1 #include "zpetsc.h" 2 #include "petscmat.h" 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define matshellsetoperation_ MATSHELLSETOPERATION 6 #define matcreateshell_ MATCREATESHELL 7 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 8 #define matcreateshell_ matcreateshell 9 #define matshellsetoperation_ matshellsetoperation 10 #endif 11 12 EXTERN_C_BEGIN 13 14 /* 15 The MatShell Matrix Vector product requires a C routine. 16 This C routine then calls the corresponding Fortran routine that was 17 set by the user. 18 */ 19 void PETSC_STDCALL matcreateshell_(MPI_Comm *comm,PetscInt *m,PetscInt *n,PetscInt *M,PetscInt *N,void **ctx,Mat *mat,PetscErrorCode *ierr) 20 { 21 *ierr = MatCreateShell((MPI_Comm)PetscToPointerComm(*comm),*m,*n,*M,*N,*ctx,mat); 22 if (*ierr) return; 23 *ierr = PetscMalloc(4*sizeof(void*),&((PetscObject)*mat)->fortran_func_pointers); 24 } 25 26 static PetscErrorCode ourmult(Mat mat,Vec x,Vec y) 27 { 28 PetscErrorCode ierr = 0; 29 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&x,&y,&ierr); 30 return ierr; 31 } 32 33 static PetscErrorCode ourmulttranspose(Mat mat,Vec x,Vec y) 34 { 35 PetscErrorCode ierr = 0; 36 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[2]))(&mat,&x,&y,&ierr); 37 return ierr; 38 } 39 40 static PetscErrorCode ourmultadd(Mat mat,Vec x,Vec y,Vec z) 41 { 42 PetscErrorCode ierr = 0; 43 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[1]))(&mat,&x,&y,&z,&ierr); 44 return ierr; 45 } 46 47 static PetscErrorCode ourmulttransposeadd(Mat mat,Vec x,Vec y,Vec z) 48 { 49 PetscErrorCode ierr = 0; 50 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[3]))(&mat,&x,&y,&z,&ierr); 51 return ierr; 52 } 53 54 void PETSC_STDCALL matshellsetoperation_(Mat *mat,MatOperation *op,PetscErrorCode (PETSC_STDCALL *f)(Mat*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 55 { 56 if (*op == MATOP_MULT) { 57 *ierr = MatShellSetOperation(*mat,*op,(FCNVOID)ourmult); 58 ((PetscObject)*mat)->fortran_func_pointers[0] = (FCNVOID)f; 59 } else if (*op == MATOP_MULT_TRANSPOSE) { 60 *ierr = MatShellSetOperation(*mat,*op,(FCNVOID)ourmulttranspose); 61 ((PetscObject)*mat)->fortran_func_pointers[2] = (FCNVOID)f; 62 } else if (*op == MATOP_MULT_ADD) { 63 *ierr = MatShellSetOperation(*mat,*op,(FCNVOID)ourmultadd); 64 ((PetscObject)*mat)->fortran_func_pointers[1] = (FCNVOID)f; 65 } else if (*op == MATOP_MULT_TRANSPOSE_ADD) { 66 *ierr = MatShellSetOperation(*mat,*op,(FCNVOID)ourmulttransposeadd); 67 ((PetscObject)*mat)->fortran_func_pointers[3] = (FCNVOID)f; 68 } else { 69 PetscError(__LINE__,"MatShellSetOperation_Fortran",__FILE__,__SDIR__,1,0, 70 "Cannot set that matrix operation"); 71 *ierr = 1; 72 } 73 } 74 75 EXTERN_C_END 76