1 #include "private/fortranimpl.h" 2 #include "petscsys.h" 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define petscpusherrorhandler_ PETSCPUSHERRORHANDLER 6 #define petsctracebackerrorhandler_ PETSCTRACEBACKERRORHANDLER 7 #define petscaborterrorhandler_ PETSCABORTERRORHANDLER 8 #define petscignoreerrorhandler_ PETSCIGNOREERRORHANDLER 9 #define petscemacsclienterrorhandler_ PETSCEMACSCLIENTERRORHANDLER 10 #define petscattachdebuggererrorhandler_ PETSCATTACHDEBUGGERERRORHANDLER 11 #define petscerror_ PETSCERROR 12 #define petscrealview_ PETSCREALVIEW 13 #define petscintview_ PETSCINTVIEW 14 #define petscerroriscatchable_ PETSCERRORISCATCHABLE 15 #define petscexceptionvalue_ PETSCEXCEPTIONVALUE 16 #define petscexceptioncaught PETSCEXCEPTIONCAUGHT 17 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 18 #define petscpusherrorhandler_ petscpusherrorhandler 19 #define petsctracebackerrorhandler_ petsctracebackerrorhandler 20 #define petscaborterrorhandler_ petscaborterrorhandler 21 #define petscignoreerrorhandler_ petscignoreerrorhandler 22 #define petscemacsclienterrorhandler_ petscemacsclienterrorhandler 23 #define petscattachdebuggererrorhandler_ petscattachdebuggererrorhandler 24 #define petscerror_ petscerror 25 #define petscrealview_ petscrealview 26 #define petscintview_ petscintview 27 #define petscerroriscatchable_ petscerroriscatchable 28 #define petscexceptionvalue_ petscexceptionvalue 29 #define petscexceptioncaught_ petscexceptioncaught 30 #endif 31 32 EXTERN_C_BEGIN 33 static void (PETSC_STDCALL *f2)(MPI_Comm *comm,int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),PetscErrorCode*,PetscErrorType*,const CHAR PETSC_MIXED_LEN(len4),void*,PetscErrorCode* PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len3) PETSC_END_LEN(len4)); 34 EXTERN_C_END 35 36 /* These are not extern C because they are passed into non-extern C user level functions */ 37 static PetscErrorCode ourerrorhandler(MPI_Comm comm,int line,const char *fun,const char *file,const char *dir,PetscErrorCode n,PetscErrorType p,const char *mess,void *ctx) 38 { 39 PetscErrorCode ierr = 0; 40 size_t len1,len2,len3,len4; 41 int l1,l2,l3,l4; 42 43 PetscStrlen(fun,&len1); l1 = (int)len1; 44 PetscStrlen(file,&len2);l2 = (int)len2; 45 PetscStrlen(dir,&len3);l3 = (int)len3; 46 PetscStrlen(mess,&len4);l4 = (int)len4; 47 48 #if defined(PETSC_HAVE_FORTRAN_MIXED_STR_ARG) 49 (*f2)(&comm,&line,fun,l1,file,l2,dir,l3,&n,&p,mess,l4,ctx,&ierr); 50 #else 51 (*f2)(&comm,&line,fun,file,dir,&n,&p,mess,ctx,&ierr,l1,l2,l3,l4); 52 #endif 53 return ierr; 54 } 55 56 EXTERN_C_BEGIN 57 58 /* 59 These are not usually called from Fortran but allow Fortran users 60 to transparently set these monitors from .F code 61 62 functions, hence no STDCALL 63 */ 64 void petsctracebackerrorhandler_(MPI_Comm *comm,int *line,const char *fun,const char *file,const char *dir,PetscErrorCode *n,PetscErrorType *p,const char *mess,void *ctx,PetscErrorCode *ierr) 65 { 66 *ierr = PetscTraceBackErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 67 } 68 69 void petscaborterrorhandler_(MPI_Comm *comm,int *line,const char *fun,const char *file,const char *dir,PetscErrorCode *n,PetscErrorType *p,const char *mess,void *ctx,PetscErrorCode *ierr) 70 { 71 *ierr = PetscAbortErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 72 } 73 74 void petscattachdebuggererrorhandler_(MPI_Comm *comm,int *line,const char *fun,const char *file,const char *dir,PetscErrorCode *n,PetscErrorType *p,const char *mess,void *ctx,PetscErrorCode *ierr) 75 { 76 *ierr = PetscAttachDebuggerErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 77 } 78 79 void petscemacsclienterrorhandler_(MPI_Comm *comm,int *line,const char *fun,const char *file,const char *dir,PetscErrorCode *n,PetscErrorType *p,const char *mess,void *ctx,PetscErrorCode *ierr) 80 { 81 *ierr = PetscEmacsClientErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 82 } 83 84 void petscignoreerrorhandler_(MPI_Comm *comm,int *line,const char *fun,const char *file,const char *dir,PetscErrorCode *n,PetscErrorType *p,const char *mess,void *ctx,PetscErrorCode *ierr) 85 { 86 *ierr = PetscIgnoreErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 87 } 88 89 void PETSC_STDCALL petscpusherrorhandler_(void (PETSC_STDCALL *handler)(MPI_Comm *comm,int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),PetscErrorCode*,PetscErrorType*,const CHAR PETSC_MIXED_LEN(len4),void*,PetscErrorCode* PETSC_END_LEN(len1) PETSC_END_LEN(len2) PETSC_END_LEN(len3) PETSC_END_LEN(len4)),void *ctx,PetscErrorCode *ierr) 90 { 91 if ((void(*)(void))handler == (void(*)(void))petsctracebackerrorhandler_) { 92 *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler,0); 93 } else { 94 f2 = handler; 95 *ierr = PetscPushErrorHandler(ourerrorhandler,ctx); 96 } 97 } 98 99 void PETSC_STDCALL petscerror_(MPI_Comm *comm,PetscErrorCode *number,int *line,PetscErrorType *p,CHAR message PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 100 { 101 char *t1; 102 FIXCHAR(message,len,t1); 103 *ierr = PetscError(*comm,*line,0,0,0,*number,*p,t1); 104 FREECHAR(message,t1); 105 } 106 107 void PETSC_STDCALL petscrealview_(PetscInt *n,PetscReal *d,PetscViewer *viwer,PetscErrorCode *ierr) 108 { 109 PetscViewer v; 110 PetscPatchDefaultViewers_Fortran(viwer,v); 111 *ierr = PetscRealView(*n,d,v); 112 } 113 114 void PETSC_STDCALL petscintview_(PetscInt *n,PetscInt *d,PetscViewer *viwer,PetscErrorCode *ierr) 115 { 116 PetscViewer v; 117 PetscPatchDefaultViewers_Fortran(viwer,v); 118 *ierr = PetscIntView(*n,d,v); 119 } 120 121 void PETSC_STDCALL petscerroriscatchable_(PetscErrorCode *ierr,PetscTruth *is) 122 { 123 *is = PetscErrorIsCatchable(*ierr); 124 } 125 126 void PETSC_STDCALL petscexceptionvalue_(PetscErrorCode *ierr,PetscTruth *is) 127 { 128 *is = PetscExceptionValue(*ierr); 129 } 130 131 void PETSC_STDCALL petscexceptioncaught_(PetscErrorCode *ierr,PetscErrorCode *zierr,PetscTruth *is) 132 { 133 *is = PetscExceptionCaught(*ierr,*zierr); 134 } 135 136 #if defined(PETSC_HAVE_FORTRAN_CAPS) 137 #define petscscalarview_ PETSCSCALARVIEW 138 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 139 #define petscscalarview_ petscscalarview 140 #endif 141 142 void PETSC_STDCALL petscscalarview_(PetscInt *n,PetscScalar *d,PetscViewer *viwer,PetscErrorCode *ierr) 143 { 144 PetscViewer v; 145 PetscPatchDefaultViewers_Fortran(viwer,v); 146 *ierr = PetscScalarView(*n,d,v); 147 } 148 149 EXTERN_C_END 150