My Project
 All Classes Files Functions Variables Enumerations Enumerator Friends Macros Pages
f77_wrap.h
1 #define UNSIGNED_BYTE
2 #include "cfortran.h"
3 
4 /************************************************************************
5  DEC C creates longs as 8-byte integers. On most other machines, ints
6  and longs are both 4-bytes, so both are compatible with Fortrans
7  default integer which is 4-bytes. To support DECs, we must redefine
8  LONGs and convert them to 8-bytes when going to C, and restore them
9  to 4-bytes when returning to Fortran. Ugh!!!
10 *************************************************************************/
11 
12 #if defined(DECFortran) || (defined(__alpha) && defined(g77Fortran)) \
13  || (defined(mipsFortran) && _MIPS_SZLONG==64)
14 
15 #undef LONGV_cfSTR
16 #undef PLONG_cfSTR
17 #undef LONGVVVVVVV_cfTYPE
18 #undef PLONG_cfTYPE
19 #undef LONGV_cfT
20 #undef PLONG_cfT
21 
22 #define LONGV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LONGV,A,B,C,D,E)
23 #define PLONG_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,PLONG,A,B,C,D,E)
24 #define LONGVVVVVVV_cfTYPE int
25 #define PLONG_cfTYPE int
26 #define LONGV_cfQ(B) long *B, _(B,N);
27 #define PLONG_cfQ(B) long B;
28 #define LONGV_cfT(M,I,A,B,D) ( (_(B,N) = * _3(M,_LONGV_A,I)), \
29  B = F2Clongv(_(B,N),A) )
30 #define PLONG_cfT(M,I,A,B,D) ((B=*A),&B)
31 #define LONGV_cfR(A,B,D) C2Flongv(_(B,N),A,B);
32 #define PLONG_cfR(A,B,D) *A=B;
33 #define LONGV_cfH(S,U,B)
34 #define PLONG_cfH(S,U,B)
35 
36 static long *F2Clongv(long size, int *A)
37 {
38  long i;
39  long *B;
40 
41  B=(long *)malloc( size*sizeof(long) );
42  for(i=0;i<size;i++) B[i]=A[i];
43  return(B);
44 }
45 
46 static void C2Flongv(long size, int *A, long *B)
47 {
48  long i;
49 
50  for(i=0;i<size;i++) A[i]=B[i];
51  free(B);
52 }
53 
54 #endif
55 
56 /************************************************************************
57  Modify cfortran.h's handling of strings. C interprets a "char **"
58  parameter as an array of pointers to the strings (or as a handle),
59  not as a pointer to a block of contiguous strings. Also set a
60  a minimum length for string allocations, to minimize risk of
61  overflow.
62 *************************************************************************/
63 
64 extern unsigned long gMinStrLen;
65 
66 #undef STRINGV_cfQ
67 #undef STRINGV_cfR
68 #undef TTSTR
69 #undef TTTTSTRV
70 #undef RRRRPSTRV
71 
72 #undef PPSTRING_cfT
73 
74 #ifdef vmsFortran
75 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)A->dsc$a_pointer
76 
77 /* We want single strings to be equivalent to string vectors with */
78 /* a single element, so ignore the number of elements info in the */
79 /* vector structure, and rely on the NUM_ELEM definitions. */
80 
81 #undef STRINGV_cfT
82 #define STRINGV_cfT(M,I,A,B,D) TTTTSTRV(A->dsc$a_pointer, B, \
83  A->dsc$w_length, \
84  num_elem(A->dsc$a_pointer, \
85  A->dsc$w_length, \
86  _3(M,_STRV_A,I) ) )
87 #else
88 #ifdef CRAYFortran
89 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)_fcdtocp(A)
90 #else
91 #define PPSTRING_cfT(M,I,A,B,D) (unsigned char*)A
92 #endif
93 #endif
94 
95 #define _cfMAX(A,B) ( (A>B) ? A : B )
96 #define STRINGV_cfQ(B) char **B; unsigned int _(B,N), _(B,M);
97 #define STRINGV_cfR(A,B,D) free(B[0]); free(B);
98 #define TTSTR( A,B,D) \
99  ((B=(char*)malloc(_cfMAX(D,gMinStrLen)+1))[D]='\0',memcpy(B,A,D), \
100  kill_trailing(B,' '))
101 #define TTTTSTRV( A,B,D,E) ( \
102  _(B,N)=_cfMAX(E,1), \
103  _(B,M)=_cfMAX(D,gMinStrLen)+1, \
104  B=(char**)malloc(_(B,N)*sizeof(char*)), \
105  B[0]=(char*)malloc(_(B,N)*_(B,M)), \
106  vindex(B,_(B,M),_(B,N),f2cstrv2(A,B[0],D,_(B,M),_(B,N))) \
107  )
108 #define RRRRPSTRV(A,B,D) \
109  c2fstrv2(B[0],A,_(B,M),D,_(B,N)), \
110  free(B[0]), \
111  free(B);
112 
113 static char **vindex(char **B, int elem_len, int nelem, char *B0)
114 {
115  int i;
116  if( nelem )
117  for( i=0;i<nelem;i++ ) B[i] = B0+i*elem_len;
118  return B;
119 }
120 
121 static char *c2fstrv2(char* cstr, char *fstr, int celem_len, int felem_len,
122  int nelem)
123 {
124  int i,j;
125 
126  if( nelem )
127  for (i=0; i<nelem; i++) {
128  for (j=0; j<felem_len && *cstr; j++) *fstr++ = *cstr++;
129  cstr += celem_len-j;
130  for (; j<felem_len; j++) *fstr++ = ' ';
131  }
132  return( fstr-felem_len*nelem );
133 }
134 
135 static char *f2cstrv2(char *fstr, char* cstr, int felem_len, int celem_len,
136  int nelem)
137 {
138  int i,j;
139 
140  if( nelem )
141  for (i=0; i<nelem; i++, cstr+=(celem_len-felem_len)) {
142  for (j=0; j<felem_len; j++) *cstr++ = *fstr++;
143  *cstr='\0';
144  kill_trailingn( cstr-felem_len, ' ', cstr );
145  }
146  return( cstr-celem_len*nelem );
147 }
148 
149 /************************************************************************
150  The following definitions redefine the BYTE data type to be
151  interpretted as a character*1 string instead of an integer*1 which
152  is not supported by all compilers.
153 *************************************************************************/
154 
155 #undef BYTE_cfT
156 #undef BYTEV_cfT
157 #undef BYTE_cfINT
158 #undef BYTEV_cfINT
159 #undef BYTE_cfSTR
160 #undef BYTEV_cfSTR
161 
162 #define BYTE_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,BYTE,B,X,Y,Z,0)
163 #define BYTEV_cfINT(N,A,B,X,Y,Z) _(CFARGS,N)(A,BYTEV,B,X,Y,Z,0)
164 #define BYTE_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,BYTE,A,B,C,D,E)
165 #define BYTEV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,BYTEV,A,B,C,D,E)
166 #define BYTE_cfSEP(T,B) INT_cfSEP(T,B)
167 #define BYTEV_cfSEP(T,B) INT_cfSEP(T,B)
168 #define BYTE_cfH(S,U,B) STRING_cfH(S,U,B)
169 #define BYTEV_cfH(S,U,B) STRING_cfH(S,U,B)
170 #define BYTE_cfQ(B)
171 #define BYTEV_cfQ(B)
172 #define BYTE_cfR(A,B,D)
173 #define BYTEV_cfR(A,B,D)
174 
175 #ifdef vmsFortran
176 #define BYTE_cfN(T,A) fstring * A
177 #define BYTEV_cfN(T,A) fstringvector * A
178 #define BYTE_cfT(M,I,A,B,D) (INTEGER_BYTE)((A->dsc$a_pointer)[0])
179 #define BYTEV_cfT(M,I,A,B,D) (INTEGER_BYTE*)A->dsc$a_pointer
180 #else
181 #ifdef CRAYFortran
182 #define BYTE_cfN(T,A) _fcd A
183 #define BYTEV_cfN(T,A) _fcd A
184 #define BYTE_cfT(M,I,A,B,D) (INTEGER_BYTE)((_fcdtocp(A))[0])
185 #define BYTEV_cfT(M,I,A,B,D) (INTEGER_BYTE*)_fcdtocp(A)
186 #else
187 #define BYTE_cfN(T,A) INTEGER_BYTE * A
188 #define BYTEV_cfN(T,A) INTEGER_BYTE * A
189 #define BYTE_cfT(M,I,A,B,D) A[0]
190 #define BYTEV_cfT(M,I,A,B,D) A
191 #endif
192 #endif
193 
194 /************************************************************************
195  The following definitions and functions handle conversions between
196  C and Fortran arrays of LOGICALS. Individually, LOGICALS are
197  treated as int's but as char's when in an array. cfortran defines
198  (F2C/C2F)LOGICALV but never uses them, so these routines also
199  handle TRUE/FALSE conversions.
200 *************************************************************************/
201 
202 #undef LOGICALV_cfSTR
203 #undef LOGICALV_cfT
204 #define LOGICALV_cfSTR(N,T,A,B,C,D,E) _(CFARGS,N)(T,LOGICALV,A,B,C,D,E)
205 #define LOGICALV_cfQ(B) char *B; unsigned int _(B,N);
206 #define LOGICALV_cfT(M,I,A,B,D) (_(B,N)= * _3(M,_LOGV_A,I), \
207  B=F2CcopyLogVect(_(B,N),A))
208 #define LOGICALV_cfR(A,B,D) C2FcopyLogVect(_(B,N),A,B);
209 #define LOGICALV_cfH(S,U,B)
210 
211 static char *F2CcopyLogVect(long size, int *A)
212 {
213  long i;
214  char *B;
215 
216  B=(char *)malloc(size*sizeof(char));
217  for( i=0; i<size; i++ ) B[i]=F2CLOGICAL(A[i]);
218  return(B);
219 }
220 
221 static void C2FcopyLogVect(long size, int *A, char *B)
222 {
223  long i;
224 
225  for( i=0; i<size; i++ ) A[i]=C2FLOGICAL(B[i]);
226  free(B);
227 }
228 
229 /*------------------ Fortran File Handling ----------------------*/
230 /* Fortran uses unit numbers, whereas C uses file pointers, so */
231 /* a global array of file pointers is setup in which Fortran's */
232 /* unit number serves as the index. Two FITSIO routines are */
233 /* the integer unit number and the fitsfile file pointer. */
234 /*-----------------------------------------------------------------*/
235 
236 #define MAXFITSFILES 200 /* Array of file pointers indexed */
237 extern fitsfile *gFitsFiles[]; /* by Fortran unit numbers */
238 
239 #define FITSUNIT_cfINT(N,A,B,X,Y,Z) INT_cfINT(N,A,B,X,Y,Z)
240 #define FITSUNIT_cfSTR(N,T,A,B,C,D,E) INT_cfSTR(N,T,A,B,C,D,E)
241 #define FITSUNIT_cfT(M,I,A,B,D) gFitsFiles[*A]
242 #define FITSUNITVVVVVVV_cfTYPE int
243 #define PFITSUNIT_cfINT(N,A,B,X,Y,Z) PINT_cfINT(N,A,B,X,Y,Z)
244 #define PFITSUNIT_cfSTR(N,T,A,B,C,D,E) PINT_cfSTR(N,T,A,B,C,D,E)
245 #define PFITSUNIT_cfT(M,I,A,B,D) (gFitsFiles + *A)
246 #define PFITSUNIT_cfTYPE int
247 
248 
249 /*---------------------- Make C++ Happy -----------------------------*/
250 /* Redefine FCALLSCFUNn so that they create prototypes of themselves */
251 /* and change TTTTSTR to use (char *)0 instead of NULL */
252 /*-------------------------------------------------------------------*/
253 
254 #undef FCALLSCFUN0
255 #undef FCALLSCFUN14
256 #undef TTTTSTR
257 
258 #define TTTTSTR(A,B,D) ( !(D<4||A[0]||A[1]||A[2]||A[3]) ) ? ((char*)0) : \
259  memchr(A,'\0',D) ? A : TTSTR(A,B,D)
260 
261 #define FCALLSCFUN0(T0,CN,UN,LN) \
262  CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0)); \
263  CFextern _(T0,_cfFZ)(UN,LN) void ABSOFT_cf2(T0)) \
264  {_Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN(); _Icf(0,K,T0,0,0) _(T0,_cfI)}
265 
266 #define FCALLSCFUN14(T0,CN,UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
267  CFextern _(T0,_cfF)(UN,LN) \
268  CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)); \
269  CFextern _(T0,_cfF)(UN,LN) \
270  CFARGT14(NCF,DCF,ABSOFT_cf2(T0),T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)) \
271  { CFARGT14S(QCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
272  _Icf(2,UU,T0,A0,0); _Icf(0,L,T0,0,0) CN( TCF(LN,T1,1,0) TCF(LN,T2,2,1) \
273  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) \
274  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) \
275  TCF(LN,TD,D,1) TCF(LN,TE,E,1) ); _Icf(0,K,T0,0,0) \
276  CFARGT14S(RCF,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) _(T0,_cfI) \
277  }
278 
fitsfile
Definition: fitsio.h:248