From 832b4b34ff8ce84a13751883c0822c16c152fe48 Mon Sep 17 00:00:00 2001
From: Joseph Hunkeler <jhunkeler@gmail.com>
Date: Thu, 5 Mar 2015 12:53:09 -0500
Subject: Massive rework

---
 src/include/f77_wrap.h | 277 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 277 insertions(+)
 create mode 100644 src/include/f77_wrap.h

(limited to 'src/include/f77_wrap.h')

diff --git a/src/include/f77_wrap.h b/src/include/f77_wrap.h
new file mode 100644
index 0000000..121850f
--- /dev/null
+++ b/src/include/f77_wrap.h
@@ -0,0 +1,277 @@
+#define UNSIGNED_BYTE
+#include "cfortran.h"
+
+/************************************************************************
+   DEC C creates longs as 8-byte integers.  On most other machines, ints
+   and longs are both 4-bytes, so both are compatible with Fortrans
+   default integer which is 4-bytes.  To support DECs, we must redefine
+   LONGs and convert them to 8-bytes when going to C, and restore them
+   to 4-bytes when returning to Fortran.  Ugh!!!
+*************************************************************************/
+
+#if (defined DECFortran) || (defined(__alpha) && defined(g77Fortran))
+
+#undef LONGV_cfSTR
+#undef PLONG_cfSTR
+#undef LONGVVVVVVV_cfTYPE
+#undef PLONG_cfTYPE
+#undef LONGV_cfT
+#undef PLONG_cfT
+
+#define    LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LONGV,A,B,C,D,E)
+#define    PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLONG,A,B,C,D,E)
+#define    LONGVVVVVVV_cfTYPE    int
+#define    PLONG_cfTYPE          int
+#define    LONGV_cfQ(B)          long *B, _(B,N);
+#define    PLONG_cfQ(B)          long B;
+#define    LONGV_cfT(M,I,A,B,D)  ( (_(B,N) = * _3(M,_LONGV_A,I)), \
+				    B = F2Clongv(_(B,N),A) )
+#define    PLONG_cfT(M,I,A,B,D)  ((B=*A),&B)
+#define    LONGV_cfR(A,B,D)      C2Flongv(_(B,N),A,B);
+#define    PLONG_cfR(A,B,D)      *A=B;
+#define    LONGV_cfH(S,U,B)
+#define    PLONG_cfH(S,U,B)
+
+static long *F2Clongv(long size, int *A)
+{
+  long i;
+  long *B;
+
+  B=(long *)malloc( size*sizeof(long) );
+  for(i=0;i<size;i++) B[i]=A[i];
+  return(B);
+}
+
+static void C2Flongv(long size, int *A, long *B)
+{
+  long i;
+
+  for(i=0;i<size;i++) A[i]=B[i];
+  free(B);
+}
+
+#endif
+
+/************************************************************************
+   Modify cfortran.h's handling of strings.  C interprets a "char **"
+   parameter as an array of pointers to the strings (or as a handle),
+   not as a pointer to a block of contiguous strings.  Also set a
+   a minimum length for string allocations, to minimize risk of
+   overflow.
+*************************************************************************/
+
+extern unsigned long gMinStrLen;
+
+#undef  STRINGV_cfQ
+#undef  STRINGV_cfR
+#undef  TTSTR
+#undef  TTTTSTRV
+#undef  RRRRPSTRV
+
+#undef  PPSTRING_cfT
+
+#ifdef vmsFortran
+#define       PPSTRING_cfT(M,I,A,B,D)     (unsigned char*)A->dsc$a_pointer
+
+/*  We want single strings to be equivalent to string vectors with  */
+/*  a single element, so ignore the number of elements info in the  */
+/*  vector structure, and rely on the NUM_ELEM definitions.         */
+
+#undef  STRINGV_cfT
+#define STRINGV_cfT(M,I,A,B,D)  TTTTSTRV(A->dsc$a_pointer, B, \
+                                         A->dsc$w_length, \
+                                         num_elem(A->dsc$a_pointer, \
+                                                  A->dsc$w_length, \
+                                                  _3(M,_STRV_A,I) ) )
+#else
+#ifdef CRAYFortran
+#define       PPSTRING_cfT(M,I,A,B,D)     (unsigned char*)_fcdtocp(A)
+#else
+#define       PPSTRING_cfT(M,I,A,B,D)     (unsigned char*)A
+#endif
+#endif
+
+#define _cfMAX(A,B)  ( (A>B) ? A : B )
+#define  STRINGV_cfQ(B)      char **B; unsigned int _(B,N), _(B,M);
+#define  STRINGV_cfR(A,B,D)  free(B[0]); free(B);
+#define  TTSTR(    A,B,D)  \
+            ((B=(char*)malloc(_cfMAX(D,gMinStrLen)+1))[D]='\0',memcpy(B,A,D), \
+               kill_trailing(B,' '))
+#define  TTTTSTRV( A,B,D,E)  ( \
+            _(B,N)=_cfMAX(E,1), \
+            _(B,M)=_cfMAX(D,gMinStrLen)+1, \
+            B=(char**)malloc(_(B,N)*sizeof(char*)), \
+            B[0]=(char*)malloc(_(B,N)*_(B,M)), \
+            vindex(B,_(B,M),_(B,N),f2cstrv2(A,B[0],D,_(B,M),_(B,N))) \
+            )
+#define  RRRRPSTRV(A,B,D)    \
+            c2fstrv2(B[0],A,_(B,M),D,_(B,N)), \
+            free(B[0]), \
+            free(B);
+
+static char **vindex(char **B, int elem_len, int nelem, char *B0)
+{
+   int i;
+   if( nelem )
+      for( i=0;i<nelem;i++ ) B[i] = B0+i*elem_len;
+   return B;
+}
+
+static char *c2fstrv2(char* cstr, char *fstr, int celem_len, int felem_len,
+               int nelem)
+{
+   int i,j;
+
+   if( nelem )
+      for (i=0; i<nelem; i++) {
+	 for (j=0; j<felem_len && *cstr; j++) *fstr++ = *cstr++;
+	 cstr += celem_len-j;
+	 for (; j<felem_len; j++) *fstr++ = ' ';
+      }
+   return( fstr-felem_len*nelem );
+}
+
+static char *f2cstrv2(char *fstr, char* cstr, int felem_len, int celem_len,
+               int nelem)
+{
+   int i,j;
+
+   if( nelem )
+      for (i=0; i<nelem; i++, cstr+=(celem_len-felem_len)) {
+	 for (j=0; j<felem_len; j++) *cstr++ = *fstr++;
+	 *cstr='\0';
+	 kill_trailingn( cstr-felem_len, ' ', cstr );
+      }
+   return( cstr-celem_len*nelem );
+}
+
+/************************************************************************
+   The following definitions redefine the BYTE data type to be
+   interpretted as a character*1 string instead of an integer*1 which
+   is not supported by all compilers.
+*************************************************************************/
+
+#undef   BYTE_cfT
+#undef   BYTEV_cfT
+#undef   BYTE_cfINT
+#undef   BYTEV_cfINT
+#undef   BYTE_cfSTR
+#undef   BYTEV_cfSTR
+
+#define   BYTE_cfINT(N,A,B,X,Y,Z)      _(CFARGS,N)(A,BYTE,B,X,Y,Z,0)
+#define   BYTEV_cfINT(N,A,B,X,Y,Z)     _(CFARGS,N)(A,BYTEV,B,X,Y,Z,0)
+#define   BYTE_cfSTR(N,T,A,B,C,D,E)    _(CFARGS,N)(T,BYTE,A,B,C,D,E)
+#define   BYTEV_cfSTR(N,T,A,B,C,D,E)   _(CFARGS,N)(T,BYTEV,A,B,C,D,E)
+#define   BYTE_cfSEP(T,B)              INT_cfSEP(T,B)
+#define   BYTEV_cfSEP(T,B)             INT_cfSEP(T,B)
+#define   BYTE_cfH(S,U,B)              STRING_cfH(S,U,B)
+#define   BYTEV_cfH(S,U,B)             STRING_cfH(S,U,B)
+#define   BYTE_cfQ(B)
+#define   BYTEV_cfQ(B)
+#define   BYTE_cfR(A,B,D)
+#define   BYTEV_cfR(A,B,D)
+
+#ifdef vmsFortran
+#define   BYTE_cfN(T,A)           fstring * A
+#define   BYTEV_cfN(T,A)          fstringvector * A
+#define   BYTE_cfT(M,I,A,B,D)     (INTEGER_BYTE)((A->dsc$a_pointer)[0])
+#define   BYTEV_cfT(M,I,A,B,D)    (INTEGER_BYTE*)A->dsc$a_pointer
+#else
+#ifdef CRAYFortran
+#define   BYTE_cfN(T,A)           _fcd A
+#define   BYTEV_cfN(T,A)          _fcd A
+#define   BYTE_cfT(M,I,A,B,D)     (INTEGER_BYTE)((_fcdtocp(A))[0])
+#define   BYTEV_cfT(M,I,A,B,D)    (INTEGER_BYTE*)_fcdtocp(A)
+#else
+#define   BYTE_cfN(T,A)           INTEGER_BYTE * A
+#define   BYTEV_cfN(T,A)          INTEGER_BYTE * A
+#define   BYTE_cfT(M,I,A,B,D)     A[0]
+#define   BYTEV_cfT(M,I,A,B,D)    A
+#endif
+#endif
+
+/************************************************************************
+   The following definitions and functions handle conversions between
+   C and Fortran arrays of LOGICALS.  Individually, LOGICALS are
+   treated as int's but as char's when in an array.  cfortran defines
+   (F2C/C2F)LOGICALV but never uses them, so these routines also
+   handle TRUE/FALSE conversions.
+*************************************************************************/
+
+#undef  LOGICALV_cfSTR
+#undef  LOGICALV_cfT
+#define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICALV,A,B,C,D,E)
+#define LOGICALV_cfQ(B)               char *B; unsigned int _(B,N);
+#define LOGICALV_cfT(M,I,A,B,D)       (_(B,N)= * _3(M,_LOGV_A,I), \
+                                            B=F2CcopyLogVect(_(B,N),A))
+#define LOGICALV_cfR(A,B,D)           C2FcopyLogVect(_(B,N),A,B);
+#define LOGICALV_cfH(S,U,B)
+
+static char *F2CcopyLogVect(long size, int *A)
+{
+   long i;
+   char *B;
+
+   B=(char *)malloc(size*sizeof(char));
+   for( i=0; i<size; i++ ) B[i]=F2CLOGICAL(A[i]);
+   return(B);
+}
+
+static void C2FcopyLogVect(long size, int *A, char *B)
+{
+   long i;
+
+   for( i=0; i<size; i++ ) A[i]=C2FLOGICAL(B[i]);
+   free(B);
+}
+
+/*------------------  Fortran File Handling  ----------------------*/
+/*  Fortran uses unit numbers, whereas C uses file pointers, so    */
+/*  a global array of file pointers is setup in which Fortran's    */
+/*  unit number serves as the index.  Two FITSIO routines are      */
+/*  the integer unit number and the fitsfile file pointer.         */
+/*-----------------------------------------------------------------*/
+
+#define MAXFITSFILES 200             /*  Array of file pointers indexed  */
+extern fitsfile *gFitsFiles[];       /*    by Fortran unit numbers       */
+
+#define  FITSUNIT_cfINT(N,A,B,X,Y,Z)   INT_cfINT(N,A,B,X,Y,Z)
+#define  FITSUNIT_cfSTR(N,T,A,B,C,D,E) INT_cfSTR(N,T,A,B,C,D,E)
+#define  FITSUNIT_cfT(M,I,A,B,D)       gFitsFiles[*A]
+#define  FITSUNITVVVVVVV_cfTYPE        int
+#define PFITSUNIT_cfINT(N,A,B,X,Y,Z)   PINT_cfINT(N,A,B,X,Y,Z)
+#define PFITSUNIT_cfSTR(N,T,A,B,C,D,E) PINT_cfSTR(N,T,A,B,C,D,E)
+#define PFITSUNIT_cfT(M,I,A,B,D)       (gFitsFiles + *A)
+#define PFITSUNIT_cfTYPE               int
+
+
+/*---------------------- Make C++ Happy -----------------------------*/
+/* Redefine FCALLSCFUNn so that they create prototypes of themselves */
+/*   and change TTTTSTR to use (char *)0 instead of NULL             */
+/*-------------------------------------------------------------------*/
+
+#undef FCALLSCFUN0
+#undef FCALLSCFUN14
+#undef TTTTSTR
+
+#define TTTTSTR(A,B,D)   ( !(D<4||A[0]||A[1]||A[2]||A[3]) ) ? ((char*)0) :     \
+                             memchr(A,'\0',D) ? A : TTSTR(A,B,D)
+
+#define FCALLSCFUN0(T0,CN,UN,LN) \
+  CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0)); \
+  CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0))  \
+  {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
+
+#define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)    \
+  CFextern _(T0,_cfF)(UN,LN)                                                   \
+  CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
+  CFextern _(T0,_cfF)(UN,LN)                                                   \
+  CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE))  \
+  {                 CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)   \
+  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0)      CN(  TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
+    TCF(LN,T3,3,1) TCF(LN,T4,4,1) TCF(LN,T5,5,1) TCF(LN,T6,6,1) TCF(LN,T7,7,1) \
+    TCF(LN,T8,8,1) TCF(LN,T9,9,1) TCF(LN,TA,A,1) TCF(LN,TB,B,1) TCF(LN,TC,C,1) \
+    TCF(LN,TD,D,1) TCF(LN,TE,E,1) );                          _Icf(0,K,T0,0,0) \
+    CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)        _(T0,_cfI) \
+  }
+
-- 
cgit