1 #include <petsc-private/fortranimpl.h> 2 #include <petscmat.h> 3 #include <petscviewer.h> 4 5 #if defined(PETSC_HAVE_FORTRAN_CAPS) 6 #define matdestroymatrices_ MATDESTROYMATRICES 7 #define matgetfactor_ MATGETFACTOR 8 #define matfactorgetsolverpackage_ MATFACTORGETSOLVERPACKAGE 9 #define matgetrowij_ MATGETROWIJ 10 #define matrestorerowij_ MATRESTOREROWIJ 11 #define matgetrow_ MATGETROW 12 #define matrestorerow_ MATRESTOREROW 13 #define matload_ MATLOAD 14 #define matview_ MATVIEW 15 #define matseqaijgetarray_ MATSEQAIJGETARRAY 16 #define matseqaijrestorearray MATSEQAIJRESTOREARRAY 17 #define matdensegetarray_ MATDENSEGETARRAY 18 #define matdenserestorearray_ MATDENSERESTOREARRAY 19 #define matconvert_ MATCONVERT 20 #define matgetsubmatrices_ MATGETSUBMATRICES 21 #define matzerorowscolumns_ MATZEROROWSCOLUMNS 22 #define matzerorowscolumnsis_ MATZEROROWSCOLUMNSIS 23 #define matzerorowsstencil_ MATZEROROWSSTENCIL 24 #define matzerorowscolumnsstencil_ MATZEROROWSCOLUMNSSTENCIL 25 #define matzerorows_ MATZEROROWS 26 #define matzerorowsis_ MATZEROROWSIS 27 #define matzerorowslocal_ MATZEROROWSLOCAL 28 #define matzerorowslocalis_ MATZEROROWSLOCALIS 29 #define matzerorowscolumnslocal_ MATZEROROWSCOLUMNSLOCAL 30 #define matzerorowscolumnslocalis_ MATZEROROWSCOLUMNSLOCALIS 31 #define matsetoptionsprefix_ MATSETOPTIONSPREFIX 32 #define matgetvecs_ MATGETVECS 33 #define matnullspaceremove_ MATNULLSPACEREMOVE 34 #define matgetinfo_ MATGETINFO 35 #define matlufactor_ MATLUFACTOR 36 #define matilufactor_ MATILUFACTOR 37 #define matlufactorsymbolic_ MATLUFACTORSYMBOLIC 38 #define matlufactornumeric_ MATLUFACTORNUMERIC 39 #define matcholeskyfactor_ MATCHOLESKYFACTOR 40 #define matcholeskyfactorsymbolic_ MATCHOLESKYFACTORSYMBOLIC 41 #define matcholeskyfactornumeric_ MATCHOLESKYFACTORNUMERIC 42 #define matilufactorsymbolic_ MATILUFACTORSYMBOLIC 43 #define maticcfactorsymbolic_ MATICCFACTORSYMBOLIC 44 #define maticcfactor_ MATICCFACTOR 45 #define matfactorinfoinitialize_ MATFACTORINFOINITIALIZE 46 #define matnullspacesetfunction_ MATNULLSPACESETFUNCTION 47 #define matfindnonzerorows_ MATFINDNONZEROROWS 48 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 49 #define matdestroymatrices_ matdestroymatrices_ 50 #define matgetfactor_ matgetfactor 51 #define matfactorgetsolverpackage_ matfactorgetsolverpackage 52 #define matgetvecs_ matgetvecs 53 #define matgetrowij_ matgetrowij 54 #define matrestorerowij_ matrestorerowij 55 #define matgetrow_ matgetrow 56 #define matrestorerow_ matrestorerow 57 #define matview_ matview 58 #define matload_ matload 59 #define matseqaijgetarray_ matseqaijgetarray 60 #define matseqaijrestorearray_ matseqaijrestorearray 61 #define matdensegetarray_ matdensegetarray 62 #define matdenserestorearray_ matdenserestorearray 63 #define matconvert_ matconvert 64 #define matgetsubmatrices_ matgetsubmatrices 65 #define matzerorowscolumns_ matzerorowscolumns 66 #define matzerorowscolumnsis_ matzerorowscolumnsis 67 #define matzerorowsstencil_ matzerorowsstencil 68 #define matzerorowscolumnsstencil_ matzerorowscolumnsstencil 69 #define matzerorows_ matzerorows 70 #define matzerorowsis_ matzerorowsis 71 #define matzerorowslocal_ matzerorowslocal 72 #define matzerorowslocalis_ matzerorowslocalis 73 #define matzerorowscolumnslocal_ matzerorowscolumnslocal 74 #define matzerorowscolumnslocalis_ matzerorowscolumnslocalis 75 #define matsetoptionsprefix_ matsetoptionsprefix 76 #define matnullspaceremove_ matnullspaceremove 77 #define matgetinfo_ matgetinfo 78 #define matlufactor_ matlufactor 79 #define matilufactor_ matilufactor 80 #define matlufactorsymbolic_ matlufactorsymbolic 81 #define matlufactornumeric_ matlufactornumeric 82 #define matcholeskyfactor_ matcholeskyfactor 83 #define matcholeskyfactorsymbolic_ matcholeskyfactorsymbolic 84 #define matcholeskyfactornumeric_ matcholeskyfactornumeric 85 #define matilufactorsymbolic_ matilufactorsymbolic 86 #define maticcfactorsymbolic_ maticcfactorsymbolic 87 #define maticcfactor_ maticcfactor 88 #define matfactorinfoinitialize_ matfactorinfoinitialize 89 #define matnullspacesetfunction_ matnullspacesetfunction 90 #define matfindnonzerorows_ matfindnonzerorows 91 #endif 92 93 EXTERN_C_BEGIN 94 95 static PetscErrorCode ournullfunction(MatNullSpace sp,Vec x,void *ctx) 96 { 97 PetscErrorCode ierr = 0; 98 (*(void (PETSC_STDCALL *)(MatNullSpace*,Vec*,void*,PetscErrorCode*))(((PetscObject)sp)->fortran_func_pointers[0]))(&sp,&x,ctx,&ierr);CHKERRQ(ierr); 99 return 0; 100 } 101 102 void PETSC_STDCALL matnullspacesetfunction_(MatNullSpace *sp, PetscErrorCode (*rem)(MatNullSpace,Vec,void*),void *ctx,PetscErrorCode *ierr) 103 { 104 PetscObjectAllocateFortranPointers(*sp,1); 105 ((PetscObject)*sp)->fortran_func_pointers[0] = (PetscVoidFunction)rem; 106 107 *ierr = MatNullSpaceSetFunction(*sp,ournullfunction,ctx); 108 } 109 110 void PETSC_STDCALL matgetvecs_(Mat *mat,Vec *right,Vec *left, int *ierr) 111 { 112 CHKFORTRANNULLOBJECT(right); 113 CHKFORTRANNULLOBJECT(left); 114 *ierr = MatGetVecs(*mat,right,left); 115 } 116 117 void PETSC_STDCALL matgetrowij_(Mat *B,PetscInt *shift,PetscBool *sym,PetscBool *blockcompressed,PetscInt *n,PetscInt *ia,size_t *iia, 118 PetscInt *ja,size_t *jja,PetscBool *done,PetscErrorCode *ierr) 119 { 120 const PetscInt *IA,*JA; 121 *ierr = MatGetRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done);if (*ierr) return; 122 *iia = PetscIntAddressToFortran(ia,(PetscInt*)IA); 123 *jja = PetscIntAddressToFortran(ja,(PetscInt*)JA); 124 } 125 126 void PETSC_STDCALL matrestorerowij_(Mat *B,PetscInt *shift,PetscBool *sym,PetscBool *blockcompressed, PetscInt *n,PetscInt *ia,size_t *iia, 127 PetscInt *ja,size_t *jja,PetscBool *done,PetscErrorCode *ierr) 128 { 129 const PetscInt *IA = PetscIntAddressFromFortran(ia,*iia),*JA = PetscIntAddressFromFortran(ja,*jja); 130 *ierr = MatRestoreRowIJ(*B,*shift,*sym,*blockcompressed,n,&IA,&JA,done); 131 } 132 133 /* 134 This is a poor way of storing the column and value pointers 135 generated by MatGetRow() to be returned with MatRestoreRow() 136 but there is not natural,good place else to store them. Hence 137 Fortran programmers can only have one outstanding MatGetRows() 138 at a time. 139 */ 140 static PetscErrorCode matgetrowactive = 0; 141 static const PetscInt *my_ocols = 0; 142 static const PetscScalar *my_ovals = 0; 143 144 void PETSC_STDCALL matgetrow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr) 145 { 146 const PetscInt **oocols = &my_ocols; 147 const PetscScalar **oovals = &my_ovals; 148 149 if (matgetrowactive) { 150 PetscError(PETSC_COMM_SELF,__LINE__,"MatGetRow_Fortran",__FILE__,__SDIR__,PETSC_ERR_ARG_WRONGSTATE,PETSC_ERROR_INITIAL, 151 "Cannot have two MatGetRow() active simultaneously\n\ 152 call MatRestoreRow() before calling MatGetRow() a second time"); 153 *ierr = 1; 154 return; 155 } 156 157 CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = NULL; 158 CHKFORTRANNULLSCALAR(vals); if (!vals) oovals = NULL; 159 160 *ierr = MatGetRow(*mat,*row,ncols,oocols,oovals); 161 if (*ierr) return; 162 163 if (oocols) { *ierr = PetscMemcpy(cols,my_ocols,(*ncols)*sizeof(PetscInt)); if (*ierr) return;} 164 if (oovals) { *ierr = PetscMemcpy(vals,my_ovals,(*ncols)*sizeof(PetscScalar)); if (*ierr) return;} 165 matgetrowactive = 1; 166 } 167 168 void PETSC_STDCALL matrestorerow_(Mat *mat,PetscInt *row,PetscInt *ncols,PetscInt *cols,PetscScalar *vals,PetscErrorCode *ierr) 169 { 170 const PetscInt **oocols = &my_ocols; 171 const PetscScalar **oovals = &my_ovals; 172 if (!matgetrowactive) { 173 PetscError(PETSC_COMM_SELF,__LINE__,"MatRestoreRow_Fortran",__FILE__,__SDIR__,PETSC_ERR_ARG_WRONGSTATE,PETSC_ERROR_INITIAL, 174 "Must call MatGetRow() first"); 175 *ierr = 1; 176 return; 177 } 178 CHKFORTRANNULLINTEGER(cols); if (!cols) oocols = NULL; 179 CHKFORTRANNULLSCALAR(vals); if (!vals) oovals = NULL; 180 181 *ierr = MatRestoreRow(*mat,*row,ncols,oocols,oovals); 182 matgetrowactive = 0; 183 } 184 185 void PETSC_STDCALL matview_(Mat *mat,PetscViewer *vin,PetscErrorCode *ierr) 186 { 187 PetscViewer v; 188 PetscPatchDefaultViewers_Fortran(vin,v); 189 *ierr = MatView(*mat,v); 190 } 191 192 void PETSC_STDCALL matload_(Mat *mat,PetscViewer *vin,PetscErrorCode *ierr) 193 { 194 PetscViewer v; 195 PetscPatchDefaultViewers_Fortran(vin,v); 196 *ierr = MatLoad(*mat,v); 197 } 198 199 void PETSC_STDCALL matseqaijgetarray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 200 { 201 PetscScalar *mm; 202 PetscInt m,n; 203 204 *ierr = MatSeqAIJGetArray(*mat,&mm); if (*ierr) return; 205 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 206 *ierr = PetscScalarAddressToFortran((PetscObject)*mat,1,fa,mm,m*n,ia); if (*ierr) return; 207 } 208 209 void PETSC_STDCALL matseqaijrestorearray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 210 { 211 PetscScalar *lx; 212 PetscInt m,n; 213 214 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 215 *ierr = PetscScalarAddressFromFortran((PetscObject)*mat,fa,*ia,m*n,&lx);if (*ierr) return; 216 *ierr = MatSeqAIJRestoreArray(*mat,&lx);if (*ierr) return; 217 } 218 219 void PETSC_STDCALL matdensegetarray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 220 { 221 PetscScalar *mm; 222 PetscInt m,n; 223 224 *ierr = MatDenseGetArray(*mat,&mm); if (*ierr) return; 225 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 226 *ierr = PetscScalarAddressToFortran((PetscObject)*mat,1,fa,mm,m*n,ia); if (*ierr) return; 227 } 228 229 void PETSC_STDCALL matdenserestorearray_(Mat *mat,PetscScalar *fa,size_t *ia,PetscErrorCode *ierr) 230 { 231 PetscScalar *lx; 232 PetscInt m,n; 233 234 *ierr = MatGetSize(*mat,&m,&n); if (*ierr) return; 235 *ierr = PetscScalarAddressFromFortran((PetscObject)*mat,fa,*ia,m*n,&lx);if (*ierr) return; 236 *ierr = MatDenseRestoreArray(*mat,&lx);if (*ierr) return; 237 } 238 239 void PETSC_STDCALL matfactorgetsolverpackage_(Mat *mat,CHAR name PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 240 { 241 const char *tname; 242 243 *ierr = MatFactorGetSolverPackage(*mat,&tname);if (*ierr) return; 244 if (name != PETSC_NULL_CHARACTER_Fortran) { 245 *ierr = PetscStrncpy(name,tname,len);if (*ierr) return; 246 } 247 FIXRETURNCHAR(PETSC_TRUE,name,len); 248 } 249 250 void PETSC_STDCALL matgetfactor_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),MatFactorType *ftype,Mat *M,PetscErrorCode *ierr PETSC_END_LEN(len)) 251 { 252 char *t; 253 FIXCHAR(outtype,len,t); 254 *ierr = MatGetFactor(*mat,t,*ftype,M); 255 FREECHAR(outtype,t); 256 } 257 258 void PETSC_STDCALL matconvert_(Mat *mat,CHAR outtype PETSC_MIXED_LEN(len),MatReuse *reuse,Mat *M,PetscErrorCode *ierr PETSC_END_LEN(len)) 259 { 260 char *t; 261 FIXCHAR(outtype,len,t); 262 *ierr = MatConvert(*mat,t,*reuse,M); 263 FREECHAR(outtype,t); 264 } 265 266 /* 267 MatGetSubmatrices() is slightly different from C since the 268 Fortran provides the array to hold the submatrix objects,while in C that 269 array is allocated by the MatGetSubmatrices() 270 */ 271 void PETSC_STDCALL matgetsubmatrices_(Mat *mat,PetscInt *n,IS *isrow,IS *iscol,MatReuse *scall,Mat *smat,PetscErrorCode *ierr) 272 { 273 Mat *lsmat; 274 PetscInt i; 275 276 if (*scall == MAT_INITIAL_MATRIX) { 277 *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&lsmat); 278 for (i=0; i<*n; i++) { 279 smat[i] = lsmat[i]; 280 } 281 *ierr = PetscFree(lsmat); 282 } else { 283 *ierr = MatGetSubMatrices(*mat,*n,isrow,iscol,*scall,&smat); 284 } 285 } 286 287 /* 288 MatDestroyMatrices() is slightly different from C since the 289 Fortran provides the array to hold the submatrix objects,while in C that 290 array is allocated by the MatGetSubmatrices() 291 */ 292 void PETSC_STDCALL matdestroymatrices_(Mat *mat,PetscInt *n,Mat *smat,PetscErrorCode *ierr) 293 { 294 PetscInt i; 295 296 for (i=0; i<*n; i++) { 297 *ierr = MatDestroy(&smat[i]);if (*ierr) return; 298 } 299 } 300 301 void PETSC_STDCALL matzerorowscolumns_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 302 { 303 CHKFORTRANNULLOBJECTDEREFERENCE(x); 304 CHKFORTRANNULLOBJECTDEREFERENCE(b); 305 *ierr = MatZeroRowsColumns(*mat,*numRows,rows,*diag,*x,*b); 306 } 307 308 void PETSC_STDCALL matzerorowscolumnsis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 309 { 310 CHKFORTRANNULLOBJECTDEREFERENCE(x); 311 CHKFORTRANNULLOBJECTDEREFERENCE(b); 312 *ierr = MatZeroRowsColumnsIS(*mat,*is,*diag,*x,*b); 313 } 314 315 void PETSC_STDCALL matzerorowsstencil_(Mat *mat,PetscInt *numRows,MatStencil *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 316 { 317 CHKFORTRANNULLOBJECTDEREFERENCE(x); 318 CHKFORTRANNULLOBJECTDEREFERENCE(b); 319 *ierr = MatZeroRowsStencil(*mat,*numRows,rows,*diag,*x,*b); 320 } 321 322 void PETSC_STDCALL matzerorowscolumnsstencil_(Mat *mat,PetscInt *numRows,MatStencil *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 323 { 324 CHKFORTRANNULLOBJECTDEREFERENCE(x); 325 CHKFORTRANNULLOBJECTDEREFERENCE(b); 326 *ierr = MatZeroRowsColumnsStencil(*mat,*numRows,rows,*diag,*x,*b); 327 } 328 329 void PETSC_STDCALL matzerorows_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 330 { 331 CHKFORTRANNULLOBJECTDEREFERENCE(x); 332 CHKFORTRANNULLOBJECTDEREFERENCE(b); 333 *ierr = MatZeroRows(*mat,*numRows,rows,*diag,*x,*b); 334 } 335 336 void PETSC_STDCALL matzerorowsis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 337 { 338 CHKFORTRANNULLOBJECTDEREFERENCE(x); 339 CHKFORTRANNULLOBJECTDEREFERENCE(b); 340 *ierr = MatZeroRowsIS(*mat,*is,*diag,*x,*b); 341 } 342 343 void PETSC_STDCALL matzerorowslocal_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 344 { 345 CHKFORTRANNULLOBJECTDEREFERENCE(x); 346 CHKFORTRANNULLOBJECTDEREFERENCE(b); 347 *ierr = MatZeroRowsLocal(*mat,*numRows,rows,*diag,*x,*b); 348 } 349 350 void PETSC_STDCALL matzerorowslocalis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 351 { 352 CHKFORTRANNULLOBJECTDEREFERENCE(x); 353 CHKFORTRANNULLOBJECTDEREFERENCE(b); 354 *ierr = MatZeroRowsLocalIS(*mat,*is,*diag,*x,*b); 355 } 356 357 void PETSC_STDCALL matzerorowscolumnslocal_(Mat *mat,PetscInt *numRows,PetscInt *rows,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 358 { 359 CHKFORTRANNULLOBJECTDEREFERENCE(x); 360 CHKFORTRANNULLOBJECTDEREFERENCE(b); 361 *ierr = MatZeroRowsColumnsLocal(*mat,*numRows,rows,*diag,*x,*b); 362 } 363 364 void PETSC_STDCALL matzerorowscolumnslocalis_(Mat *mat,IS *is,PetscScalar *diag,Vec *x,Vec *b,PetscErrorCode *ierr) 365 { 366 CHKFORTRANNULLOBJECTDEREFERENCE(x); 367 CHKFORTRANNULLOBJECTDEREFERENCE(b); 368 *ierr = MatZeroRowsColumnsLocalIS(*mat,*is,*diag,*x,*b); 369 } 370 371 void PETSC_STDCALL matsetoptionsprefix_(Mat *mat,CHAR prefix PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 372 { 373 char *t; 374 375 FIXCHAR(prefix,len,t); 376 *ierr = MatSetOptionsPrefix(*mat,t); 377 FREECHAR(prefix,t); 378 } 379 380 void PETSC_STDCALL matnullspaceremove_(MatNullSpace *sp,Vec *vec,Vec *out,PetscErrorCode *ierr) 381 { 382 CHKFORTRANNULLOBJECT(out); 383 *ierr = MatNullSpaceRemove(*sp,*vec,out); 384 } 385 386 void PETSC_STDCALL matgetinfo_(Mat *mat,MatInfoType *flag,MatInfo *info, int *__ierr) 387 { 388 *__ierr = MatGetInfo(*mat,*flag,info); 389 } 390 391 void PETSC_STDCALL matlufactor_(Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr) 392 { 393 *__ierr = MatLUFactor(*mat,*row,*col,info); 394 } 395 396 void PETSC_STDCALL matilufactor_(Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr) 397 { 398 *__ierr = MatILUFactor(*mat,*row,*col,info); 399 } 400 401 void PETSC_STDCALL matlufactorsymbolic_(Mat *fact,Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr) 402 { 403 *__ierr = MatLUFactorSymbolic(*fact,*mat,*row,*col,info); 404 } 405 406 void PETSC_STDCALL matlufactornumeric_(Mat *fact,Mat *mat, MatFactorInfo *info, int *__ierr) 407 { 408 *__ierr = MatLUFactorNumeric(*fact,*mat,info); 409 } 410 411 void PETSC_STDCALL matcholeskyfactor_(Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr) 412 { 413 *__ierr = MatCholeskyFactor(*mat,*perm,info); 414 } 415 416 void PETSC_STDCALL matcholeskyfactorsymbolic_(Mat *fact,Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr) 417 { 418 *__ierr = MatCholeskyFactorSymbolic(*fact,*mat,*perm,info); 419 } 420 421 void PETSC_STDCALL matcholeskyfactornumeric_(Mat *fact,Mat *mat, MatFactorInfo *info, int *__ierr) 422 { 423 *__ierr = MatCholeskyFactorNumeric(*fact,*mat,info); 424 } 425 426 void PETSC_STDCALL matilufactorsymbolic_(Mat *fact,Mat *mat,IS *row,IS *col, MatFactorInfo *info, int *__ierr) 427 { 428 *__ierr = MatILUFactorSymbolic(*fact,*mat,*row,*col,info); 429 } 430 431 void PETSC_STDCALL maticcfactorsymbolic_(Mat *fact,Mat *mat,IS *perm, MatFactorInfo *info, int *__ierr) 432 { 433 *__ierr = MatICCFactorSymbolic(*fact,*mat,*perm,info); 434 } 435 436 void PETSC_STDCALL maticcfactor_(Mat *mat,IS *row, MatFactorInfo *info, int *__ierr) 437 { 438 *__ierr = MatICCFactor(*mat,*row,info); 439 } 440 441 void PETSC_STDCALL matfactorinfoinitialize_(MatFactorInfo *info, int *__ierr) 442 { 443 *__ierr = MatFactorInfoInitialize(info); 444 } 445 446 EXTERN_C_END 447