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