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