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