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