1 #include "private/fortranimpl.h" 2 #include "petscmat.h" 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define matgetrowij_ MATGETROWIJ 6 #define matrestorerowij_ MATRESTOREROWIJ 7 #define matgetrow_ MATGETROW 8 #define matrestorerow_ MATRESTOREROW 9 #define matview_ MATVIEW 10 #define matgetarray_ MATGETARRAY 11 #define matrestorearray_ MATRESTOREARRAY 12 #define matconvert_ MATCONVERT 13 #define matgetsubmatrices_ MATGETSUBMATRICES 14 #define matzerorows_ MATZEROROWS 15 #define matzerorowsis_ MATZEROROWSIS 16 #define matzerorowslocal_ MATZEROROWSLOCAL 17 #define matzerorowslocalis_ MATZEROROWSLOCALIS 18 #define matsetoptionsprefix_ MATSETOPTIONSPREFIX 19 #define matgetvecs_ MATGETVECS 20 #define matnullspaceremove_ MATNULLSPACEREMOVE 21 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 22 #define matgetvecs_ matgetvecs 23 #define matgetrowij_ matgetrowij 24 #define matrestorerowij_ matrestorerowij 25 #define matgetrow_ matgetrow 26 #define matrestorerow_ matrestorerow 27 #define matview_ matview 28 #define matgetarray_ matgetarray 29 #define matrestorearray_ matrestorearray 30 #define matconvert_ matconvert 31 #define matgetsubmatrices_ matgetsubmatrices 32 #define matzerorows_ matzerorows 33 #define matzerorowsis_ matzerorowsis 34 #define matzerorowslocal_ matzerorowslocal 35 #define matzerorowslocalis_ matzerorowslocalis 36 #define matsetoptionsprefix_ matsetoptionsprefix 37 #define matnullspaceremove_ matnullspaceremove 38 #endif 39 40 EXTERN_C_BEGIN 41 42 void PETSC_STDCALL matgetvecs_(Mat *mat,Vec *right,Vec *left, int *ierr ) 43 { 44 CHKFORTRANNULLOBJECT(right); 45 CHKFORTRANNULLOBJECT(left); 46 *ierr = MatGetVecs(*mat,right,left); 47 } 48 49 void PETSC_STDCALL matgetrowij_(Mat *B,PetscInt *shift,PetscTruth *sym,PetscTruth *blockcompressed,PetscInt *n,PetscInt *ia,size_t *iia, 50 PetscInt *ja,size_t *jja,PetscTruth *done,PetscErrorCode *ierr) 51 { 52 PetscInt *IA,*JA; 53 *ierr = MatGetRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done);if (*ierr) return; 54 *iia = PetscIntAddressToFortran(ia,IA); 55 *jja = PetscIntAddressToFortran(ja,JA); 56 } 57 58 void PETSC_STDCALL matrestorerowij_(Mat *B,PetscInt *shift,PetscTruth *sym,PetscTruth *blockcompressed, PetscInt *n,PetscInt *ia,size_t *iia, 59 PetscInt *ja,size_t *jja,PetscTruth *done,PetscErrorCode *ierr) 60 { 61 PetscInt *IA = PetscIntAddressFromFortran(ia,*iia),*JA = PetscIntAddressFromFortran(ja,*jja); 62 *ierr = MatRestoreRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done); 63 } 64 65 /* 66 This is a poor way of storing the column and value pointers 67 generated by MatGetRow() to be returned with MatRestoreRow() 68 but there is not natural,good place else to store them. Hence 69 Fortran programmers can only have one outstanding MatGetRows() 70 at a time. 71 */ 72 static PetscErrorCode matgetrowactive = 0; 73 static const PetscInt *my_ocols = 0; 74 static const PetscScalar *my_ovals = 0; 75 76 void PETSC_STDCALL matgetrow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr) 77 { 78 const PetscInt **oocols = &my_ocols; 79 const PetscScalar **oovals = &my_ovals; 80 81 if (matgetrowactive) { 82 PetscError(__LINE__,"MatGetRow_Fortran",__FILE__,__SDIR__,1,0, 83 "Cannot have two MatGetRow() active simultaneously\n\ 84 call MatRestoreRow() before calling MatGetRow() a second time"); 85 *ierr = 1; 86 return; 87 } 88 89 CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = PETSC_NULL; 90 CHKFORTRANNULLSCALAR(vals); if (!vals) oovals = PETSC_NULL; 91 92 *ierr = MatGetRow(*mat,*row,ncols,oocols,oovals); 93 if (*ierr) return; 94 95 if (oocols) { *ierr = PetscMemcpy(cols,my_ocols,(*ncols)*sizeof(PetscInt)); if (*ierr) return;} 96 if (oovals) { *ierr = PetscMemcpy(vals,my_ovals,(*ncols)*sizeof(PetscScalar)); if (*ierr) return; } 97 matgetrowactive = 1; 98 } 99 100 void PETSC_STDCALL matrestorerow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr) 101 { 102 const PetscInt **oocols = &my_ocols; 103 const PetscScalar **oovals = &my_ovals; 104 if (!matgetrowactive) { 105 PetscError(__LINE__,"MatRestoreRow_Fortran",__FILE__,__SDIR__,1,0, 106 "Must call MatGetRow() first"); 107 *ierr = 1; 108 return; 109 } 110 CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = PETSC_NULL; 111 CHKFORTRANNULLSCALAR(vals); if (!vals) oovals = PETSC_NULL; 112 113 *ierr = MatRestoreRow(*mat,*row,ncols,oocols,oovals); 114 matgetrowactive = 0; 115 } 116 117 void PETSC_STDCALL matview_(Mat *mat,PetscViewer *vin,PetscErrorCode *ierr) 118 { 119 PetscViewer v; 120 PetscPatchDefaultViewers_Fortran(vin,v); 121 *ierr = MatView(*mat,v); 122 } 123 124 void PETSC_STDCALL matgetarray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 125 { 126 PetscScalar *mm; 127 PetscInt m,n; 128 129 *ierr = MatGetArray(*mat,&mm); if (*ierr) return; 130 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 131 *ierr = PetscScalarAddressToFortran((PetscObject)*mat,1,fa,mm,m*n,ia); if (*ierr) return; 132 } 133 134 void PETSC_STDCALL matrestorearray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 135 { 136 PetscScalar *lx; 137 PetscInt m,n; 138 139 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 140 *ierr = PetscScalarAddressFromFortran((PetscObject)*mat,fa,*ia,m*n,&lx);if (*ierr) return; 141 *ierr = MatRestoreArray(*mat,&lx);if (*ierr) return; 142 } 143 144 void PETSC_STDCALL matconvert_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),MatReuse *reuse,Mat *M,PetscErrorCode *ierr PETSC_END_LEN(len)) 145 { 146 char *t; 147 FIXCHAR(outtype,len,t); 148 *ierr = MatConvert(*mat,t,*reuse,M); 149 FREECHAR(outtype,t); 150 } 151 152 /* 153 MatGetSubmatrices() is slightly different from C since the 154 Fortran provides the array to hold the submatrix objects,while in C that 155 array is allocated by the MatGetSubmatrices() 156 */ 157 void PETSC_STDCALL matgetsubmatrices_(Mat *mat,PetscInt *n,IS *isrow,IS *iscol,MatReuse *scall,Mat *smat,PetscErrorCode *ierr) 158 { 159 Mat *lsmat; 160 PetscInt i; 161 162 if (*scall == MAT_INITIAL_MATRIX) { 163 *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&lsmat); 164 for (i=0; i<*n; i++) { 165 smat[i] = lsmat[i]; 166 } 167 *ierr = PetscFree(lsmat); 168 } else { 169 *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&smat); 170 } 171 } 172 173 void PETSC_STDCALL matzerorows_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,PetscErrorCode *ierr) 174 { 175 *ierr = MatZeroRows(*mat,*numRows,rows,*diag); 176 } 177 178 void PETSC_STDCALL matzerorowsis_(Mat *mat,IS *is,PetscScalar *diag,PetscErrorCode *ierr) 179 { 180 *ierr = MatZeroRowsIS(*mat,*is,*diag); 181 } 182 183 void PETSC_STDCALL matzerorowslocal_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,PetscErrorCode *ierr) 184 { 185 *ierr = MatZeroRowsLocal(*mat,*numRows,rows,*diag); 186 } 187 188 void PETSC_STDCALL matzerorowslocalis_(Mat *mat,IS *is,PetscScalar *diag,PetscErrorCode *ierr) 189 { 190 *ierr = MatZeroRowsLocalIS(*mat,*is,*diag); 191 } 192 193 194 void PETSC_STDCALL matsetoptionsprefix_(Mat *mat,CHAR prefix PETSC_MIXED_LEN(len), 195 PetscErrorCode *ierr PETSC_END_LEN(len)) 196 { 197 char *t; 198 199 FIXCHAR(prefix,len,t); 200 *ierr = MatSetOptionsPrefix(*mat,t); 201 FREECHAR(prefix,t); 202 } 203 204 void PETSC_STDCALL matnullspaceremove_(MatNullSpace *sp,Vec *vec,Vec *out,PetscErrorCode *ierr) 205 { 206 CHKFORTRANNULLOBJECT(out); 207 *ierr = MatNullSpaceRemove(*sp,*vec,out); 208 } 209 210 EXTERN_C_END 211