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