1 2 #include <petsc/private/fortranimpl.h> 3 4 #if defined(PETSC_HAVE_FORTRAN_CAPS) 5 #define chkmemfortran_ CHKMEMFORTRAN 6 #define petscoffsetfortran_ PETSCOFFSETFORTRAN 7 #define petscobjectstateincrease_ PETSCOBJECTSTATEINCREASE 8 #define petscobjectcomposefunction_ PETSCOBJECTCOMPOSEFUNCTION 9 #define petscobjectqueryfunction_ PETSCOBJECTQUERYFUNCTION 10 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 11 #define petscoffsetfortran_ petscoffsetfortran 12 #define chkmemfortran_ chkmemfortran 13 #define flush__ flush_ 14 #define petscobjectstateincrease_ petscobjectstateincrease 15 #define petscobjectcomposefunction_ petscobjectcomposefunction 16 #define petscobjectqueryfunction_ petscobjectqueryfunction 17 #endif 18 19 PETSC_EXTERN void PETSC_STDCALL petscobjectstateincrease_(PetscObject *obj, PetscErrorCode *ierr) 20 { 21 *ierr = PetscObjectStateIncrease(*obj); 22 } 23 24 #if defined(PETSC_MISSING_FORTRAN_FLUSH_) 25 void flush__(int unit) 26 { 27 } 28 #endif 29 30 31 PETSC_EXTERN void PETSC_STDCALL petscoffsetfortran_(PetscScalar *x,PetscScalar *y,size_t *shift,PetscErrorCode *ierr) 32 { 33 *ierr = 0; 34 *shift = y - x; 35 } 36 37 /* ---------------------------------------------------------------------------------*/ 38 /* 39 This version does not do a malloc 40 */ 41 static char FIXCHARSTRING[1024]; 42 43 #define FIXCHARNOMALLOC(a,n,b) \ 44 {\ 45 if (a == PETSC_NULL_CHARACTER_Fortran) { \ 46 b = a = 0; \ 47 } else { \ 48 while ((n > 0) && (a[n-1] == ' ')) n--; \ 49 if (a[n] != 0) { \ 50 b = FIXCHARSTRING; \ 51 *ierr = PetscStrncpy(b,a,n+1); \ 52 if (*ierr) return; \ 53 } else b = a;\ 54 } \ 55 } 56 57 PETSC_EXTERN void PETSC_STDCALL chkmemfortran_(int *line,char* file PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 58 { 59 char *c1; 60 61 FIXCHARNOMALLOC(file,len,c1); 62 *ierr = PetscMallocValidate(*line,"Userfunction",c1); 63 } 64 65 PETSC_EXTERN void PETSC_STDCALL petscobjectcomposefunction_(PetscObject *obj, char* name PETSC_MIXED_LEN(len), void (*fptr)(void), PetscErrorCode *ierr PETSC_END_LEN(len)) 66 { 67 char *c1; 68 69 FIXCHARNOMALLOC(name,len,c1); 70 *ierr = PetscObjectComposeFunction(*obj,name,**fptr); 71 } 72 73 PETSC_EXTERN void PETSC_STDCALL petscobjectqueryfunction_(PetscObject *obj, char* name PETSC_MIXED_LEN(len), void (**fptr)(void), PetscErrorCode *ierr PETSC_END_LEN(len)) 74 { 75 char *c1; 76 77 FIXCHARNOMALLOC(name,len,c1); 78 *ierr = PetscObjectQueryFunction(*obj,name,fptr); 79 } 80 81