1 #include "private/fortranimpl.h" 2 #include "petsc.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)(int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),int*,int*,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(int line,const char *fun,const char *file,const char *dir,int n,int 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)(&line,fun,l1,file,l2,dir,l3,&n,&p,mess,l4,ctx,&ierr); 50 #else 51 (*f2)(&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_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr) 65 { 66 *ierr = PetscTraceBackErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx); 67 } 68 69 void petscaborterrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr) 70 { 71 *ierr = PetscAbortErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx); 72 } 73 74 void petscattachdebuggererrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr) 75 { 76 *ierr = PetscAttachDebuggerErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx); 77 } 78 79 void petscemacsclienterrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr) 80 { 81 *ierr = PetscEmacsClientErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx); 82 } 83 84 void petscignoreerrorhandler_(int *line,const char *fun,const char *file,const char *dir,int *n,int *p,const char *mess,void *ctx,PetscErrorCode *ierr) 85 { 86 *ierr = PetscIgnoreErrorHandler(*line,fun,file,dir,*n,*p,mess,ctx); 87 } 88 89 void PETSC_STDCALL petscpusherrorhandler_(void (PETSC_STDCALL *handler)(int*,const CHAR PETSC_MIXED_LEN(len1),const CHAR PETSC_MIXED_LEN(len2),const CHAR PETSC_MIXED_LEN(len3),int*,int*,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_(int *number,int *line,int *p,CHAR message PETSC_MIXED_LEN(len), 100 PetscErrorCode *ierr PETSC_END_LEN(len)) 101 { 102 char *t1; 103 FIXCHAR(message,len,t1); 104 *ierr = PetscError(*line,0,0,0,*number,*p,t1); 105 FREECHAR(message,t1); 106 } 107 108 void PETSC_STDCALL petscrealview_(PetscInt *n,PetscReal *d,PetscViewer *viwer,PetscErrorCode *ierr) 109 { 110 PetscViewer v; 111 PetscPatchDefaultViewers_Fortran(viwer,v); 112 *ierr = PetscRealView(*n,d,v); 113 } 114 115 void PETSC_STDCALL petscintview_(PetscInt *n,PetscInt *d,PetscViewer *viwer,PetscErrorCode *ierr) 116 { 117 PetscViewer v; 118 PetscPatchDefaultViewers_Fortran(viwer,v); 119 *ierr = PetscIntView(*n,d,v); 120 } 121 122 void PETSC_STDCALL petscerroriscatchable_(PetscErrorCode *ierr,PetscTruth *is) 123 { 124 *is = PetscErrorIsCatchable(*ierr); 125 } 126 127 void PETSC_STDCALL petscexceptionvalue_(PetscErrorCode *ierr,PetscTruth *is) 128 { 129 *is = PetscExceptionValue(*ierr); 130 } 131 132 void PETSC_STDCALL petscexceptioncaught_(PetscErrorCode *ierr,PetscErrorCode *zierr,PetscTruth *is) 133 { 134 *is = PetscExceptionCaught(*ierr,*zierr); 135 } 136 137 #if defined(PETSC_HAVE_FORTRAN_CAPS) 138 #define petscscalarview_ PETSCSCALARVIEW 139 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 140 #define petscscalarview_ petscscalarview 141 #endif 142 143 void PETSC_STDCALL petscscalarview_(PetscInt *n,PetscScalar *d,PetscViewer *viwer,PetscErrorCode *ierr) 144 { 145 PetscViewer v; 146 PetscPatchDefaultViewers_Fortran(viwer,v); 147 *ierr = PetscScalarView(*n,d,v); 148 } 149 150 EXTERN_C_END 151