1 #include <petsc/private/fortranimpl.h> 2 #include <petsc/private/f90impl.h> 3 #include <petscmat.h> 4 #include <petscviewer.h> 5 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 41 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 } 47 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; 52 53 *ierr = MatNullSpaceSetFunction(*sp, ournullfunction, ctx); 54 } 55 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 } 64 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 } 70 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; 81 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; 86 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 } 93 94 CHKFORTRANNULLINTEGER(cols); 95 if (!cols) oocols = NULL; 96 CHKFORTRANNULLSCALAR(vals); 97 if (!vals) oovals = NULL; 98 99 *ierr = MatGetRow(*mat, *row, ncols, oocols, oovals); 100 if (*ierr) return; 101 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 } 112 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; 117 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; 127 128 *ierr = MatRestoreRow(*mat, *row, ncols, oocols, oovals); 129 matgetrowactive = 0; 130 } 131 132 PETSC_EXTERN void matseqaijgetarray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 133 { 134 PetscScalar *mm; 135 PetscInt m, n; 136 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 } 144 145 PETSC_EXTERN void matseqaijrestorearray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 146 { 147 PetscScalar *lx; 148 PetscInt m, n; 149 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 } 157 158 PETSC_EXTERN void matdensegetarray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 159 { 160 PetscScalar *mm; 161 PetscInt m, n; 162 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 } 170 171 PETSC_EXTERN void matdenserestorearray_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 172 { 173 PetscScalar *lx; 174 PetscInt m, n; 175 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 } 183 184 PETSC_EXTERN void matdensegetarrayread_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 185 { 186 const PetscScalar *mm; 187 PetscInt m, n; 188 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 } 196 197 PETSC_EXTERN void matdenserestorearrayread_(Mat *mat, PetscScalar *fa, size_t *ia, PetscErrorCode *ierr) 198 { 199 const PetscScalar *lx; 200 PetscInt m, n; 201 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 } 209 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; 219 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 } 230 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; 240 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 } 251 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; 260 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 } 268 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() 273 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; 281 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 } 290