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