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