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 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 15 #define petscpusherrorhandler_ petscpusherrorhandler 16 #define petsctracebackerrorhandler_ petsctracebackerrorhandler 17 #define petscaborterrorhandler_ petscaborterrorhandler 18 #define petscignoreerrorhandler_ petscignoreerrorhandler 19 #define petscemacsclienterrorhandler_ petscemacsclienterrorhandler 20 #define petscattachdebuggererrorhandler_ petscattachdebuggererrorhandler 21 #define petscerror_ petscerror 22 #define petscrealview_ petscrealview 23 #define petscintview_ petscintview 24 #endif 25 26 EXTERN_C_BEGIN 27 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)); 28 EXTERN_C_END 29 30 /* These are not extern C because they are passed into non-extern C user level functions */ 31 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) 32 { 33 PetscErrorCode ierr = 0; 34 size_t len1,len2,len3,len4; 35 int l1,l2,l3,l4; 36 37 PetscStrlen(fun,&len1); l1 = (int)len1; 38 PetscStrlen(file,&len2);l2 = (int)len2; 39 PetscStrlen(dir,&len3);l3 = (int)len3; 40 PetscStrlen(mess,&len4);l4 = (int)len4; 41 42 #if defined(PETSC_HAVE_FORTRAN_MIXED_STR_ARG) 43 (*f2)(&comm,&line,fun,l1,file,l2,dir,l3,&n,&p,mess,l4,ctx,&ierr); 44 #else 45 (*f2)(&comm,&line,fun,file,dir,&n,&p,mess,ctx,&ierr,l1,l2,l3,l4); 46 #endif 47 return ierr; 48 } 49 50 EXTERN_C_BEGIN 51 52 /* 53 These are not usually called from Fortran but allow Fortran users 54 to transparently set these monitors from .F code 55 56 functions, hence no STDCALL 57 */ 58 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) 59 { 60 *ierr = PetscTraceBackErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 61 } 62 63 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) 64 { 65 *ierr = PetscAbortErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 66 } 67 68 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) 69 { 70 *ierr = PetscAttachDebuggerErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 71 } 72 73 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) 74 { 75 *ierr = PetscEmacsClientErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 76 } 77 78 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) 79 { 80 *ierr = PetscIgnoreErrorHandler(*comm,*line,fun,file,dir,*n,*p,mess,ctx); 81 } 82 83 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) 84 { 85 if ((void(*)(void))handler == (void(*)(void))petsctracebackerrorhandler_) { 86 *ierr = PetscPushErrorHandler(PetscTraceBackErrorHandler,0); 87 } else { 88 f2 = handler; 89 *ierr = PetscPushErrorHandler(ourerrorhandler,ctx); 90 } 91 } 92 93 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)) 94 { 95 char *t1; 96 FIXCHAR(message,len,t1); 97 *ierr = PetscError(*comm,*line,0,0,0,*number,*p,t1); 98 FREECHAR(message,t1); 99 } 100 101 void PETSC_STDCALL petscrealview_(PetscInt *n,PetscReal *d,PetscViewer *viwer,PetscErrorCode *ierr) 102 { 103 PetscViewer v; 104 PetscPatchDefaultViewers_Fortran(viwer,v); 105 *ierr = PetscRealView(*n,d,v); 106 } 107 108 void PETSC_STDCALL petscintview_(PetscInt *n,PetscInt *d,PetscViewer *viwer,PetscErrorCode *ierr) 109 { 110 PetscViewer v; 111 PetscPatchDefaultViewers_Fortran(viwer,v); 112 *ierr = PetscIntView(*n,d,v); 113 } 114 115 #if defined(PETSC_HAVE_FORTRAN_CAPS) 116 #define petscscalarview_ PETSCSCALARVIEW 117 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 118 #define petscscalarview_ petscscalarview 119 #endif 120 121 void PETSC_STDCALL petscscalarview_(PetscInt *n,PetscScalar *d,PetscViewer *viwer,PetscErrorCode *ierr) 122 { 123 PetscViewer v; 124 PetscPatchDefaultViewers_Fortran(viwer,v); 125 *ierr = PetscScalarView(*n,d,v); 126 } 127 128 EXTERN_C_END 129