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