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 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 static PetscErrorCode ourgetdiagonal(Mat mat,Vec x) 55 { 56 PetscErrorCode ierr = 0; 57 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[4]))(&mat,&x,&ierr); 58 return ierr; 59 } 60 61 static PetscErrorCode ourdiagonalscale(Mat mat,Vec l,Vec r) 62 { 63 PetscErrorCode ierr = 0; 64 if (!l) { 65 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[5]))(&mat,(Vec*)PETSC_NULL_OBJECT_Fortran,&r,&ierr); 66 } else if (!r) { 67 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[5]))(&mat,&l,(Vec*)PETSC_NULL_OBJECT_Fortran,&ierr); 68 } else { 69 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[5]))(&mat,&l,&r,&ierr); 70 } 71 return ierr; 72 } 73 74 static PetscErrorCode ourgetvecs(Mat mat,Vec *l,Vec *r) 75 { 76 PetscErrorCode ierr = 0; 77 PetscInt none = -1; 78 if (!l) { 79 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[7]))(&mat,(Vec*)&none,r,&ierr); 80 } else if (!r) { 81 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[7]))(&mat,l,(Vec*)&none,&ierr); 82 } else { 83 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[7]))(&mat,l,r,&ierr); 84 } 85 return ierr; 86 } 87 88 static PetscErrorCode ourdiagonalset(Mat mat,Vec x,InsertMode ins) 89 { 90 PetscErrorCode ierr = 0; 91 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,InsertMode*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[6]))(&mat,&x,&ins,&ierr); 92 return ierr; 93 } 94 95 static PetscErrorCode ourview(Mat mat,PetscViewer v) 96 { 97 PetscErrorCode ierr = 0; 98 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,PetscViewer*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[8]))(&mat,&v,&ierr); 99 return ierr; 100 } 101 102 static PetscErrorCode oursor(Mat mat,Vec b,PetscReal omega,MatSORType flg,PetscReal shift,PetscInt its,PetscInt lits,Vec x) 103 { 104 PetscErrorCode ierr = 0; 105 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,Vec*,PetscReal*,MatSORType*,PetscReal*,PetscInt*,PetscInt*,Vec*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[9]))(&mat,&b,&omega,&flg,&shift,&its,&lits,&x,&ierr); 106 return ierr; 107 } 108 109 static PetscErrorCode ourshift(Mat mat, PetscScalar a) 110 { 111 PetscErrorCode ierr = 0; 112 (*(PetscErrorCode (PETSC_STDCALL *)(Mat*,PetscScalar*,PetscErrorCode*))(((PetscObject)mat)->fortran_func_pointers[10]))(&mat,&a,&ierr); 113 return ierr; 114 } 115 116 void PETSC_STDCALL matshellsetoperation_(Mat *mat,MatOperation *op,PetscErrorCode (PETSC_STDCALL *f)(Mat*,Vec*,Vec*,PetscErrorCode*),PetscErrorCode *ierr) 117 { 118 MPI_Comm comm; 119 120 *ierr = PetscObjectGetComm((PetscObject)*mat,&comm);if (*ierr) return; 121 PetscObjectAllocateFortranPointers(*mat,11); 122 if (*op == MATOP_MULT) { 123 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmult); 124 ((PetscObject)*mat)->fortran_func_pointers[0] = (PetscVoidFunction)f; 125 } else if (*op == MATOP_MULT_TRANSPOSE) { 126 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttranspose); 127 ((PetscObject)*mat)->fortran_func_pointers[2] = (PetscVoidFunction)f; 128 } else if (*op == MATOP_MULT_ADD) { 129 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmultadd); 130 ((PetscObject)*mat)->fortran_func_pointers[1] = (PetscVoidFunction)f; 131 } else if (*op == MATOP_MULT_TRANSPOSE_ADD) { 132 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourmulttransposeadd); 133 ((PetscObject)*mat)->fortran_func_pointers[3] = (PetscVoidFunction)f; 134 } else if (*op == MATOP_GET_DIAGONAL) { 135 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourgetdiagonal); 136 ((PetscObject)*mat)->fortran_func_pointers[4] = (PetscVoidFunction)f; 137 } else if (*op == MATOP_DIAGONAL_SCALE) { 138 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourdiagonalscale); 139 ((PetscObject)*mat)->fortran_func_pointers[5] = (PetscVoidFunction)f; 140 } else if (*op == MATOP_DIAGONAL_SET) { 141 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourdiagonalset); 142 ((PetscObject)*mat)->fortran_func_pointers[6] = (PetscVoidFunction)f; 143 } else if (*op == MATOP_GET_VECS) { 144 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourgetvecs); 145 ((PetscObject)*mat)->fortran_func_pointers[7] = (PetscVoidFunction)f; 146 } else if (*op == MATOP_VIEW) { 147 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourview); 148 ((PetscObject)*mat)->fortran_func_pointers[8] = (PetscVoidFunction)f; 149 } else if (*op == MATOP_SOR) { 150 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)oursor); 151 ((PetscObject)*mat)->fortran_func_pointers[9] = (PetscVoidFunction)f; 152 } else if (*op == MATOP_SHIFT) { 153 *ierr = MatShellSetOperation(*mat,*op,(PetscVoidFunction)ourshift); 154 ((PetscObject)*mat)->fortran_func_pointers[10] = (PetscVoidFunction)f; 155 } else { 156 PetscError(comm,__LINE__,"MatShellSetOperation_Fortran",__FILE__,__SDIR__,PETSC_ERR_ARG_WRONG,PETSC_ERROR_INITIAL, 157 "Cannot set that matrix operation"); 158 *ierr = 1; 159 } 160 } 161 162 void PETSC_STDCALL matshellgetcontext_(Mat *mat,void **ctx,PetscErrorCode *ierr) 163 { 164 *ierr = MatShellGetContext(*mat,ctx); 165 } 166 167 168 EXTERN_C_END 169