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 #define matshellgetcontext_ MATSHELLGETCONTEXT 8 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 9 #define matcreateshell_ matcreateshell 10 #define matshellsetoperation_ matshellsetoperation 11 #define matshellgetcontext_ matshellgetcontext 12 #endif 13 14 EXTERN_C_BEGIN 15 16 /* 17 The MatShell Matrix Vector product requires a C routine. 18 This C routine then calls the corresponding Fortran routine that was 19 set by the user. 20 */ 21 void PETSC_STDCALL matcreateshell_(MPI_Comm *comm,PetscInt *m,PetscInt *n,PetscInt *M,PetscInt *N,void **ctx,Mat *mat,PetscErrorCode *ierr) 22 { 23 *ierr = MatCreateShell(MPI_Comm_f2c(*(MPI_Fint *)&*comm),*m,*n,*M,*N,*ctx,mat); 24 25 } 26 27 static PetscErrorCode ourmult(Mat mat,Vec x,Vec y) 28 { 29 PetscErrorCode ierr = 0; 30 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[0]))(&mat,&x,&y,&ierr); 31 return ierr; 32 } 33 34 static PetscErrorCode ourmulttranspose(Mat mat,Vec x,Vec y) 35 { 36 PetscErrorCode ierr = 0; 37 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[2]))(&mat,&x,&y,&ierr); 38 return ierr; 39 } 40 41 static PetscErrorCode ourmultadd(Mat mat,Vec x,Vec y,Vec z) 42 { 43 PetscErrorCode ierr = 0; 44 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[1]))(&mat,&x,&y,&z,&ierr); 45 return ierr; 46 } 47 48 static PetscErrorCode ourmulttransposeadd(Mat mat,Vec x,Vec y,Vec z) 49 { 50 PetscErrorCode ierr = 0; 51 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[3]))(&mat,&x,&y,&z,&ierr); 52 return ierr; 53 } 54 55 static PetscErrorCode ourgetdiagonal(Mat mat,Vec x) 56 { 57 PetscErrorCode ierr = 0; 58 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[4]))(&mat,&x,&ierr); 59 return ierr; 60 } 61 62 void PETSC_STDCALL matshellsetoperation_(Mat *mat,MatOperation *op,PetscErrorCode (PETSC_STDCALL *f)(Mat*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 63 { 64 PetscObjectAllocateFortranPointers(*mat,5); 65 if (*op == MATOP_MULT) { 66 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmult); 67 ((PetscObject)*mat)->fortran_func_pointers[0] = (PetscVoidFunction)f; 68 } else if (*op == MATOP_MULT_TRANSPOSE) { 69 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttranspose); 70 ((PetscObject)*mat)->fortran_func_pointers[2] = (PetscVoidFunction)f; 71 } else if (*op == MATOP_MULT_ADD) { 72 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmultadd); 73 ((PetscObject)*mat)->fortran_func_pointers[1] = (PetscVoidFunction)f; 74 } else if (*op == MATOP_MULT_TRANSPOSE_ADD) { 75 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttransposeadd); 76 ((PetscObject)*mat)->fortran_func_pointers[3] = (PetscVoidFunction)f; 77 } else if (*op == MATOP_GET_DIAGONAL) { 78 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourgetdiagonal); 79 ((PetscObject)*mat)->fortran_func_pointers[4] = (PetscVoidFunction)f; 80 } else { 81 PetscError(__LINE__,"MatShellSetOperation_Fortran",__FILE__,__SDIR__,1,0, 82 "Cannot set that matrix operation"); 83 *ierr = 1; 84 } 85 } 86 87 void PETSC_STDCALL matshellgetcontext_(Mat *mat,void **ctx,PetscErrorCode *ierr) 88 { 89 *ierr = MatShellGetContext(*mat,ctx); 90 } 91 92 93 EXTERN_C_END 94