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