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