1 2 #include "zpetsc.h" 3 #include "petscsys.h" 4 5 #ifdef PETSC_HAVE_FORTRAN_CAPS 6 #define chkmemfortran_ CHKMEMFORTRAN 7 #define petscoffsetfortran_ PETSCOFFSETFORTRAN 8 #elif !defined(PETSC_HAVE_FORTRAN_UNDERSCORE) 9 #define petscoffsetfortran_ petscoffsetfortran 10 #define chkmemfortran_ chkmemfortran 11 #endif 12 13 EXTERN_C_BEGIN 14 15 void PETSC_STDCALL petscoffsetfortran_(PetscScalar *x,PetscScalar *y,size_t *shift,PetscErrorCode *ierr) 16 { 17 *ierr = 0; 18 *shift = y - x; 19 } 20 21 /* ---------------------------------------------------------------------------------*/ 22 /* 23 This version does not do a malloc 24 */ 25 static char FIXCHARSTRING[1024]; 26 #if defined(PETSC_USES_CPTOFCD) 27 #include <fortran.h> 28 29 #define CHAR _fcd 30 #define FIXCHARNOMALLOC(a,n,b) \ 31 { \ 32 b = _fcdtocp(a); \ 33 n = _fcdlen (a); \ 34 if (b == PETSC_NULL_CHARACTER_Fortran) { \ 35 b = 0; \ 36 } else { \ 37 while((n > 0) && (b[n-1] == ' ')) n--; \ 38 b = FIXCHARSTRING; \ 39 *ierr = PetscStrncpy(b,_fcdtocp(a),n); \ 40 if (*ierr) return; \ 41 b[n] = 0; \ 42 } \ 43 } 44 45 #else 46 47 #define CHAR char* 48 #define FIXCHARNOMALLOC(a,n,b) \ 49 {\ 50 if (a == PETSC_NULL_CHARACTER_Fortran) { \ 51 b = a = 0; \ 52 } else { \ 53 while((n > 0) && (a[n-1] == ' ')) n--; \ 54 if (a[n] != 0) { \ 55 b = FIXCHARSTRING; \ 56 *ierr = PetscStrncpy(b,a,n); \ 57 if (*ierr) return; \ 58 b[n] = 0; \ 59 } else b = a;\ 60 } \ 61 } 62 63 #endif 64 65 void PETSC_STDCALL chkmemfortran_(int *line,CHAR file PETSC_MIXED_LEN(len),PetscErrorCode *ierr PETSC_END_LEN(len)) 66 { 67 char *c1; 68 69 FIXCHARNOMALLOC(file,len,c1); 70 *ierr = PetscMallocValidate(*line,"Userfunction",c1," "); 71 } 72 73 74 EXTERN_C_END 75 76 77