xref: /petsc/src/mat/interface/ftn-custom/zmatrixf.c (revision 4eb428fdc6f36238aef3665003db33fd4cbae8e2) 
1 #include <petsc-private/fortranimpl.h>
2 #include <petscmat.h>
3 
4 #if defined(PETSC_HAVE_FORTRAN_CAPS)
5 #define matdestroymatrices_              MATDESTROYMATRICES
6 #define matgetfactor_                    MATGETFACTOR
7 #define matfactorgetsolverpackage_       MATFACTORGETSOLVERPACKAGE
8 #define matgetrowij_                     MATGETROWIJ
9 #define matrestorerowij_                 MATRESTOREROWIJ
10 #define matgetrow_                       MATGETROW
11 #define matrestorerow_                   MATRESTOREROW
12 #define matload_                         MATLOAD
13 #define matview_                         MATVIEW
14 #define matgetarray_                     MATGETARRAY
15 #define matrestorearray_                 MATRESTOREARRAY
16 #define matconvert_                      MATCONVERT
17 #define matgetsubmatrices_               MATGETSUBMATRICES
18 #define matzerorowscolumns_              MATZEROROWSCOLUMNS
19 #define matzerorowscolumnsis_            MATZEROROWSCOLUMNSIS
20 #define matzerorowsstencil_              MATZEROROWSSTENCIL
21 #define matzerorows_                     MATZEROROWS
22 #define matzerorowsis_                   MATZEROROWSIS
23 #define matzerorowslocal_                MATZEROROWSLOCAL
24 #define matzerorowslocalis_              MATZEROROWSLOCALIS
25 #define matzerorowscolumnslocal_         MATZEROROWSCOLUMNSLOCAL
26 #define matzerorowscolumnslocalis_       MATZEROROWSCOLUMNSLOCALIS
27 #define matsetoptionsprefix_             MATSETOPTIONSPREFIX
28 #define matgetvecs_                      MATGETVECS
29 #define matnullspaceremove_              MATNULLSPACEREMOVE
30 #define matgetinfo_                      MATGETINFO
31 #define matlufactor_                     MATLUFACTOR
32 #define matilufactor_                    MATILUFACTOR
33 #define matlufactorsymbolic_             MATLUFACTORSYMBOLIC
34 #define matlufactornumeric_              MATLUFACTORNUMERIC
35 #define matcholeskyfactor_               MATCHOLESKYFACTOR
36 #define matcholeskyfactorsymbolic_       MATCHOLESKYFACTORSYMBOLIC
37 #define matcholeskyfactornumeric_        MATCHOLESKYFACTORNUMERIC
38 #define matilufactorsymbolic_            MATILUFACTORSYMBOLIC
39 #define maticcfactorsymbolic_            MATICCFACTORSYMBOLIC
40 #define maticcfactor_                    MATICCFACTOR
41 #define matfactorinfoinitialize_         MATFACTORINFOINITIALIZE
42 #define matnullspacesetfunction_         MATNULLSPACESETFUNCTION
43 #define matfindnonzerorows_              MATFINDNONZEROROWS
44 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
45 #define matdestroymatrices_              matdestroymatrices_
46 #define matgetfactor_                    matgetfactor
47 #define matfactorgetsolverpackage_       matfactorgetsolverpackage
48 #define matgetvecs_                      matgetvecs
49 #define matgetrowij_                     matgetrowij
50 #define matrestorerowij_                 matrestorerowij
51 #define matgetrow_                       matgetrow
52 #define matrestorerow_                   matrestorerow
53 #define matview_                         matview
54 #define matload_                         matload
55 #define matgetarray_                     matgetarray
56 #define matrestorearray_                 matrestorearray
57 #define matconvert_                      matconvert
58 #define matgetsubmatrices_               matgetsubmatrices
59 #define matzerorowscolumns_              matzerorowscolumns
60 #define matzerorowscolumnsis_            matzerorowscolumnsis
61 #define matzerorowsstencil_              matzerorowsstencil
62 #define matzerorows_                     matzerorows
63 #define matzerorowsis_                   matzerorowsis
64 #define matzerorowslocal_                matzerorowslocal
65 #define matzerorowslocalis_              matzerorowslocalis
66 #define matzerorowscolumnslocal_         matzerorowscolumnslocal
67 #define matzerorowscolumnslocalis_       matzerorowscolumnslocalis
68 #define matsetoptionsprefix_             matsetoptionsprefix
69 #define matnullspaceremove_              matnullspaceremove
70 #define matgetinfo_                      matgetinfo
71 #define matlufactor_                     matlufactor
72 #define matilufactor_                    matilufactor
73 #define matlufactorsymbolic_             matlufactorsymbolic
74 #define matlufactornumeric_              matlufactornumeric
75 #define matcholeskyfactor_               matcholeskyfactor
76 #define matcholeskyfactorsymbolic_       matcholeskyfactorsymbolic
77 #define matcholeskyfactornumeric_        matcholeskyfactornumeric
78 #define matilufactorsymbolic_            matilufactorsymbolic
79 #define maticcfactorsymbolic_            maticcfactorsymbolic
80 #define maticcfactor_                    maticcfactor
81 #define matfactorinfoinitialize_         matfactorinfoinitialize
82 #define matnullspacesetfunction_         matnullspacesetfunction
83 #define matfindnonzerorows_              matfindnonzerorows
84 #endif
85 
86 EXTERN_C_BEGIN
87 
88 static PetscErrorCode ournullfunction(MatNullSpace sp,Vec x,void *ctx)
89 {
90   PetscErrorCode ierr = 0;
91   (*(void (PETSC_STDCALL *)(MatNullSpace*,Vec*,void*,PetscErrorCode*))(((PetscObject)sp)->fortran_func_pointers[0]))(&sp,&x,ctx,&ierr);CHKERRQ(ierr);
92   return 0;
93 }
94 
95 void PETSC_STDCALL  matnullspacesetfunction_(MatNullSpace *sp, PetscErrorCode (*rem)(MatNullSpace,Vec,void*),void *ctx,PetscErrorCode *ierr)
96 {
97   PetscObjectAllocateFortranPointers(*sp,1);
98   ((PetscObject)*sp)->fortran_func_pointers[0] = (PetscVoidFunction)rem;
99   *ierr = MatNullSpaceSetFunction(*sp,ournullfunction,ctx);
100 }
101 
102 void PETSC_STDCALL   matgetvecs_(Mat *mat,Vec *right,Vec *left, int *ierr )
103 {
104   CHKFORTRANNULLOBJECT(right);
105   CHKFORTRANNULLOBJECT(left);
106   *ierr = MatGetVecs(*mat,right,left);
107 }
108 
109 void PETSC_STDCALL matgetrowij_(Mat *B,PetscInt *shift,PetscBool  *sym,PetscBool  *blockcompressed,PetscInt *n,PetscInt *ia,size_t *iia,
110                                 PetscInt *ja,size_t *jja,PetscBool  *done,PetscErrorCode *ierr)
111 {
112   PetscInt *IA,*JA;
113   *ierr = MatGetRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done);if (*ierr) return;
114   *iia  = PetscIntAddressToFortran(ia,IA);
115   *jja  = PetscIntAddressToFortran(ja,JA);
116 }
117 
118 void PETSC_STDCALL matrestorerowij_(Mat *B,PetscInt *shift,PetscBool  *sym,PetscBool  *blockcompressed, PetscInt *n,PetscInt *ia,size_t *iia,
119                                     PetscInt *ja,size_t *jja,PetscBool  *done,PetscErrorCode *ierr)
120 {
121   PetscInt *IA = PetscIntAddressFromFortran(ia,*iia),*JA = PetscIntAddressFromFortran(ja,*jja);
122   *ierr = MatRestoreRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done);
123 }
124 
125 /*
126    This is a poor way of storing the column and value pointers
127   generated by MatGetRow() to be returned with MatRestoreRow()
128   but there is not natural,good place else to store them. Hence
129   Fortran programmers can only have one outstanding MatGetRows()
130   at a time.
131 */
132 static PetscErrorCode    matgetrowactive = 0;
133 static const PetscInt    *my_ocols = 0;
134 static const PetscScalar *my_ovals = 0;
135 
136 void PETSC_STDCALL matgetrow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr)
137 {
138   const PetscInt    **oocols = &my_ocols;
139   const PetscScalar **oovals = &my_ovals;
140 
141   if (matgetrowactive) {
142     PetscError(PETSC_COMM_SELF,__LINE__,"MatGetRow_Fortran",__FILE__,__SDIR__,PETSC_ERR_ARG_WRONGSTATE,PETSC_ERROR_INITIAL,
143                "Cannot have two MatGetRow() active simultaneously\n\
144                call MatRestoreRow() before calling MatGetRow() a second time");
145      *ierr = 1;
146      return;
147   }
148 
149   CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = PETSC_NULL;
150   CHKFORTRANNULLSCALAR(vals);  if (!vals) oovals = PETSC_NULL;
151 
152   *ierr = MatGetRow(*mat,*row,ncols,oocols,oovals);
153   if (*ierr) return;
154 
155   if (oocols) { *ierr = PetscMemcpy(cols,my_ocols,(*ncols)*sizeof(PetscInt)); if (*ierr) return;}
156   if (oovals) { *ierr = PetscMemcpy(vals,my_ovals,(*ncols)*sizeof(PetscScalar)); if (*ierr) return; }
157   matgetrowactive = 1;
158 }
159 
160 void PETSC_STDCALL matrestorerow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr)
161 {
162   const PetscInt         **oocols = &my_ocols;
163   const PetscScalar **oovals = &my_ovals;
164   if (!matgetrowactive) {
165     PetscError(PETSC_COMM_SELF,__LINE__,"MatRestoreRow_Fortran",__FILE__,__SDIR__,PETSC_ERR_ARG_WRONGSTATE,PETSC_ERROR_INITIAL,
166                "Must call MatGetRow() first");
167      *ierr = 1;
168      return;
169   }
170   CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = PETSC_NULL;
171   CHKFORTRANNULLSCALAR(vals);  if (!vals) oovals = PETSC_NULL;
172 
173   *ierr = MatRestoreRow(*mat,*row,ncols,oocols,oovals);
174   matgetrowactive = 0;
175 }
176 
177 void PETSC_STDCALL matview_(Mat *mat,PetscViewer *vin,PetscErrorCode *ierr)
178 {
179   PetscViewer v;
180   PetscPatchDefaultViewers_Fortran(vin,v);
181   *ierr = MatView(*mat,v);
182 }
183 
184 void PETSC_STDCALL matload_(Mat *mat,PetscViewer *vin,PetscErrorCode *ierr)
185 {
186   PetscViewer v;
187   PetscPatchDefaultViewers_Fortran(vin,v);
188   *ierr = MatLoad(*mat,v);
189 }
190 
191 void PETSC_STDCALL matgetarray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr)
192 {
193   PetscScalar *mm;
194   PetscInt    m,n;
195 
196   *ierr = MatGetArray(*mat,&mm); if (*ierr) return;
197   *ierr = MatGetSize(*mat,&m,&n);  if (*ierr) return;
198   *ierr = PetscScalarAddressToFortran((PetscObject)*mat,1,fa,mm,m*n,ia); if (*ierr) return;
199 }
200 
201 void PETSC_STDCALL matrestorearray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr)
202 {
203   PetscScalar          *lx;
204   PetscInt                  m,n;
205 
206   *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return;
207   *ierr = PetscScalarAddressFromFortran((PetscObject)*mat,fa,*ia,m*n,&lx);if (*ierr) return;
208   *ierr = MatRestoreArray(*mat,&lx);if (*ierr) return;
209 }
210 
211 void PETSC_STDCALL matfactorgetsolverpackage_(Mat *mat,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
212 {
213   const char *tname;
214 
215   *ierr = MatFactorGetSolverPackage(*mat,&tname);if (*ierr) return;
216   if (name != PETSC_NULL_CHARACTER_Fortran) {
217     *ierr = PetscStrncpy(name,tname,len);if (*ierr) return;
218   }
219   FIXRETURNCHAR(PETSC_TRUE,name,len);
220 }
221 
222 void PETSC_STDCALL matgetfactor_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),MatFactorType *ftype,Mat *M,PetscErrorCode *ierr PETSC_END_LEN(len))
223 {
224   char *t;
225   FIXCHAR(outtype,len,t);
226   *ierr = MatGetFactor(*mat,t,*ftype,M);
227   FREECHAR(outtype,t);
228 }
229 
230 void PETSC_STDCALL matconvert_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),MatReuse *reuse,Mat *M,PetscErrorCode *ierr PETSC_END_LEN(len))
231 {
232   char *t;
233   FIXCHAR(outtype,len,t);
234   *ierr = MatConvert(*mat,t,*reuse,M);
235   FREECHAR(outtype,t);
236 }
237 
238 /*
239     MatGetSubmatrices() is slightly different from C since the
240     Fortran provides the array to hold the submatrix objects,while in C that
241     array is allocated by the MatGetSubmatrices()
242 */
243 void PETSC_STDCALL matgetsubmatrices_(Mat *mat,PetscInt *n,IS *isrow,IS *iscol,MatReuse *scall,Mat *smat,PetscErrorCode *ierr)
244 {
245   Mat *lsmat;
246   PetscInt i;
247 
248   if (*scall == MAT_INITIAL_MATRIX) {
249     *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&lsmat);
250     for (i=0; i<*n; i++) {
251       smat[i] = lsmat[i];
252     }
253     *ierr = PetscFree(lsmat);
254   } else {
255     *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&smat);
256   }
257 }
258 
259 /*
260     MatDestroyMatrices() is slightly different from C since the
261     Fortran provides the array to hold the submatrix objects,while in C that
262     array is allocated by the MatGetSubmatrices()
263 */
264 void PETSC_STDCALL matdestroymatrices_(Mat *mat,PetscInt *n,Mat *smat,PetscErrorCode *ierr)
265 {
266   PetscInt i;
267 
268   for (i=0; i<*n; i++) {
269     *ierr = MatDestroy(&smat[i]);if (*ierr) return;
270   }
271 }
272 
273 void PETSC_STDCALL matzerorowscolumns_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
274 {
275   CHKFORTRANNULLOBJECTDEREFERENCE(x);
276   CHKFORTRANNULLOBJECTDEREFERENCE(b);
277   *ierr = MatZeroRowsColumns(*mat,*numRows,rows,*diag,*x,*b);
278 }
279 
280 void PETSC_STDCALL matzerorowscolumnsis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
281 {
282   CHKFORTRANNULLOBJECTDEREFERENCE(x);
283   CHKFORTRANNULLOBJECTDEREFERENCE(b);
284   *ierr = MatZeroRowsColumnsIS(*mat,*is,*diag,*x,*b);
285 }
286 
287 void PETSC_STDCALL matzerorowsstencil_(Mat *mat,PetscInt *numRows,MatStencil *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
288 {
289   CHKFORTRANNULLOBJECTDEREFERENCE(x);
290   CHKFORTRANNULLOBJECTDEREFERENCE(b);
291   *ierr = MatZeroRowsStencil(*mat,*numRows,rows,*diag,*x,*b);
292 }
293 
294 void PETSC_STDCALL matzerorows_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
295 {
296   CHKFORTRANNULLOBJECTDEREFERENCE(x);
297   CHKFORTRANNULLOBJECTDEREFERENCE(b);
298   *ierr = MatZeroRows(*mat,*numRows,rows,*diag,*x,*b);
299 }
300 
301 void PETSC_STDCALL matzerorowsis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
302 {
303   CHKFORTRANNULLOBJECTDEREFERENCE(x);
304   CHKFORTRANNULLOBJECTDEREFERENCE(b);
305   *ierr = MatZeroRowsIS(*mat,*is,*diag,*x,*b);
306 }
307 
308 void PETSC_STDCALL matzerorowslocal_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
309 {
310   CHKFORTRANNULLOBJECTDEREFERENCE(x);
311   CHKFORTRANNULLOBJECTDEREFERENCE(b);
312   *ierr = MatZeroRowsLocal(*mat,*numRows,rows,*diag,*x,*b);
313 }
314 
315 void PETSC_STDCALL matzerorowslocalis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
316 {
317   CHKFORTRANNULLOBJECTDEREFERENCE(x);
318   CHKFORTRANNULLOBJECTDEREFERENCE(b);
319   *ierr = MatZeroRowsLocalIS(*mat,*is,*diag,*x,*b);
320 }
321 
322 void PETSC_STDCALL matzerorowscolumnslocal_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
323 {
324   CHKFORTRANNULLOBJECTDEREFERENCE(x);
325   CHKFORTRANNULLOBJECTDEREFERENCE(b);
326   *ierr = MatZeroRowsColumnsLocal(*mat,*numRows,rows,*diag,*x,*b);
327 }
328 
329 void PETSC_STDCALL matzerorowscolumnslocalis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr)
330 {
331   CHKFORTRANNULLOBJECTDEREFERENCE(x);
332   CHKFORTRANNULLOBJECTDEREFERENCE(b);
333   *ierr = MatZeroRowsColumnsLocalIS(*mat,*is,*diag,*x,*b);
334 }
335 
336 void PETSC_STDCALL matsetoptionsprefix_(Mat *mat,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len))
337 {
338   char *t;
339 
340   FIXCHAR(prefix,len,t);
341   *ierr = MatSetOptionsPrefix(*mat,t);
342   FREECHAR(prefix,t);
343 }
344 
345 void PETSC_STDCALL matnullspaceremove_(MatNullSpace *sp,Vec *vec,Vec *out,PetscErrorCode *ierr)
346 {
347   CHKFORTRANNULLOBJECT(out);
348   *ierr = MatNullSpaceRemove(*sp,*vec,out);
349 }
350 
351 void PETSC_STDCALL   matgetinfo_(Mat *mat,MatInfoType *flag,MatInfo *info, int *__ierr )
352 {
353   *__ierr = MatGetInfo(*mat,*flag,info);
354 }
355 
356 void PETSC_STDCALL   matlufactor_(Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr )
357 {
358   *__ierr = MatLUFactor(*mat,*row,*col,info);
359 }
360 
361 void PETSC_STDCALL   matilufactor_(Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr )
362 {
363   *__ierr = MatILUFactor(*mat,*row,*col,info);
364 }
365 
366 void PETSC_STDCALL   matlufactorsymbolic_(Mat *fact,Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr )
367 {
368   *__ierr = MatLUFactorSymbolic(*fact,*mat,*row,*col,info);
369 }
370 
371 void PETSC_STDCALL   matlufactornumeric_(Mat *fact,Mat *mat, MatFactorInfo *info, int *__ierr )
372 {
373   *__ierr = MatLUFactorNumeric(*fact,*mat,info);
374 }
375 
376 void PETSC_STDCALL   matcholeskyfactor_(Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr )
377 {
378   *__ierr = MatCholeskyFactor(*mat,*perm,info);
379 }
380 
381 void PETSC_STDCALL   matcholeskyfactorsymbolic_(Mat *fact,Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr )
382 {
383   *__ierr = MatCholeskyFactorSymbolic(*fact,*mat,*perm,info);
384 }
385 
386 void PETSC_STDCALL   matcholeskyfactornumeric_(Mat *fact,Mat *mat, MatFactorInfo *info, int *__ierr )
387 {
388   *__ierr = MatCholeskyFactorNumeric(*fact,*mat,info);
389 }
390 
391 void PETSC_STDCALL   matilufactorsymbolic_(Mat *fact,Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr )
392 {
393   *__ierr = MatILUFactorSymbolic(*fact,*mat,*row,*col,info);
394 }
395 
396 void PETSC_STDCALL   maticcfactorsymbolic_(Mat *fact,Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr )
397 {
398   *__ierr = MatICCFactorSymbolic(*fact,*mat,*perm,info);
399 }
400 
401 void PETSC_STDCALL   maticcfactor_(Mat *mat,IS *row, MatFactorInfo* info, int *__ierr )
402 {
403   *__ierr = MatICCFactor(*mat,*row,info);
404 }
405 
406 void PETSC_STDCALL   matfactorinfoinitialize_(MatFactorInfo *info, int *__ierr )
407 {
408   *__ierr = MatFactorInfoInitialize(info);
409 }
410 
411 EXTERN_C_END
412