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