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