"SfR Fresh" - the SfR Freeware/Shareware Archive 
Member "cfitsio/cfortran.h" of archive cfitsio3100.tar.gz:
As a special service "SfR Fresh" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting with prefixed line numbers.
Alternatively you can here view or download the uninterpreted source code file.
That can be also achieved for any archive member file by clicking within an archive contents listing on the first character of the file(path) respectively on the according byte size field.
1 /* cfortran.h 4.4 */
2 /* http://www-zeus.desy.de/~burow/cfortran/ */
3 /* Burkhard Burow burow@desy.de 1990 - 2002. */
4
5 #ifndef __CFORTRAN_LOADED
6 #define __CFORTRAN_LOADED
7
8 /*
9 THIS FILE IS PROPERTY OF BURKHARD BUROW. IF YOU ARE USING THIS FILE YOU
10 SHOULD ALSO HAVE ACCESS TO CFORTRAN.DOC WHICH PROVIDES TERMS FOR USING,
11 MODIFYING, COPYING AND DISTRIBUTING THE CFORTRAN.H PACKAGE.
12 */
13
14 /* The following modifications were made by the authors of CFITSIO or by me.
15 * They are flagged below with CFITSIO, the author's initials, or KMCCARTY.
16 * PDW = Peter Wilson
17 * DM = Doug Mink
18 * LEB = Lee E Brotzman
19 * MR = Martin Reinecke
20 * WDP = William D Pence
21 * -- Kevin McCarty, for Debian (19 Dec. 2005) */
22
23 /*******
24 Modifications:
25 Oct 1997: Changed symbol name extname to appendus (PDW/HSTX)
26 (Conflicted with a common variable name in FTOOLS)
27 Nov 1997: If g77Fortran defined, also define f2cFortran (PDW/HSTX)
28 Feb 1998: Let VMS see the NUM_ELEMS code. Lets programs treat
29 single strings as vectors with single elements
30 Nov 1999: If macintoxh defined, also define f2cfortran (for Mac OS-X)
31 Apr 2000: If WIN32 defined, also define PowerStationFortran and
32 VISUAL_CPLUSPLUS (Visual C++)
33 Jun 2000: If __GNUC__ and linux defined, also define f2cFortran
34 (linux/gcc environment detection)
35 Apr 2002: If __CYGWIN__ is defined, also define f2cFortran
36 Nov 2002: If __APPLE__ defined, also define f2cfortran (for Mac OS-X)
37
38 Nov 2003: If __INTEL_COMPILER or INTEL_COMPILER defined, also define
39 f2cFortran (KMCCARTY)
40 Dec 2005: If f2cFortran is defined, enforce REAL functions in FORTRAN
41 returning "double" in C. This was one of the items on
42 Burkhard's TODO list. (KMCCARTY)
43 Dec 2005: Modifications to support 8-byte integers. (MR)
44 USE AT YOUR OWN RISK!
45 Feb 2006 Added logic to typedef the symbol 'LONGLONG' to an appropriate
46 intrinsic 8-byte integer datatype (WDP)
47 Apr 2006: Modifications to support gfortran (and g77 with -fno-f2c flag)
48 since by default it returns "float" for FORTRAN REAL function.
49 (KMCCARTY)
50 May 2008: Revert commenting out of "extern" in COMMON_BLOCK_DEF macro.
51 Add braces around do-nothing ";" in 3 empty while blocks to
52 get rid of compiler warnings. Thanks to ROOT developers
53 Jacek Holeczek and Rene Brun for these suggestions. (KMCCARTY)
54 *******/
55
56 /*
57 Avoid symbols already used by compilers and system *.h:
58 __ - OSF1 zukal06 V3.0 347 alpha, cc -c -std1 cfortest.c
59
60 */
61
62 /*
63 Determine what 8-byte integer data type is available.
64 'long long' is now supported by most compilers, but older
65 MS Visual C++ compilers before V7.0 use '__int64' instead. (WDP)
66 */
67
68 #ifndef LONGLONG_TYPE /* this may have been previously defined */
69 #if defined(_MSC_VER) /* Microsoft Visual C++ */
70
71 #if (_MSC_VER < 1300) /* versions earlier than V7.0 do not have 'long long' */
72 typedef __int64 LONGLONG;
73 #else /* newer versions do support 'long long' */
74 typedef long long LONGLONG;
75 #endif
76
77 #else
78 typedef long long LONGLONG;
79 #endif
80
81 #define LONGLONG_TYPE
82 #endif
83
84
85 /* First prepare for the C compiler. */
86
87 #ifndef ANSI_C_preprocessor /* i.e. user can override. */
88 #ifdef __CF__KnR
89 #define ANSI_C_preprocessor 0
90 #else
91 #ifdef __STDC__
92 #define ANSI_C_preprocessor 1
93 #else
94 #define _cfleft 1
95 #define _cfright
96 #define _cfleft_cfright 0
97 #define ANSI_C_preprocessor _cfleft/**/_cfright
98 #endif
99 #endif
100 #endif
101
102 #if ANSI_C_preprocessor
103 #define _0(A,B) A##B
104 #define _(A,B) _0(A,B) /* see cat,xcat of K&R ANSI C p. 231 */
105 #define _2(A,B) A##B /* K&R ANSI C p.230: .. identifier is not replaced */
106 #define _3(A,B,C) _(A,_(B,C))
107 #else /* if it turns up again during rescanning. */
108 #define _(A,B) A/**/B
109 #define _2(A,B) A/**/B
110 #define _3(A,B,C) A/**/B/**/C
111 #endif
112
113 #if (defined(vax)&&defined(unix)) || (defined(__vax__)&&defined(__unix__))
114 #define VAXUltrix
115 #endif
116
117 #include <stdio.h> /* NULL [in all machines stdio.h] */
118 #include <string.h> /* strlen, memset, memcpy, memchr. */
119 #if !( defined(VAXUltrix) || defined(sun) || (defined(apollo)&&!defined(__STDCPP__)) )
120 #include <stdlib.h> /* malloc,free */
121 #else
122 #include <malloc.h> /* Had to be removed for DomainOS h105 10.4 sys5.3 425t*/
123 #ifdef apollo
124 #define __CF__APOLLO67 /* __STDCPP__ is in Apollo 6.8 (i.e. ANSI) and onwards */
125 #endif
126 #endif
127
128 #if !defined(__GNUC__) && !defined(__sun) && (defined(sun)||defined(VAXUltrix)||defined(lynx))
129 #define __CF__KnR /* Sun, LynxOS and VAX Ultrix cc only supports K&R. */
130 /* Manually define __CF__KnR for HP if desired/required.*/
131 #endif /* i.e. We will generate Kernighan and Ritchie C. */
132 /* Note that you may define __CF__KnR before #include cfortran.h, in order to
133 generate K&R C instead of the default ANSI C. The differences are mainly in the
134 function prototypes and declarations. All machines, except the Apollo, work
135 with either style. The Apollo's argument promotion rules require ANSI or use of
136 the obsolete std_$call which we have not implemented here. Hence on the Apollo,
137 only C calling FORTRAN subroutines will work using K&R style.*/
138
139
140 /* Remainder of cfortran.h depends on the Fortran compiler. */
141
142 /* 11/29/2003 (KMCCARTY): add *INTEL_COMPILER symbols here */
143 /* 04/05/2006 (KMCCARTY): add gFortran symbol here */
144 #if defined(CLIPPERFortran) || defined(pgiFortran) || defined(__INTEL_COMPILER) || defined(INTEL_COMPILER) || defined(gFortran)
145 #define f2cFortran
146 #endif
147
148 /* VAX/VMS does not let us \-split long #if lines. */
149 /* Split #if into 2 because some HP-UX can't handle long #if */
150 #if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
151 #if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
152 /* If no Fortran compiler is given, we choose one for the machines we know. */
153 #if defined(lynx) || defined(VAXUltrix)
154 #define f2cFortran /* Lynx: Only support f2c at the moment.
155 VAXUltrix: f77 behaves like f2c.
156 Support f2c or f77 with gcc, vcc with f2c.
157 f77 with vcc works, missing link magic for f77 I/O.*/
158 #endif
159 /* 04/13/00 DM (CFITSIO): Add these lines for NT */
160 /* with PowerStationFortran and and Visual C++ */
161 #if defined(WIN32) && !defined(__CYGWIN__)
162 #define PowerStationFortran
163 #define VISUAL_CPLUSPLUS
164 #endif
165 #if defined(g77Fortran) /* 11/03/97 PDW (CFITSIO) */
166 #define f2cFortran
167 #endif
168 #if defined(__CYGWIN__) /* 04/11/02 LEB (CFITSIO) */
169 #define f2cFortran
170 #endif
171 #if defined(__GNUC__) && defined(linux) /* 06/21/00 PDW (CFITSIO) */
172 #define f2cFortran
173 #endif
174 #if defined(macintosh) /* 11/1999 (CFITSIO) */
175 #define f2cFortran
176 #endif
177 #if defined(__APPLE__) /* 11/2002 (CFITSIO) */
178 #define f2cFortran
179 #endif
180 #if defined(__hpux) /* 921107: Use __hpux instead of __hp9000s300 */
181 #define hpuxFortran /* Should also allow hp9000s7/800 use.*/
182 #endif
183 #if defined(apollo)
184 #define apolloFortran /* __CF__APOLLO67 also defines some behavior. */
185 #endif
186 #if defined(sun) || defined(__sun)
187 #define sunFortran
188 #endif
189 #if defined(_IBMR2)
190 #define IBMR2Fortran
191 #endif
192 #if defined(_CRAY)
193 #define CRAYFortran /* _CRAYT3E also defines some behavior. */
194 #endif
195 #if defined(_SX)
196 #define SXFortran
197 #endif
198 #if defined(mips) || defined(__mips)
199 #define mipsFortran
200 #endif
201 #if defined(vms) || defined(__vms)
202 #define vmsFortran
203 #endif
204 #if defined(__alpha) && defined(__unix__)
205 #define DECFortran
206 #endif
207 #if defined(__convex__)
208 #define CONVEXFortran
209 #endif
210 #if defined(VISUAL_CPLUSPLUS)
211 #define PowerStationFortran
212 #endif
213 #endif /* ...Fortran */
214 #endif /* ...Fortran */
215
216 /* Split #if into 2 because some HP-UX can't handle long #if */
217 #if !(defined(NAGf90Fortran)||defined(f2cFortran)||defined(hpuxFortran)||defined(apolloFortran)||defined(sunFortran)||defined(IBMR2Fortran)||defined(CRAYFortran))
218 #if !(defined(mipsFortran)||defined(DECFortran)||defined(vmsFortran)||defined(CONVEXFortran)||defined(PowerStationFortran)||defined(AbsoftUNIXFortran)||defined(AbsoftProFortran)||defined(SXFortran))
219 /* If your compiler barfs on ' #error', replace # with the trigraph for # */
220 #error "cfortran.h: Can't find your environment among:\
221 - GNU gcc (g77) on Linux. \
222 - MIPS cc and f77 2.0. (e.g. Silicon Graphics, DECstations, ...) \
223 - IBM AIX XL C and FORTRAN Compiler/6000 Version 01.01.0000.0000 \
224 - VAX VMS CC 3.1 and FORTRAN 5.4. \
225 - Alpha VMS DEC C 1.3 and DEC FORTRAN 6.0. \
226 - Alpha OSF DEC C and DEC Fortran for OSF/1 AXP Version 1.2 \
227 - Apollo DomainOS 10.2 (sys5.3) with f77 10.7 and cc 6.7. \
228 - CRAY \
229 - NEC SX-4 SUPER-UX \
230 - CONVEX \
231 - Sun \
232 - PowerStation Fortran with Visual C++ \
233 - HP9000s300/s700/s800 Latest test with: HP-UX A.08.07 A 9000/730 \
234 - LynxOS: cc or gcc with f2c. \
235 - VAXUltrix: vcc,cc or gcc with f2c. gcc or cc with f77. \
236 - f77 with vcc works; but missing link magic for f77 I/O. \
237 - NO fort. None of gcc, cc or vcc generate required names.\
238 - f2c/g77: Use #define f2cFortran, or cc -Df2cFortran \
239 - gfortran: Use #define gFortran, or cc -DgFortran \
240 (also necessary for g77 with -fno-f2c option) \
241 - NAG f90: Use #define NAGf90Fortran, or cc -DNAGf90Fortran \
242 - Absoft UNIX F77: Use #define AbsoftUNIXFortran or cc -DAbsoftUNIXFortran \
243 - Absoft Pro Fortran: Use #define AbsoftProFortran \
244 - Portland Group Fortran: Use #define pgiFortran \
245 - Intel Fortran: Use #define INTEL_COMPILER"
246 /* Compiler must throw us out at this point! */
247 #endif
248 #endif
249
250
251 #if defined(VAXC) && !defined(__VAXC)
252 #define OLD_VAXC
253 #pragma nostandard /* Prevent %CC-I-PARAMNOTUSED. */
254 #endif
255
256 /* Throughout cfortran.h we use: UN = Uppercase Name. LN = Lowercase Name. */
257
258 /* "extname" changed to "appendus" below (CFITSIO) */
259 #if defined(f2cFortran) || defined(NAGf90Fortran) || defined(DECFortran) || defined(mipsFortran) || defined(apolloFortran) || defined(sunFortran) || defined(CONVEXFortran) || defined(SXFortran) || defined(appendus)
260 #define CFC_(UN,LN) _(LN,_) /* Lowercase FORTRAN symbols. */
261 #define orig_fcallsc(UN,LN) CFC_(UN,LN)
262 #else
263 #if defined(CRAYFortran) || defined(PowerStationFortran) || defined(AbsoftProFortran)
264 #ifdef _CRAY /* (UN), not UN, circumvents CRAY preprocessor bug. */
265 #define CFC_(UN,LN) (UN) /* Uppercase FORTRAN symbols. */
266 #else /* At least VISUAL_CPLUSPLUS barfs on (UN), so need UN. */
267 #define CFC_(UN,LN) UN /* Uppercase FORTRAN symbols. */
268 #endif
269 #define orig_fcallsc(UN,LN) CFC_(UN,LN) /* CRAY insists on arg.'s here. */
270 #else /* For following machines one may wish to change the fcallsc default. */
271 #define CF_SAME_NAMESPACE
272 #ifdef vmsFortran
273 #define CFC_(UN,LN) LN /* Either case FORTRAN symbols. */
274 /* BUT we usually use UN for C macro to FORTRAN routines, so use LN here,*/
275 /* because VAX/VMS doesn't do recursive macros. */
276 #define orig_fcallsc(UN,LN) UN
277 #else /* HP-UX without +ppu or IBMR2 without -qextname. NOT reccomended. */
278 #define CFC_(UN,LN) LN /* Lowercase FORTRAN symbols. */
279 #define orig_fcallsc(UN,LN) CFC_(UN,LN)
280 #endif /* vmsFortran */
281 #endif /* CRAYFortran PowerStationFortran */
282 #endif /* ....Fortran */
283
284 #define fcallsc(UN,LN) orig_fcallsc(UN,LN)
285 #define preface_fcallsc(P,p,UN,LN) CFC_(_(P,UN),_(p,LN))
286 #define append_fcallsc(P,p,UN,LN) CFC_(_(UN,P),_(LN,p))
287
288 #define C_FUNCTION(UN,LN) fcallsc(UN,LN)
289 #define FORTRAN_FUNCTION(UN,LN) CFC_(UN,LN)
290
291 #ifndef COMMON_BLOCK
292 #ifndef CONVEXFortran
293 #ifndef CLIPPERFortran
294 #if !(defined(AbsoftUNIXFortran)||defined(AbsoftProFortran))
295 #define COMMON_BLOCK(UN,LN) CFC_(UN,LN)
296 #else
297 #define COMMON_BLOCK(UN,LN) _(_C,LN)
298 #endif /* AbsoftUNIXFortran or AbsoftProFortran */
299 #else
300 #define COMMON_BLOCK(UN,LN) _(LN,__)
301 #endif /* CLIPPERFortran */
302 #else
303 #define COMMON_BLOCK(UN,LN) _3(_,LN,_)
304 #endif /* CONVEXFortran */
305 #endif /* COMMON_BLOCK */
306
307 #ifndef DOUBLE_PRECISION
308 #if defined(CRAYFortran) && !defined(_CRAYT3E)
309 #define DOUBLE_PRECISION long double
310 #else
311 #define DOUBLE_PRECISION double
312 #endif
313 #endif
314
315 #ifndef FORTRAN_REAL
316 #if defined(CRAYFortran) && defined(_CRAYT3E)
317 #define FORTRAN_REAL double
318 #else
319 #define FORTRAN_REAL float
320 #endif
321 #endif
322
323 #ifdef CRAYFortran
324 #ifdef _CRAY
325 #include <fortran.h>
326 #else
327 #include "fortran.h" /* i.e. if crosscompiling assume user has file. */
328 #endif
329 #define FLOATVVVVVVV_cfPP (FORTRAN_REAL *) /* Used for C calls FORTRAN. */
330 /* CRAY's double==float but CRAY says pointers to doubles and floats are diff.*/
331 #define VOIDP (void *) /* When FORTRAN calls C, we don't know if C routine
332 arg.'s have been declared float *, or double *. */
333 #else
334 #define FLOATVVVVVVV_cfPP
335 #define VOIDP
336 #endif
337
338 #ifdef vmsFortran
339 #if defined(vms) || defined(__vms)
340 #include <descrip.h>
341 #else
342 #include "descrip.h" /* i.e. if crosscompiling assume user has file. */
343 #endif
344 #endif
345
346 #ifdef sunFortran
347 #if defined(sun) || defined(__sun)
348 #include <math.h> /* Sun's FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT. */
349 #else
350 #include "math.h" /* i.e. if crosscompiling assume user has file. */
351 #endif
352 /* At least starting with the default C compiler SC3.0.1 of SunOS 5.3,
353 * FLOATFUNCTIONTYPE, ASSIGNFLOAT, RETURNFLOAT are not required and not in
354 * <math.h>, since sun C no longer promotes C float return values to doubles.
355 * Therefore, only use them if defined.
356 * Even if gcc is being used, assume that it exhibits the Sun C compiler
357 * behavior in order to be able to use *.o from the Sun C compiler.
358 * i.e. If FLOATFUNCTIONTYPE, etc. are in math.h, they required by gcc.
359 */
360 #endif
361
362 #ifndef apolloFortran
363 #define COMMON_BLOCK_DEF(DEFINITION, NAME) extern DEFINITION NAME
364 #define CF_NULL_PROTO
365 #else /* HP doesn't understand #elif. */
366 /* Without ANSI prototyping, Apollo promotes float functions to double. */
367 /* Note that VAX/VMS, IBM, Mips choke on 'type function(...);' prototypes. */
368 #define CF_NULL_PROTO ...
369 #ifndef __CF__APOLLO67
370 #define COMMON_BLOCK_DEF(DEFINITION, NAME) \
371 DEFINITION NAME __attribute((__section(NAME)))
372 #else
373 #define COMMON_BLOCK_DEF(DEFINITION, NAME) \
374 DEFINITION NAME #attribute[section(NAME)]
375 #endif
376 #endif
377
378 #ifdef __cplusplus
379 #undef CF_NULL_PROTO
380 #define CF_NULL_PROTO ...
381 #endif
382
383
384 #ifndef USE_NEW_DELETE
385 #ifdef __cplusplus
386 #define USE_NEW_DELETE 1
387 #else
388 #define USE_NEW_DELETE 0
389 #endif
390 #endif
391 #if USE_NEW_DELETE
392 #define _cf_malloc(N) new char[N]
393 #define _cf_free(P) delete[] P
394 #else
395 #define _cf_malloc(N) (char *)malloc(N)
396 #define _cf_free(P) free(P)
397 #endif
398
399 #ifdef mipsFortran
400 #define CF_DECLARE_GETARG int f77argc; char **f77argv
401 #define CF_SET_GETARG(ARGC,ARGV) f77argc = ARGC; f77argv = ARGV
402 #else
403 #define CF_DECLARE_GETARG
404 #define CF_SET_GETARG(ARGC,ARGV)
405 #endif
406
407 #ifdef OLD_VAXC /* Allow %CC-I-PARAMNOTUSED. */
408 #pragma standard
409 #endif
410
411 #define AcfCOMMA ,
412 #define AcfCOLON ;
413
414 /*-------------------------------------------------------------------------*/
415
416 /* UTILITIES USED WITHIN CFORTRAN.H */
417
418 #define _cfMIN(A,B) (A<B?A:B)
419
420 /* 970211 - XIX.145:
421 firstindexlength - better name is all_but_last_index_lengths
422 secondindexlength - better name is last_index_length
423 */
424 #define firstindexlength(A) (sizeof(A[0])==1 ? 1 : (sizeof(A) / sizeof(A[0])) )
425 #define secondindexlength(A) (sizeof(A[0])==1 ? sizeof(A) : sizeof(A[0]) )
426
427 /* Behavior of FORTRAN LOGICAL. All machines' LOGICAL is same size as C's int.
428 Conversion is automatic except for arrays which require F2CLOGICALV/C2FLOGICALV.
429 f2c, MIPS f77 [DECstation, SGI], VAX Ultrix f77,
430 HP-UX f77 : as in C.
431 VAX/VMS FORTRAN, VAX Ultrix fort,
432 Absoft Unix Fortran, IBM RS/6000 xlf : LS Bit = 0/1 = TRUE/FALSE.
433 Apollo : neg. = TRUE, else FALSE.
434 [Apollo accepts -1 as TRUE for function values, but NOT all other neg. values.]
435 [DECFortran for Ultrix RISC is also called f77 but is the same as VAX/VMS.]
436 [MIPS f77 treats .eqv./.neqv. as .eq./.ne. and hence requires LOGICAL_STRICT.]*/
437
438 #if defined(NAGf90Fortran) || defined(f2cFortran) || defined(mipsFortran) || defined(PowerStationFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran) || defined(SXFortran)
439 /* SX/PowerStationFortran have 0 and 1 defined, others are neither T nor F. */
440 /* hpuxFortran800 has 0 and 0x01000000 defined. Others are unknown. */
441 #define LOGICAL_STRICT /* Other Fortran have .eqv./.neqv. == .eq./.ne. */
442 #endif
443
444 #define C2FLOGICALV(A,I) \
445 do {int __i; for(__i=0;__i<I;__i++) A[__i]=C2FLOGICAL(A[__i]); } while (0)
446 #define F2CLOGICALV(A,I) \
447 do {int __i; for(__i=0;__i<I;__i++) A[__i]=F2CLOGICAL(A[__i]); } while (0)
448
449 #if defined(apolloFortran)
450 #define C2FLOGICAL(L) ((L)?-1:(L)&~((unsigned)1<<sizeof(int)*8-1))
451 #define F2CLOGICAL(L) ((L)<0?(L):0)
452 #else
453 #if defined(CRAYFortran)
454 #define C2FLOGICAL(L) _btol(L)
455 #define F2CLOGICAL(L) _ltob(&(L)) /* Strangely _ltob() expects a pointer. */
456 #else
457 #if defined(IBMR2Fortran) || defined(vmsFortran) || defined(DECFortran) || defined(AbsoftUNIXFortran)
458 /* How come no AbsoftProFortran ? */
459 #define C2FLOGICAL(L) ((L)?(L)|1:(L)&~(int)1)
460 #define F2CLOGICAL(L) ((L)&1?(L):0)
461 #else
462 #if defined(CONVEXFortran)
463 #define C2FLOGICAL(L) ((L) ? ~0 : 0 )
464 #define F2CLOGICAL(L) (L)
465 #else /* others evaluate LOGICALs as for C. */
466 #define C2FLOGICAL(L) (L)
467 #define F2CLOGICAL(L) (L)
468 #ifndef LOGICAL_STRICT
469 #undef C2FLOGICALV
470 #undef F2CLOGICALV
471 #define C2FLOGICALV(A,I)
472 #define F2CLOGICALV(A,I)
473 #endif /* LOGICAL_STRICT */
474 #endif /* CONVEXFortran || All Others */
475 #endif /* IBMR2Fortran vmsFortran DECFortran AbsoftUNIXFortran */
476 #endif /* CRAYFortran */
477 #endif /* apolloFortran */
478
479 /* 970514 - In addition to CRAY, there may be other machines
480 for which LOGICAL_STRICT makes no sense. */
481 #if defined(LOGICAL_STRICT) && !defined(CRAYFortran)
482 /* Force C2FLOGICAL to generate only the values for either .TRUE. or .FALSE.
483 SX/PowerStationFortran only have 0 and 1 defined.
484 Elsewhere, only needed if you want to do:
485 logical lvariable
486 if (lvariable .eq. .true.) then ! (1)
487 instead of
488 if (lvariable .eqv. .true.) then ! (2)
489 - (1) may not even be FORTRAN/77 and that Apollo's f77 and IBM's xlf
490 refuse to compile (1), so you are probably well advised to stay away from
491 (1) and from LOGICAL_STRICT.
492 - You pay a (slight) performance penalty for using LOGICAL_STRICT. */
493 #undef C2FLOGICAL
494 #ifdef hpuxFortran800
495 #define C2FLOGICAL(L) ((L)?0x01000000:0)
496 #else
497 #if defined(apolloFortran) || defined(vmsFortran) || defined(DECFortran)
498 #define C2FLOGICAL(L) ((L)?-1:0) /* These machines use -1/0 for .true./.false.*/
499 #else
500 #define C2FLOGICAL(L) ((L)? 1:0) /* All others use +1/0 for .true./.false.*/
501 #endif
502 #endif
503 #endif /* LOGICAL_STRICT */
504
505 /* Convert a vector of C strings into FORTRAN strings. */
506 #ifndef __CF__KnR
507 static char *c2fstrv(char* cstr, char *fstr, int elem_len, int sizeofcstr)
508 #else
509 static char *c2fstrv( cstr, fstr, elem_len, sizeofcstr)
510 char* cstr; char *fstr; int elem_len; int sizeofcstr;
511 #endif
512 { int i,j;
513 /* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
514 Useful size of string must be the same in both languages. */
515 for (i=0; i<sizeofcstr/elem_len; i++) {
516 for (j=1; j<elem_len && *cstr; j++) *fstr++ = *cstr++;
517 cstr += 1+elem_len-j;
518 for (; j<elem_len; j++) *fstr++ = ' ';
519 } /* 95109 - Seems to be returning the original fstr. */
520 return fstr-sizeofcstr+sizeofcstr/elem_len; }
521
522 /* Convert a vector of FORTRAN strings into C strings. */
523 #ifndef __CF__KnR
524 static char *f2cstrv(char *fstr, char* cstr, int elem_len, int sizeofcstr)
525 #else
526 static char *f2cstrv( fstr, cstr, elem_len, sizeofcstr)
527 char *fstr; char* cstr; int elem_len; int sizeofcstr;
528 #endif
529 { int i,j;
530 /* elem_len includes \0 for C strings. Fortran strings don't have term. \0.
531 Useful size of string must be the same in both languages. */
532 cstr += sizeofcstr;
533 fstr += sizeofcstr - sizeofcstr/elem_len;
534 for (i=0; i<sizeofcstr/elem_len; i++) {
535 *--cstr = '\0';
536 for (j=1; j<elem_len; j++) *--cstr = *--fstr;
537 } return cstr; }
538
539 /* kill the trailing char t's in string s. */
540 #ifndef __CF__KnR
541 static char *kill_trailing(char *s, char t)
542 #else
543 static char *kill_trailing( s, t) char *s; char t;
544 #endif
545 {char *e;
546 e = s + strlen(s);
547 if (e>s) { /* Need this to handle NULL string.*/
548 while (e>s && *--e==t) {;} /* Don't follow t's past beginning. */
549 e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
550 } return s; }
551
552 /* kill_trailingn(s,t,e) will kill the trailing t's in string s. e normally
553 points to the terminating '\0' of s, but may actually point to anywhere in s.
554 s's new '\0' will be placed at e or earlier in order to remove any trailing t's.
555 If e<s string s is left unchanged. */
556 #ifndef __CF__KnR
557 static char *kill_trailingn(char *s, char t, char *e)
558 #else
559 static char *kill_trailingn( s, t, e) char *s; char t; char *e;
560 #endif
561 {
562 if (e==s) *e = '\0'; /* Kill the string makes sense here.*/
563 else if (e>s) { /* Watch out for neg. length string.*/
564 while (e>s && *--e==t){;} /* Don't follow t's past beginning. */
565 e[*e==t?0:1] = '\0'; /* Handle s[0]=t correctly. */
566 } return s; }
567
568 /* Note the following assumes that any element which has t's to be chopped off,
569 does indeed fill the entire element. */
570 #ifndef __CF__KnR
571 static char *vkill_trailing(char* cstr, int elem_len, int sizeofcstr, char t)
572 #else
573 static char *vkill_trailing( cstr, elem_len, sizeofcstr, t)
574 char* cstr; int elem_len; int sizeofcstr; char t;
575 #endif
576 { int i;
577 for (i=0; i<sizeofcstr/elem_len; i++) /* elem_len includes \0 for C strings. */
578 kill_trailingn(cstr+elem_len*i,t,cstr+elem_len*(i+1)-1);
579 return cstr; }
580
581 #ifdef vmsFortran
582 typedef struct dsc$descriptor_s fstring;
583 #define DSC$DESCRIPTOR_A(DIMCT) \
584 struct { \
585 unsigned short dsc$w_length; unsigned char dsc$b_dtype; \
586 unsigned char dsc$b_class; char *dsc$a_pointer; \
587 char dsc$b_scale; unsigned char dsc$b_digits; \
588 struct { \
589 unsigned : 3; unsigned dsc$v_fl_binscale : 1; \
590 unsigned dsc$v_fl_redim : 1; unsigned dsc$v_fl_column : 1; \
591 unsigned dsc$v_fl_coeff : 1; unsigned dsc$v_fl_bounds : 1; \
592 } dsc$b_aflags; \
593 unsigned char dsc$b_dimct; unsigned long dsc$l_arsize; \
594 char *dsc$a_a0; long dsc$l_m [DIMCT]; \
595 struct { \
596 long dsc$l_l; long dsc$l_u; \
597 } dsc$bounds [DIMCT]; \
598 }
599 typedef DSC$DESCRIPTOR_A(1) fstringvector;
600 /*typedef DSC$DESCRIPTOR_A(2) fstringarrarr;
601 typedef DSC$DESCRIPTOR_A(3) fstringarrarrarr;*/
602 #define initfstr(F,C,ELEMNO,ELEMLEN) \
603 ( (F).dsc$l_arsize= ( (F).dsc$w_length =(ELEMLEN) ) \
604 *( (F).dsc$l_m[0]=(F).dsc$bounds[0].dsc$l_u=(ELEMNO) ), \
605 (F).dsc$a_a0 = ( (F).dsc$a_pointer=(C) ) - (F).dsc$w_length ,(F))
606
607 #endif /* PDW: 2/10/98 (CFITSIO) -- Let VMS see NUM_ELEMS definitions */
608 #define _NUM_ELEMS -1
609 #define _NUM_ELEM_ARG -2
610 #define NUM_ELEMS(A) A,_NUM_ELEMS
611 #define NUM_ELEM_ARG(B) *_2(A,B),_NUM_ELEM_ARG
612 #define TERM_CHARS(A,B) A,B
613 #ifndef __CF__KnR
614 static int num_elem(char *strv, unsigned elem_len, int term_char, int num_term)
615 #else
616 static int num_elem( strv, elem_len, term_char, num_term)
617 char *strv; unsigned elem_len; int term_char; int num_term;
618 #endif
619 /* elem_len is the number of characters in each element of strv, the FORTRAN
620 vector of strings. The last element of the vector must begin with at least
621 num_term term_char characters, so that this routine can determine how
622 many elements are in the vector. */
623 {
624 unsigned num,i;
625 if (num_term == _NUM_ELEMS || num_term == _NUM_ELEM_ARG)
626 return term_char;
627 if (num_term <=0) num_term = (int)elem_len;
628 for (num=0; ; num++) {
629 for (i=0; i<(unsigned)num_term && *strv==term_char; i++,strv++){;}
630 if (i==(unsigned)num_term) break;
631 else strv += elem_len-i;
632 }
633 if (0) { /* to prevent not used warnings in gcc (added by ROOT) */
634 c2fstrv(0, 0, 0, 0); f2cstrv(0, 0, 0, 0); kill_trailing(0, 0);
635 vkill_trailing(0, 0, 0, 0); num_elem(0, 0, 0, 0);
636 }
637 return (int)num;
638 }
639 /* #endif removed 2/10/98 (CFITSIO) */
640
641 /*-------------------------------------------------------------------------*/
642
643 /* UTILITIES FOR C TO USE STRINGS IN FORTRAN COMMON BLOCKS */
644
645 /* C string TO Fortran Common Block STRing. */
646 /* DIM is the number of DIMensions of the array in terms of strings, not
647 characters. e.g. char a[12] has DIM = 0, char a[12][4] has DIM = 1, etc. */
648 #define C2FCBSTR(CSTR,FSTR,DIM) \
649 c2fstrv((char *)CSTR, (char *)FSTR, sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
650 sizeof(FSTR)+cfelementsof(FSTR,DIM))
651
652 /* Fortran Common Block string TO C STRing. */
653 #define FCB2CSTR(FSTR,CSTR,DIM) \
654 vkill_trailing(f2cstrv((char *)FSTR, (char *)CSTR, \
655 sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
656 sizeof(FSTR)+cfelementsof(FSTR,DIM)), \
657 sizeof(FSTR)/cfelementsof(FSTR,DIM)+1, \
658 sizeof(FSTR)+cfelementsof(FSTR,DIM), ' ')
659
660 #define cfDEREFERENCE0
661 #define cfDEREFERENCE1 *
662 #define cfDEREFERENCE2 **
663 #define cfDEREFERENCE3 ***
664 #define cfDEREFERENCE4 ****
665 #define cfDEREFERENCE5 *****
666 #define cfelementsof(A,D) (sizeof(A)/sizeof(_(cfDEREFERENCE,D)(A)))
667
668 /*-------------------------------------------------------------------------*/
669
670 /* UTILITIES FOR C TO CALL FORTRAN SUBROUTINES */
671
672 /* Define lookup tables for how to handle the various types of variables. */
673
674 #ifdef OLD_VAXC /* Prevent %CC-I-PARAMNOTUSED. */
675 #pragma nostandard
676 #endif
677
678 #define ZTRINGV_NUM(I) I
679 #define ZTRINGV_ARGFP(I) (*(_2(A,I))) /* Undocumented. For PINT, etc. */
680 #define ZTRINGV_ARGF(I) _2(A,I)
681 #ifdef CFSUBASFUN
682 #define ZTRINGV_ARGS(I) ZTRINGV_ARGF(I)
683 #else
684 #define ZTRINGV_ARGS(I) _2(B,I)
685 #endif
686
687 #define PBYTE_cfVP(A,B) PINT_cfVP(A,B)
688 #define PDOUBLE_cfVP(A,B)
689 #define PFLOAT_cfVP(A,B)
690 #ifdef ZTRINGV_ARGS_allows_Pvariables
691 /* This allows Pvariables for ARGS. ARGF machinery is above ARGFP.
692 * B is not needed because the variable may be changed by the Fortran routine,
693 * but because B is the only way to access an arbitrary macro argument. */
694 #define PINT_cfVP(A,B) int B = (int)A; /* For ZSTRINGV_ARGS */
695 #else
696 #define PINT_cfVP(A,B)
697 #endif
698 #define PLOGICAL_cfVP(A,B) int *B; /* Returning LOGICAL in FUNn and SUBn */
699 #define PLONG_cfVP(A,B) PINT_cfVP(A,B)
700 #define PSHORT_cfVP(A,B) PINT_cfVP(A,B)
701
702 #define VCF_INT_S(T,A,B) _(T,VVVVVVV_cfTYPE) B = A;
703 #define VCF_INT_F(T,A,B) _(T,_cfVCF)(A,B)
704 /* _cfVCF table is directly mapped to _cfCCC table. */
705 #define BYTE_cfVCF(A,B)
706 #define DOUBLE_cfVCF(A,B)
707 #if !defined(__CF__KnR)
708 #define FLOAT_cfVCF(A,B)
709 #else
710 #define FLOAT_cfVCF(A,B) FORTRAN_REAL B = A;
711 #endif
712 #define INT_cfVCF(A,B)
713 #define LOGICAL_cfVCF(A,B)
714 #define LONG_cfVCF(A,B)
715 #define SHORT_cfVCF(A,B)
716
717 /* 980416
718 Cast (void (*)(CF_NULL_PROTO)) causes SunOS CC 4.2 occasionally to barf,
719 while the following equivalent typedef is fine.
720 For consistency use the typedef on all machines.
721 */
722 typedef void (*cfCAST_FUNCTION)(CF_NULL_PROTO);
723
724 #define VCF(TN,I) _Icf4(4,V,TN,_(A,I),_(B,I),F)
725 #define VVCF(TN,AI,BI) _Icf4(4,V,TN,AI,BI,S)
726 #define INT_cfV(T,A,B,F) _(VCF_INT_,F)(T,A,B)
727 #define INTV_cfV(T,A,B,F)
728 #define INTVV_cfV(T,A,B,F)
729 #define INTVVV_cfV(T,A,B,F)
730 #define INTVVVV_cfV(T,A,B,F)
731 #define INTVVVVV_cfV(T,A,B,F)
732 #define INTVVVVVV_cfV(T,A,B,F)
733 #define INTVVVVVVV_cfV(T,A,B,F)
734 #define PINT_cfV( T,A,B,F) _(T,_cfVP)(A,B)
735 #define PVOID_cfV( T,A,B,F)
736 #if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
737 #define ROUTINE_cfV(T,A,B,F) void (*B)(CF_NULL_PROTO) = (cfCAST_FUNCTION)A;
738 #else
739 #define ROUTINE_cfV(T,A,B,F)
740 #endif
741 #define SIMPLE_cfV(T,A,B,F)
742 #ifdef vmsFortran
743 #define STRING_cfV(T,A,B,F) static struct {fstring f; unsigned clen;} B = \
744 {{0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL},0};
745 #define PSTRING_cfV(T,A,B,F) static fstring B={0,DSC$K_DTYPE_T,DSC$K_CLASS_S,NULL};
746 #define STRINGV_cfV(T,A,B,F) static fstringvector B = \
747 {sizeof(A),DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
748 #define PSTRINGV_cfV(T,A,B,F) static fstringvector B = \
749 {0,DSC$K_DTYPE_T,DSC$K_CLASS_A,NULL,0,0,{0,0,1,1,1},1,0,NULL,0,{1,0}};
750 #else
751 #define STRING_cfV(T,A,B,F) struct {unsigned int clen, flen; char *nombre;} B;
752 #define STRINGV_cfV(T,A,B,F) struct {char *s, *fs; unsigned flen; char *nombre;} B;
753 #define PSTRING_cfV(T,A,B,F) int B;
754 #define PSTRINGV_cfV(T,A,B,F) struct{char *fs; unsigned int sizeofA,flen;}B;
755 #endif
756 #define ZTRINGV_cfV(T,A,B,F) STRINGV_cfV(T,A,B,F)
757 #define PZTRINGV_cfV(T,A,B,F) PSTRINGV_cfV(T,A,B,F)
758
759 /* Note that the actions of the A table were performed inside the AA table.
760 VAX Ultrix vcc, and HP-UX cc, didn't evaluate arguments to functions left to
761 right, so we had to split the original table into the current robust two. */
762 #define ACF(NAME,TN,AI,I) _(TN,_cfSTR)(4,A,NAME,I,AI,_(B,I),0)
763 #define DEFAULT_cfA(M,I,A,B)
764 #define LOGICAL_cfA(M,I,A,B) B=C2FLOGICAL(B);
765 #define PLOGICAL_cfA(M,I,A,B) A=C2FLOGICAL(A);
766 #define STRING_cfA(M,I,A,B) STRING_cfC(M,I,A,B,sizeof(A))
767 #define PSTRING_cfA(M,I,A,B) PSTRING_cfC(M,I,A,B,sizeof(A))
768 #ifdef vmsFortran
769 #define AATRINGV_cfA( A,B, sA,filA,silA) \
770 initfstr(B,_cf_malloc((sA)-(filA)),(filA),(silA)-1), \
771 c2fstrv(A,B.dsc$a_pointer,(silA),(sA));
772 #define APATRINGV_cfA( A,B, sA,filA,silA) \
773 initfstr(B,A,(filA),(silA)-1),c2fstrv(A,A,(silA),(sA));
774 #else
775 #define AATRINGV_cfA( A,B, sA,filA,silA) \
776 (B.s=_cf_malloc((sA)-(filA)),B.fs=c2fstrv(A,B.s,(B.flen=(silA)-1)+1,(sA)));
777 #define APATRINGV_cfA( A,B, sA,filA,silA) \
778 B.fs=c2fstrv(A,A,(B.flen=(silA)-1)+1,B.sizeofA=(sA));
779 #endif
780 #define STRINGV_cfA(M,I,A,B) \
781 AATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
782 #define PSTRINGV_cfA(M,I,A,B) \
783 APATRINGV_cfA((char *)A,B,sizeof(A),firstindexlength(A),secondindexlength(A))
784 #define ZTRINGV_cfA(M,I,A,B) AATRINGV_cfA( (char *)A,B, \
785 (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
786 (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
787 #define PZTRINGV_cfA(M,I,A,B) APATRINGV_cfA( (char *)A,B, \
788 (_3(M,_ELEMS_,I))*(( _3(M,_ELEMLEN_,I))+1), \
789 (_3(M,_ELEMS_,I)),(_3(M,_ELEMLEN_,I))+1)
790
791 #define PBYTE_cfAAP(A,B) &A
792 #define PDOUBLE_cfAAP(A,B) &A
793 #define PFLOAT_cfAAP(A,B) FLOATVVVVVVV_cfPP &A
794 #define PINT_cfAAP(A,B) &A
795 #define PLOGICAL_cfAAP(A,B) B= &A /* B used to keep a common W table. */
796 #define PLONG_cfAAP(A,B) &A
797 #define PSHORT_cfAAP(A,B) &A
798
799 #define AACF(TN,AI,I,C) _SEP_(TN,C,cfCOMMA) _Icf(3,AA,TN,AI,_(B,I))
800 #define INT_cfAA(T,A,B) &B
801 #define INTV_cfAA(T,A,B) _(T,VVVVVV_cfPP) A
802 #define INTVV_cfAA(T,A,B) _(T,VVVVV_cfPP) A[0]
803 #define INTVVV_cfAA(T,A,B) _(T,VVVV_cfPP) A[0][0]
804 #define INTVVVV_cfAA(T,A,B) _(T,VVV_cfPP) A[0][0][0]
805 #define INTVVVVV_cfAA(T,A,B) _(T,VV_cfPP) A[0][0][0][0]
806 #define INTVVVVVV_cfAA(T,A,B) _(T,V_cfPP) A[0][0][0][0][0]
807 #define INTVVVVVVV_cfAA(T,A,B) _(T,_cfPP) A[0][0][0][0][0][0]
808 #define PINT_cfAA(T,A,B) _(T,_cfAAP)(A,B)
809 #define PVOID_cfAA(T,A,B) (void *) A
810 #if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
811 #define ROUTINE_cfAA(T,A,B) &B
812 #else
813 #define ROUTINE_cfAA(T,A,B) (cfCAST_FUNCTION)A
814 #endif
815 #define STRING_cfAA(T,A,B) STRING_cfCC(T,A,B)
816 #define PSTRING_cfAA(T,A,B) PSTRING_cfCC(T,A,B)
817 #ifdef vmsFortran
818 #define STRINGV_cfAA(T,A,B) &B
819 #else
820 #ifdef CRAYFortran
821 #define STRINGV_cfAA(T,A,B) _cptofcd(B.fs,B.flen)
822 #else
823 #define STRINGV_cfAA(T,A,B) B.fs
824 #endif
825 #endif
826 #define PSTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
827 #define ZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
828 #define PZTRINGV_cfAA(T,A,B) STRINGV_cfAA(T,A,B)
829
830 #if defined(vmsFortran) || defined(CRAYFortran)
831 #define JCF(TN,I)
832 #define KCF(TN,I)
833 #else
834 #define JCF(TN,I) _(TN,_cfSTR)(1,J,_(B,I), 0,0,0,0)
835 #if defined(AbsoftUNIXFortran)
836 #define DEFAULT_cfJ(B) ,0
837 #else
838 #define DEFAULT_cfJ(B)
839 #endif
840 #define LOGICAL_cfJ(B) DEFAULT_cfJ(B)
841 #define PLOGICAL_cfJ(B) DEFAULT_cfJ(B)
842 #define STRING_cfJ(B) ,B.flen
843 #define PSTRING_cfJ(B) ,B
844 #define STRINGV_cfJ(B) STRING_cfJ(B)
845 #define PSTRINGV_cfJ(B) STRING_cfJ(B)
846 #define ZTRINGV_cfJ(B) STRING_cfJ(B)
847 #define PZTRINGV_cfJ(B) STRING_cfJ(B)
848
849 /* KCF is identical to DCF, except that KCF ZTRING is not empty. */
850 #define KCF(TN,I) _(TN,_cfSTR)(1,KK,_(B,I), 0,0,0,0)
851 #if defined(AbsoftUNIXFortran)
852 #define DEFAULT_cfKK(B) , unsigned B
853 #else
854 #define DEFAULT_cfKK(B)
855 #endif
856 #define LOGICAL_cfKK(B) DEFAULT_cfKK(B)
857 #define PLOGICAL_cfKK(B) DEFAULT_cfKK(B)
858 #define STRING_cfKK(B) , unsigned B
859 #define PSTRING_cfKK(B) STRING_cfKK(B)
860 #define STRINGV_cfKK(B) STRING_cfKK(B)
861 #define PSTRINGV_cfKK(B) STRING_cfKK(B)
862 #define ZTRINGV_cfKK(B) STRING_cfKK(B)
863 #define PZTRINGV_cfKK(B) STRING_cfKK(B)
864 #endif
865
866 #define WCF(TN,AN,I) _(TN,_cfSTR)(2,W,AN,_(B,I), 0,0,0)
867 #define DEFAULT_cfW(A,B)
868 #define LOGICAL_cfW(A,B)
869 #define PLOGICAL_cfW(A,B) *B=F2CLOGICAL(*B);
870 #define STRING_cfW(A,B) (B.nombre=A,B.nombre[B.clen]!='\0'?B.nombre[B.clen]='\0':0); /* A?="constnt"*/
871 #define PSTRING_cfW(A,B) kill_trailing(A,' ');
872 #ifdef vmsFortran
873 #define STRINGV_cfW(A,B) _cf_free(B.dsc$a_pointer);
874 #define PSTRINGV_cfW(A,B) \
875 vkill_trailing(f2cstrv((char*)A, (char*)A, \
876 B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0]), \
877 B.dsc$w_length+1, B.dsc$l_arsize+B.dsc$l_m[0], ' ');
878 #else
879 #define STRINGV_cfW(A,B) _cf_free(B.s);
880 #define PSTRINGV_cfW(A,B) vkill_trailing( \
881 f2cstrv((char*)A,(char*)A,B.flen+1,B.sizeofA), B.flen+1,B.sizeofA,' ');
882 #endif
883 #define ZTRINGV_cfW(A,B) STRINGV_cfW(A,B)
884 #define PZTRINGV_cfW(A,B) PSTRINGV_cfW(A,B)
885
886 #define NCF(TN,I,C) _SEP_(TN,C,cfCOMMA) _Icf(2,N,TN,_(A,I),0)
887 #define NNCF(TN,I,C) UUCF(TN,I,C)
888 #define NNNCF(TN,I,C) _SEP_(TN,C,cfCOLON) _Icf(2,N,TN,_(A,I),0)
889 #define INT_cfN(T,A) _(T,VVVVVVV_cfTYPE) * A
890 #define INTV_cfN(T,A) _(T,VVVVVV_cfTYPE) * A
891 #define INTVV_cfN(T,A) _(T,VVVVV_cfTYPE) * A
892 #define INTVVV_cfN(T,A) _(T,VVVV_cfTYPE) * A
893 #define INTVVVV_cfN(T,A) _(T,VVV_cfTYPE) * A
894 #define INTVVVVV_cfN(T,A) _(T,VV_cfTYPE) * A
895 #define INTVVVVVV_cfN(T,A) _(T,V_cfTYPE) * A
896 #define INTVVVVVVV_cfN(T,A) _(T,_cfTYPE) * A
897 #define PINT_cfN(T,A) _(T,_cfTYPE) * A
898 #define PVOID_cfN(T,A) void * A
899 #if defined(apolloFortran) || defined(hpuxFortran800) || defined(AbsoftUNIXFortran)
900 #define ROUTINE_cfN(T,A) void (**A)(CF_NULL_PROTO)
901 #else
902 #define ROUTINE_cfN(T,A) void ( *A)(CF_NULL_PROTO)
903 #endif
904 #ifdef vmsFortran
905 #define STRING_cfN(T,A) fstring * A
906 #define STRINGV_cfN(T,A) fstringvector * A
907 #else
908 #ifdef CRAYFortran
909 #define STRING_cfN(T,A) _fcd A
910 #define STRINGV_cfN(T,A) _fcd A
911 #else
912 #define STRING_cfN(T,A) char * A
913 #define STRINGV_cfN(T,A) char * A
914 #endif
915 #endif
916 #define PSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
917 #define PNSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
918 #define PPSTRING_cfN(T,A) STRING_cfN(T,A) /* CRAY insists on arg.'s here. */
919 #define PSTRINGV_cfN(T,A) STRINGV_cfN(T,A)
920 #define ZTRINGV_cfN(T,A) STRINGV_cfN(T,A)
921 #define PZTRINGV_cfN(T,A) PSTRINGV_cfN(T,A)
922
923
924 /* Apollo 6.7, CRAY, old Sun, VAX/Ultrix vcc/cc and new ultrix
925 can't hack more than 31 arg's.
926 e.g. ultrix >= 4.3 gives message:
927 zow35> cc -c -DDECFortran cfortest.c
928 cfe: Fatal: Out of memory: cfortest.c
929 zow35>
930 Old __hpux had the problem, but new 'HP-UX A.09.03 A 9000/735' is fine
931 if using -Aa, otherwise we have a problem.
932 */
933 #ifndef MAX_PREPRO_ARGS
934 #if !defined(__GNUC__) && (defined(VAXUltrix) || defined(__CF__APOLLO67) || (defined(sun)&&!defined(__sun)) || defined(_CRAY) || defined(__ultrix__) || (defined(__hpux)&&defined(__CF__KnR)))
935 #define MAX_PREPRO_ARGS 31
936 #else
937 #define MAX_PREPRO_ARGS 99
938 #endif
939 #endif
940
941 #if defined(AbsoftUNIXFortran) || defined(AbsoftProFortran)
942 /* In addition to explicit Absoft stuff, only Absoft requires:
943 - DEFAULT coming from _cfSTR.
944 DEFAULT could have been called e.g. INT, but keep it for clarity.
945 - M term in CFARGT14 and CFARGT14FS.
946 */
947 #define ABSOFT_cf1(T0) _(T0,_cfSTR)(0,ABSOFT1,0,0,0,0,0)
948 #define ABSOFT_cf2(T0) _(T0,_cfSTR)(0,ABSOFT2,0,0,0,0,0)
949 #define ABSOFT_cf3(T0) _(T0,_cfSTR)(0,ABSOFT3,0,0,0,0,0)
950 #define DEFAULT_cfABSOFT1
951 #define LOGICAL_cfABSOFT1
952 #define STRING_cfABSOFT1 ,MAX_LEN_FORTRAN_FUNCTION_STRING
953 #define DEFAULT_cfABSOFT2
954 #define LOGICAL_cfABSOFT2
955 #define STRING_cfABSOFT2 ,unsigned D0
956 #define DEFAULT_cfABSOFT3
957 #define LOGICAL_cfABSOFT3
958 #define STRING_cfABSOFT3 ,D0
959 #else
960 #define ABSOFT_cf1(T0)
961 #define ABSOFT_cf2(T0)
962 #define ABSOFT_cf3(T0)
963 #endif
964
965 /* _Z introduced to cicumvent IBM and HP silly preprocessor warning.
966 e.g. "Macro CFARGT14 invoked with a null argument."
967 */
968 #define _Z
969
970 #define CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
971 S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
972 S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14)
973 #define CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
974 S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
975 S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
976 S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
977 S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
978
979 #define CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
980 F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
981 F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
982 M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
983 #define CFARGT27FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
984 F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
985 F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
986 F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
987 F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
988 M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
989
990 #if !(defined(PowerStationFortran)||defined(hpuxFortran800))
991 /* Old CFARGT14 -> CFARGT14FS as seen below, for Absoft cross-compile yields:
992 SunOS> cc -c -Xa -DAbsoftUNIXFortran c.c
993 "c.c", line 406: warning: argument mismatch
994 Haven't checked if this is ANSI C or a SunOS bug. SunOS -Xs works ok.
995 Behavior is most clearly seen in example:
996 #define A 1 , 2
997 #define C(X,Y,Z) x=X. y=Y. z=Z.
998 #define D(X,Y,Z) C(X,Y,Z)
999 D(x,A,z)
1000 Output from preprocessor is: x = x . y = 1 . z = 2 .
1001 #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
1002 CFARGT14FS(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
1003 */
1004 #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
1005 F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
1006 F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
1007 M CFARGT14S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
1008 #define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
1009 F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
1010 F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
1011 F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) F(TL,21,1) \
1012 F(TM,22,1) F(TN,23,1) F(TO,24,1) F(TP,25,1) F(TQ,26,1) F(TR,27,1) \
1013 M CFARGT27S(S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR)
1014
1015 #define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
1016 F(T1,1,0) F(T2,2,1) F(T3,3,1) F(T4,4,1) F(T5,5,1) F(T6,6,1) F(T7,7,1) \
1017 F(T8,8,1) F(T9,9,1) F(TA,10,1) F(TB,11,1) F(TC,12,1) F(TD,13,1) F(TE,14,1) \
1018 F(TF,15,1) F(TG,16,1) F(TH,17,1) F(TI,18,1) F(TJ,19,1) F(TK,20,1) \
1019 S(T1,1) S(T2,2) S(T3,3) S(T4,4) S(T5,5) S(T6,6) S(T7,7) \
1020 S(T8,8) S(T9,9) S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) \
1021 S(TF,15) S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
1022 #define CFARGTA14(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE) \
1023 F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
1024 F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
1025 F(TD,AD,13,1) F(TE,AE,14,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
1026 S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
1027 S(TB,11) S(TC,12) S(TD,13) S(TE,14)
1028 #if MAX_PREPRO_ARGS>31
1029 #define CFARGTA20(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK) \
1030 F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
1031 F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
1032 F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
1033 F(TJ,AJ,19,1) F(TK,AK,20,1) S(T1,1) S(T2,2) S(T3,3) S(T4,4) \
1034 S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) S(TA,10) \
1035 S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) S(TG,16) \
1036 S(TH,17) S(TI,18) S(TJ,19) S(TK,20)
1037 #define CFARGTA27(F,S,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR,A1,A2,A3,A4,A5,A6,A7,A8,A9,AA,AB,AC,AD,AE,AF,AG,AH,AI,AJ,AK,AL,AM,AN,AO,AP,AQ,AR) \
1038 F(T1,A1,1,0) F(T2,A2,2,1) F(T3,A3,3,1) F(T4,A4,4,1) F(T5,A5,5,1) F(T6,A6,6,1) \
1039 F(T7,A7,7,1) F(T8,A8,8,1) F(T9,A9,9,1) F(TA,AA,10,1) F(TB,AB,11,1) F(TC,AC,12,1) \
1040 F(TD,AD,13,1) F(TE,AE,14,1) F(TF,AF,15,1) F(TG,AG,16,1) F(TH,AH,17,1) F(TI,AI,18,1) \
1041 F(TJ,AJ,19,1) F(TK,AK,20,1) F(TL,AL,21,1) F(TM,AM,22,1) F(TN,AN,23,1) F(TO,AO,24,1) \
1042 F(TP,AP,25,1) F(TQ,AQ,26,1) F(TR,AR,27,1) S(T1,1) S(T2,2) S(T3,3) \
1043 S(T4,4) S(T5,5) S(T6,6) S(T7,7) S(T8,8) S(T9,9) \
1044 S(TA,10) S(TB,11) S(TC,12) S(TD,13) S(TE,14) S(TF,15) \
1045 S(TG,16) S(TH,17) S(TI,18) S(TJ,19) S(TK,20) S(TL,21) \
1046 S(TM,22) S(TN,23) S(TO,24) S(TP,25) S(TQ,26) S(TR,27)
1047 #endif
1048 #else
1049 #define CFARGT14(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE) \
1050 F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
1051 F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
1052 F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
1053 F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14)
1054 #define CFARGT27(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK,TL,TM,TN,TO,TP,TQ,TR) \
1055 F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
1056 F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
1057 F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
1058 F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
1059 F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20) \
1060 F(TL,21,1) S(TL,21) F(TM,22,1) S(TM,22) F(TN,23,1) S(TN,23) F(TO,24,1) S(TO,24) \
1061 F(TP,25,1) S(TP,25) F(TQ,26,1) S(TQ,26) F(TR,27,1) S(TR,27)
1062
1063 #define CFARGT20(F,S,M,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE,TF,TG,TH,TI,TJ,TK) \
1064 F(T1,1,0) S(T1,1) F(T2,2,1) S(T2,2) F(T3,3,1) S(T3,3) F(T4,4,1) S(T4,4) \
1065 F(T5,5,1) S(T5,5) F(T6,6,1) S(T6,6) F(T7,7,1) S(T7,7) F(T8,8,1) S(T8,8) \
1066 F(T9,9,1) S(T9,9) F(TA,10,1) S(TA,10) F(TB,11,1) S(TB,11) F(TC,12,1) S(TC,12) \
1067 F(TD,13,1) S(TD,13) F(TE,14,1) S(TE,14) F(TF,15,1) S(TF,15) F(TG,16,1) S(TG,16) \
1068 F(TH,17,1) S(TH,17) F(TI,18,1) S(TI,18) F(TJ,19,1) S(TJ,19) F(TK,20,1) S(TK,20)
1069