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