1 #include "private/fortranimpl.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 23 } 24 25 static PetscErrorCode ourmult(Mat mat,Vec x,Vec y) 26 { 27 PetscErrorCode ierr = 0; 28 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&x,&y,&ierr); 29 return ierr; 30 } 31 32 static PetscErrorCode ourmulttranspose(Mat mat,Vec x,Vec y) 33 { 34 PetscErrorCode ierr = 0; 35 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[2]))(&mat,&x,&y,&ierr); 36 return ierr; 37 } 38 39 static PetscErrorCode ourmultadd(Mat mat,Vec x,Vec y,Vec z) 40 { 41 PetscErrorCode ierr = 0; 42 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[1]))(&mat,&x,&y,&z,&ierr); 43 return ierr; 44 } 45 46 static PetscErrorCode ourmulttransposeadd(Mat mat,Vec x,Vec y,Vec z) 47 { 48 PetscErrorCode ierr = 0; 49 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[3]))(&mat,&x,&y,&z,&ierr); 50 return ierr; 51 } 52 53 static PetscErrorCode ourgetdiagonal(Mat mat,Vec x) 54 { 55 PetscErrorCode ierr = 0; 56 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[4]))(&mat,&x,&ierr); 57 return ierr; 58 } 59 60 void PETSC_STDCALL matshellsetoperation_(Mat *mat,MatOperation *op,PetscErrorCode (PETSC_STDCALL *f)(Mat*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 61 { 62 PetscObjectAllocateFortranPointers(*mat,5); 63 if (*op == MATOP_MULT) { 64 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmult); 65 ((PetscObject)*mat)->fortran_func_pointers[0] = (PetscVoidFunction)f; 66 } else if (*op == MATOP_MULT_TRANSPOSE) { 67 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttranspose); 68 ((PetscObject)*mat)->fortran_func_pointers[2] = (PetscVoidFunction)f; 69 } else if (*op == MATOP_MULT_ADD) { 70 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmultadd); 71 ((PetscObject)*mat)->fortran_func_pointers[1] = (PetscVoidFunction)f; 72 } else if (*op == MATOP_MULT_TRANSPOSE_ADD) { 73 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttransposeadd); 74 ((PetscObject)*mat)->fortran_func_pointers[3] = (PetscVoidFunction)f; 75 } else if (*op == MATOP_GET_DIAGONAL) { 76 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourgetdiagonal); 77 ((PetscObject)*mat)->fortran_func_pointers[4] = (PetscVoidFunction)f; 78 } else { 79 PetscError(__LINE__,"MatShellSetOperation_Fortran",__FILE__,__SDIR__,1,0, 80 "Cannot set that matrix operation"); 81 *ierr = 1; 82 } 83 } 84 85 EXTERN_C_END 86