Actual source code: zmatrixf.c

  1: #include <petsc/private/fortranimpl.h>
  2: #include <petsc/private/f90impl.h>
  3: #include <petscmat.h>
  4: #include <petscviewer.h>

  6: #if defined(PETSC_HAVE_FORTRAN_CAPS)
  7:   #define matdestroymatrices_       MATDESTROYMATRICES
  8:   #define matdestroysubmatrices_    MATDESTROYSUBMATRICES
  9:   #define matgetrowij_              MATGETROWIJ
 10:   #define matrestorerowij_          MATRESTOREROWIJ
 11:   #define matgetrow_                MATGETROW
 12:   #define matrestorerow_            MATRESTOREROW
 13:   #define matseqaijgetarray_        MATSEQAIJGETARRAY
 14:   #define matseqaijrestorearray_    MATSEQAIJRESTOREARRAY
 15:   #define matdensegetarray_         MATDENSEGETARRAY
 16:   #define matdensegetarrayread_     MATDENSEGETARRAYREAD
 17:   #define matdenserestorearray_     MATDENSERESTOREARRAY
 18:   #define matdenserestorearrayread_ MATDENSERESTOREARRAYREAD
 19:   #define matcreatesubmatrices_     MATCREATESUBMATRICES
 20:   #define matcreatesubmatricesmpi_  MATCREATESUBMATRICESMPI
 21:   #define matnullspacesetfunction_  MATNULLSPACESETFUNCTION
 22:   #define matfindnonzerorows_       MATFINDNONZEROROWS
 23: #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE)
 24:   #define matdestroymatrices_       matdestroymatrices
 25:   #define matdestroysubmatrices_    matdestroysubmatrices
 26:   #define matgetrowij_              matgetrowij
 27:   #define matrestorerowij_          matrestorerowij
 28:   #define matgetrow_                matgetrow
 29:   #define matrestorerow_            matrestorerow
 30:   #define matseqaijgetarray_        matseqaijgetarray
 31:   #define matseqaijrestorearray_    matseqaijrestorearray
 32:   #define matdensegetarray_         matdensegetarray
 33:   #define matdensegetarrayread_     matdensegetarrayread
 34:   #define matdenserestorearray_     matdenserestorearray
 35:   #define matdenserestorearrayread_ matdenserestorearrayread
 36:   #define matcreatesubmatrices_     matcreatesubmatrices
 37:   #define matcreatesubmatricesmpi_  matcreatesubmatricesmpi
 38:   #define matnullspacesetfunction_  matnullspacesetfunction
 39:   #define matfindnonzerorows_       matfindnonzerorows
 40: #endif

 42: static PetscErrorCode ournullfunction(MatNullSpace sp, Vec x, void *ctx)
 43: {
 44:   PetscCallFortranVoidFunction((*(void (*)(MatNullSpace *, Vec *, void *, PetscErrorCode *))(((PetscObject)sp)->fortran_func_pointers[0]))(&sp, &x, ctx, &ierr));
 45:   return PETSC_SUCCESS;
 46: }

 48: PETSC_EXTERN void matnullspacesetfunction_(MatNullSpace *sp, PetscErrorCode (*rem)(MatNullSpace, Vec, void *), void *ctx, PetscErrorCode *ierr)
 49: {
 50:   PetscObjectAllocateFortranPointers(*sp, 1);
 51:   ((PetscObject)*sp)->fortran_func_pointers[0] = (PetscVoidFn *)rem;

 53:   *ierr = MatNullSpaceSetFunction(*sp, ournullfunction, ctx);
 54: }

 56: PETSC_EXTERN void matgetrowij_(Mat *B, PetscInt *shift, PetscBool *sym, PetscBool *blockcompressed, PetscInt *n, PetscInt *ia, size_t *iia, PetscInt *ja, size_t *jja, PetscBool *done, PetscErrorCode *ierr)
 57: {
 58:   const PetscInt *IA, *JA;
 59:   *ierr = MatGetRowIJ(*B, *shift, *sym, *blockcompressed, n, &IA, &JA, done);
 60:   if (*ierr) return;
 61:   *iia = PetscIntAddressToFortran(ia, (PetscInt *)IA);
 62:   *jja = PetscIntAddressToFortran(ja, (PetscInt *)JA);
 63: }

 65: PETSC_EXTERN void matrestorerowij_(Mat *B, PetscInt *shift, PetscBool *sym, PetscBool *blockcompressed, PetscInt *n, PetscInt *ia, size_t *iia, PetscInt *ja, size_t *jja, PetscBool *done, PetscErrorCode *ierr)
 66: {
 67:   const PetscInt *IA = PetscIntAddressFromFortran(ia, *iia), *JA = PetscIntAddressFromFortran(ja, *jja);
 68:   *ierr = MatRestoreRowIJ(*B, *shift, *sym, *blockcompressed, n, &IA, &JA, done);
 69: }

 71: /*
 72:    This is a poor way of storing the column and value pointers
 73:   generated by MatGetRow() to be returned with MatRestoreRow()
 74:   but there is not natural,good place else to store them. Hence
 75:   Fortran programmers can only have one outstanding MatGetRows()
 76:   at a time.
 77: */
 78: static int                matgetrowactive = 0;
 79: static const PetscInt    *my_ocols        = NULL;
 80: static const PetscScalar *my_ovals        = NULL;

 82: PETSC_EXTERN void matgetrow_(Mat *mat, PetscInt *row, PetscInt *ncols, PetscInt *cols, PetscScalar *vals, PetscErrorCode *ierr)
 83: {
 84:   const PetscInt    **oocols = &my_ocols;
 85:   const PetscScalar **oovals = &my_ovals;

 87:   if (matgetrowactive) {
 88:     *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "MatGetRow_Fortran", __FILE__, PETSC_ERR_ARG_WRONGSTATE, PETSC_ERROR_INITIAL, "Cannot have two MatGetRow() active simultaneously\n\
 89:                call MatRestoreRow() before calling MatGetRow() a second time");
 90:     *ierr = PETSC_ERR_ARG_WRONGSTATE;
 91:     return;
 92:   }

 94:   CHKFORTRANNULLINTEGER(cols);
 95:   if (!cols) oocols = NULL;
 96:   CHKFORTRANNULLSCALAR(vals);
 97:   if (!vals) oovals = NULL;

 99:   *ierr = MatGetRow(*mat, *row, ncols, oocols, oovals);
100:   if (*ierr) return;

102:   if (oocols) {
103:     *ierr = PetscArraycpy(cols, my_ocols, *ncols);
104:     if (*ierr) return;
105:   }
106:   if (oovals) {
107:     *ierr = PetscArraycpy(vals, my_ovals, *ncols);
108:     if (*ierr) return;
109:   }
110:   matgetrowactive = 1;
111: }

113: PETSC_EXTERN void matrestorerow_(Mat *mat, PetscInt *row, PetscInt *ncols, PetscInt *cols, PetscScalar *vals, PetscErrorCode *ierr)
114: {
115:   const PetscInt    **oocols = &my_ocols;
116:   const PetscScalar **oovals = &my_ovals;

118:   if (!matgetrowactive) {
119:     *ierr = PetscError(PETSC_COMM_SELF, __LINE__, "MatRestoreRow_Fortran", __FILE__, PETSC_ERR_ARG_WRONGSTATE, PETSC_ERROR_INITIAL, "Must call MatGetRow() first");
120:     *ierr = PETSC_ERR_ARG_WRONGSTATE;
121:     return;
122:   }
123:   CHKFORTRANNULLINTEGER(cols);
124:   if (!cols) oocols = NULL;
125:   CHKFORTRANNULLSCALAR(vals);
126:   if (!vals) oovals = NULL;

128:   *ierr           = MatRestoreRow(*mat, *row, ncols, oocols, oovals);
129:   matgetrowactive = 0;
130: }

132: PETSC_EXTERN void matseqaijgetarray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
133: {
134:   PetscScalar *mm;
135:   PetscInt     m, n;

137:   *ierr = MatSeqAIJGetArray(*mat, &mm);
138:   if (*ierr) return;
139:   *ierr = MatGetSize(*mat, &m, &n);
140:   if (*ierr) return;
141:   *ierr = PetscScalarAddressToFortran((PetscObject)*mat, 1, fa, mm, m * n, ia);
142:   if (*ierr) return;
143: }

145: PETSC_EXTERN void matseqaijrestorearray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
146: {
147:   PetscScalar *lx;
148:   PetscInt     m, n;

150:   *ierr = MatGetSize(*mat, &m, &n);
151:   if (*ierr) return;
152:   *ierr = PetscScalarAddressFromFortran((PetscObject)*mat, fa, *ia, m * n, &lx);
153:   if (*ierr) return;
154:   *ierr = MatSeqAIJRestoreArray(*mat, &lx);
155:   if (*ierr) return;
156: }

158: PETSC_EXTERN void matdensegetarray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
159: {
160:   PetscScalar *mm;
161:   PetscInt     m, n;

163:   *ierr = MatDenseGetArray(*mat, &mm);
164:   if (*ierr) return;
165:   *ierr = MatGetSize(*mat, &m, &n);
166:   if (*ierr) return;
167:   *ierr = PetscScalarAddressToFortran((PetscObject)*mat, 1, fa, mm, m * n, ia);
168:   if (*ierr) return;
169: }

171: PETSC_EXTERN void matdenserestorearray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
172: {
173:   PetscScalar *lx;
174:   PetscInt     m, n;

176:   *ierr = MatGetSize(*mat, &m, &n);
177:   if (*ierr) return;
178:   *ierr = PetscScalarAddressFromFortran((PetscObject)*mat, fa, *ia, m * n, &lx);
179:   if (*ierr) return;
180:   *ierr = MatDenseRestoreArray(*mat, &lx);
181:   if (*ierr) return;
182: }

184: PETSC_EXTERN void matdensegetarrayread_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
185: {
186:   const PetscScalar *mm;
187:   PetscInt           m, n;

189:   *ierr = MatDenseGetArrayRead(*mat, &mm);
190:   if (*ierr) return;
191:   *ierr = MatGetSize(*mat, &m, &n);
192:   if (*ierr) return;
193:   *ierr = PetscScalarAddressToFortran((PetscObject)*mat, 1, fa, (PetscScalar *)mm, m * n, ia);
194:   if (*ierr) return;
195: }

197: PETSC_EXTERN void matdenserestorearrayread_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr)
198: {
199:   const PetscScalar *lx;
200:   PetscInt           m, n;

202:   *ierr = MatGetSize(*mat, &m, &n);
203:   if (*ierr) return;
204:   *ierr = PetscScalarAddressFromFortran((PetscObject)*mat, fa, *ia, m * n, (PetscScalar **)&lx);
205:   if (*ierr) return;
206:   *ierr = MatDenseRestoreArrayRead(*mat, &lx);
207:   if (*ierr) return;
208: }

210: /*
211:     MatCreateSubmatrices() is slightly different from C since the
212:     Fortran provides the array to hold the submatrix objects,while in C that
213:     array is allocated by the MatCreateSubmatrices()
214: */
215: PETSC_EXTERN void matcreatesubmatrices_(Mat *mat, PetscInt *n, IS *isrow, IS *iscol, MatReuse *scall, Mat *smat, PetscErrorCode *ierr)
216: {
217:   Mat     *lsmat;
218:   PetscInt i;

220:   if (*scall == MAT_INITIAL_MATRIX) {
221:     *ierr = MatCreateSubMatrices(*mat, *n, isrow, iscol, *scall, &lsmat);
222:     for (i = 0; i <= *n; i++) { /* lsmat[*n] might be a dummy matrix for saving data structure */
223:       smat[i] = lsmat[i];
224:     }
225:     *ierr = PetscFree(lsmat);
226:   } else {
227:     *ierr = MatCreateSubMatrices(*mat, *n, isrow, iscol, *scall, &smat);
228:   }
229: }

231: /*
232:     MatCreateSubmatrices() is slightly different from C since the
233:     Fortran provides the array to hold the submatrix objects,while in C that
234:     array is allocated by the MatCreateSubmatrices()
235: */
236: PETSC_EXTERN void matcreatesubmatricesmpi_(Mat *mat, PetscInt *n, IS *isrow, IS *iscol, MatReuse *scall, Mat *smat, PetscErrorCode *ierr)
237: {
238:   Mat     *lsmat;
239:   PetscInt i;

241:   if (*scall == MAT_INITIAL_MATRIX) {
242:     *ierr = MatCreateSubMatricesMPI(*mat, *n, isrow, iscol, *scall, &lsmat);
243:     for (i = 0; i <= *n; i++) { /* lsmat[*n] might be a dummy matrix for saving data structure */
244:       smat[i] = lsmat[i];
245:     }
246:     *ierr = PetscFree(lsmat);
247:   } else {
248:     *ierr = MatCreateSubMatricesMPI(*mat, *n, isrow, iscol, *scall, &smat);
249:   }
250: }

252: /*
253:     MatDestroyMatrices() is slightly different from C since the
254:     Fortran does not free the array of matrix objects, while in C that
255:     the array is freed
256: */
257: PETSC_EXTERN void matdestroymatrices_(PetscInt *n, Mat *smat, PetscErrorCode *ierr)
258: {
259:   PetscInt i;

261:   for (i = 0; i < *n; i++) {
262:     PETSC_FORTRAN_OBJECT_F_DESTROYED_TO_C_NULL(&smat[i]);
263:     *ierr = MatDestroy(&smat[i]);
264:     if (*ierr) return;
265:     PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(&smat[i]);
266:   }
267: }

269: /*
270:     MatDestroySubMatrices() is slightly different from C since the
271:     Fortran provides the array to hold the submatrix objects, while in C that
272:     array is allocated by the MatCreateSubmatrices()

274:     An extra matrix may be stored at the end of the array, hence the check see
275:     MatDestroySubMatrices_Dummy()
276: */
277: PETSC_EXTERN void matdestroysubmatrices_(PetscInt *n, Mat *smat, PetscErrorCode *ierr)
278: {
279:   Mat     *lsmat;
280:   PetscInt i;

282:   if (*n == 0) return;
283:   *ierr = PetscMalloc1(*n + 1, &lsmat);
284:   if (*ierr) return;
285:   for (i = 0; i <= *n; i++) { lsmat[i] = smat[i]; }
286:   *ierr = MatDestroySubMatrices(*n, &lsmat);
287:   if (*ierr) return;
288:   for (i = 0; i <= *n; i++) { PETSC_FORTRAN_OBJECT_C_NULL_TO_F_DESTROYED(&smat[i]); }
289: }