1 /************************************************************************
2
3 f77_wrap1.c and f77_wrap2.c have now been split into 4 files to
4 prevent compile-time memory errors (from expansion of compiler commands).
5 f77_wrap1.c was split into f77_wrap1.c and f77_wrap3.c, and
6 f77_wrap2.c was split into f77_wrap2.c and f77_wrap4.c:
7
8 f77_wrap1.c contains routines operating on whole files and some
9 utility routines.
10
11 f77_wrap2.c contains routines operating on primary array, image,
12 or column elements.
13
14 f77_wrap3.c contains routines operating on headers & keywords.
15
16 f77_wrap4.c contains miscellaneous routines.
17
18 Peter's original comments:
19
20 Together, f77_wrap1.c and f77_wrap2.c contain C wrappers for all
21 the CFITSIO routines prototyped in fitsio.h, except for the
22 generic datatype routines and features not supported in fortran
23 (eg, unsigned integers), a few routines prototyped in fitsio2.h,
24 which only a handful of FTOOLS use, plus a few obsolete FITSIO
25 routines not present in CFITSIO. This file allows Fortran code
26 to use the CFITSIO library instead of the FITSIO library without
27 modification. It also gives access to new routines not present
28 in FITSIO. Fortran FTOOLS must continue using the old routine
29 names from FITSIO (ie, ftxxxx), but most of the C-wrappers simply
30 redirect those calls to the corresponding CFITSIO routines (ie,
31 ffxxxx), with appropriate parameter massaging where necessary.
32 The main exception are read/write routines ending in j (ie, long
33 data) which get redirected to C routines ending in k (ie, int
34 data). This is more consistent with the default integer type in
35 Fortran. f77_wrap1.c primarily holds routines operating on whole
36 files and extension headers. f77_wrap2.c handle routines which
37 read and write the data portion, plus miscellaneous extra routines.
38
39 File created by Peter Wilson (HSTX), Oct-Dec. 1997
40 ************************************************************************/
41
42 #include "fitsio2.h"
43 #include "f77_wrap.h"
44
45 unsigned long gMinStrLen=80L;
46 fitsfile *gFitsFiles[NMAXFILES]={0};
47
48 /*---------------- Fortran Unit Number Allocation -------------*/
49
50 void Cffgiou( int *unit, int *status );
Cffgiou(int * unit,int * status)51 void Cffgiou( int *unit, int *status )
52 {
53 int i;
54
55 if( *status>0 ) return;
56 for( i=50;i<NMAXFILES;i++ ) /* Using a unit=0 sounds bad, so start at 1 */
57 if( gFitsFiles[i]==NULL ) break;
58 if( i==NMAXFILES ) {
59 *unit = 0;
60 *status = TOO_MANY_FILES;
61 ffpmsg("Cffgiou has no more available unit numbers.");
62 } else {
63 *unit=i;
64 gFitsFiles[i] = (fitsfile *)1; /* Flag it as taken until ftopen/init */
65 /* can be called and set a real value */
66 }
67 }
68 FCALLSCSUB2(Cffgiou,FTGIOU,ftgiou,PINT,PINT)
69
70 void Cfffiou( int unit, int *status );
Cfffiou(int unit,int * status)71 void Cfffiou( int unit, int *status )
72 {
73 if( *status>0 ) return;
74 if( unit == -1 ) {
75 int i; for( i=50; i<NMAXFILES; ) gFitsFiles[i++]=NULL;
76 } else if( unit<1 || unit>=NMAXFILES ) {
77 *status = BAD_FILEPTR;
78 ffpmsg("Cfffiou was sent an unacceptable unit number.");
79 } else gFitsFiles[unit]=NULL;
80 }
FCALLSCSUB2(Cfffiou,FTFIOU,ftfiou,INT,PINT)81 FCALLSCSUB2(Cfffiou,FTFIOU,ftfiou,INT,PINT)
82
83
84 int CFITS2Unit( fitsfile *fptr )
85 /* Utility routine to convert a fitspointer to a Fortran unit number */
86 /* for use when a C program is calling a Fortran routine which could */
87 /* in turn call CFITSIO... Modelled after code by Ning Gan. */
88 {
89 static fitsfile *last_fptr = (fitsfile *)NULL; /* Remember last fptr */
90 static int last_unit = 0; /* Remember last unit */
91 int status = 0;
92
93 /* Test whether we are repeating the last lookup */
94
95 if( last_unit && fptr==gFitsFiles[last_unit] )
96 return( last_unit );
97
98 /* Check if gFitsFiles has an entry for this fptr. */
99 /* Allows Fortran to call C to call Fortran to */
100 /* call CFITSIO... OUCH!!! */
101
102 last_fptr = fptr;
103 for( last_unit=1; last_unit<NMAXFILES; last_unit++ ) {
104 if( fptr == gFitsFiles[last_unit] )
105 return( last_unit );
106 }
107
108 /* Allocate a new unit number for this fptr */
109 Cffgiou( &last_unit, &status );
110 if( status )
111 last_unit = 0;
112 else
113 gFitsFiles[last_unit] = fptr;
114 return( last_unit );
115 }
116
117
CUnit2FITS(int unit)118 fitsfile* CUnit2FITS(int unit)
119 {
120 if( unit<1 || unit>=NMAXFILES )
121 return(0);
122
123 return(gFitsFiles[unit]);
124 }
125
126 /**************************************************/
127 /* Start of wrappers for routines in fitsio.h */
128 /**************************************************/
129
130 /*---------------- FITS file URL parsing routines -------------*/
131
132 FCALLSCSUB9(ffiurl,FTIURL,ftiurl,STRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PINT)
133 FCALLSCSUB3(ffrtnm,FTRTNM,ftrtnm,STRING,PSTRING,PINT)
134 FCALLSCSUB3(ffexist,FTEXIST,ftexist,STRING,PINT,PINT)
135 FCALLSCSUB3(ffextn,FTEXTN,ftextn,STRING,PINT,PINT)
136 FCALLSCSUB7(ffrwrg,FTRWRG,ftrwrg,STRING,LONG,INT,PINT,PLONG,PLONG,PINT)
137
138 /*---------------- FITS file I/O routines ---------------*/
139
140 void Cffopen( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status );
Cffopen(fitsfile ** fptr,const char * filename,int iomode,int * blocksize,int * status)141 void Cffopen( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status )
142 {
143 int hdutype;
144
145 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
146 ffopen( fptr, filename, iomode, status );
147 ffmahd( *fptr, 1, &hdutype, status );
148 *blocksize = 1;
149 } else {
150 *status = FILE_NOT_OPENED;
151 ffpmsg("Cffopen tried to use an already opened unit.");
152 }
153 }
154 FCALLSCSUB5(Cffopen,FTOPEN,ftopen,PFITSUNIT,STRING,INT,PINT,PINT)
155
156 void Cffdkopn( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status );
Cffdkopn(fitsfile ** fptr,const char * filename,int iomode,int * blocksize,int * status)157 void Cffdkopn( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status )
158 {
159 int hdutype;
160
161 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
162 ffdkopn( fptr, filename, iomode, status );
163 ffmahd( *fptr, 1, &hdutype, status );
164 *blocksize = 1;
165 } else {
166 *status = FILE_NOT_OPENED;
167 ffpmsg("Cffdkopn tried to use an already opened unit.");
168 }
169 }
170 FCALLSCSUB5(Cffdkopn,FTDKOPN,ftdkopn,PFITSUNIT,STRING,INT,PINT,PINT)
171
172
173 void Cffnopn( fitsfile **fptr, const char *filename, int iomode, int *status );
Cffnopn(fitsfile ** fptr,const char * filename,int iomode,int * status)174 void Cffnopn( fitsfile **fptr, const char *filename, int iomode, int *status )
175 {
176 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
177 ffopen( fptr, filename, iomode, status );
178 } else {
179 *status = FILE_NOT_OPENED;
180 ffpmsg("Cffnopn tried to use an already opened unit.");
181 }
182 }
183 FCALLSCSUB4(Cffnopn,FTNOPN,ftnopn,PFITSUNIT,STRING,INT,PINT)
184
185 void Cffdopn( fitsfile **fptr, const char *filename, int iomode, int *status );
Cffdopn(fitsfile ** fptr,const char * filename,int iomode,int * status)186 void Cffdopn( fitsfile **fptr, const char *filename, int iomode, int *status )
187 {
188 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
189 ffdopn( fptr, filename, iomode, status );
190 } else {
191 *status = FILE_NOT_OPENED;
192 ffpmsg("Cffdopn tried to use an already opened unit.");
193 }
194 }
195 FCALLSCSUB4(Cffdopn,FTDOPN,ftdopn,PFITSUNIT,STRING,INT,PINT)
196
197 void Cfftopn( fitsfile **fptr, const char *filename, int iomode, int *status );
Cfftopn(fitsfile ** fptr,const char * filename,int iomode,int * status)198 void Cfftopn( fitsfile **fptr, const char *filename, int iomode, int *status )
199 {
200 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
201 fftopn( fptr, filename, iomode, status );
202 } else {
203 *status = FILE_NOT_OPENED;
204 ffpmsg("Cfftopn tried to use an already opened unit.");
205 }
206 }
207 FCALLSCSUB4(Cfftopn,FTTOPN,fttopn,PFITSUNIT,STRING,INT,PINT)
208
209 void Cffiopn( fitsfile **fptr, const char *filename, int iomode, int *status );
Cffiopn(fitsfile ** fptr,const char * filename,int iomode,int * status)210 void Cffiopn( fitsfile **fptr, const char *filename, int iomode, int *status )
211 {
212 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
213 ffiopn( fptr, filename, iomode, status );
214 } else {
215 *status = FILE_NOT_OPENED;
216 ffpmsg("Cffiopn tried to use an already opened unit.");
217 }
218 }
219 FCALLSCSUB4(Cffiopn,FTIOPN,ftiopn,PFITSUNIT,STRING,INT,PINT)
220
221 void Cffreopen( fitsfile *openfptr, fitsfile **newfptr, int *status );
Cffreopen(fitsfile * openfptr,fitsfile ** newfptr,int * status)222 void Cffreopen( fitsfile *openfptr, fitsfile **newfptr, int *status )
223 {
224 if( *newfptr==NULL || *newfptr==(fitsfile*)1 ) {
225 ffreopen( openfptr, newfptr, status );
226 } else {
227 *status = FILE_NOT_OPENED;
228 ffpmsg("Cffreopen tried to use an already opened unit.");
229 }
230 }
231 FCALLSCSUB3(Cffreopen,FTREOPEN,ftreopen,FITSUNIT,PFITSUNIT,PINT)
232
233 void Cffinit( fitsfile **fptr, const char *filename, int blocksize, int *status );
Cffinit(fitsfile ** fptr,const char * filename,int blocksize,int * status)234 void Cffinit( fitsfile **fptr, const char *filename, int blocksize, int *status )
235 {
236 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
237 ffinit( fptr, filename, status );
238 } else {
239 *status = FILE_NOT_CREATED;
240 ffpmsg("Cffinit tried to use an already opened unit.");
241 }
242 }
243 FCALLSCSUB4(Cffinit,FTINIT,ftinit,PFITSUNIT,STRING,INT,PINT)
244
245 void Cffdkinit( fitsfile **fptr, const char *filename, int blocksize, int *status );
Cffdkinit(fitsfile ** fptr,const char * filename,int blocksize,int * status)246 void Cffdkinit( fitsfile **fptr, const char *filename, int blocksize, int *status )
247 {
248 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
249 ffdkinit( fptr, filename, status );
250 } else {
251 *status = FILE_NOT_CREATED;
252 ffpmsg("Cffdkinit tried to use an already opened unit.");
253 }
254 }
255 FCALLSCSUB4(Cffdkinit,FTDKINIT,ftdkinit,PFITSUNIT,STRING,INT,PINT)
256
257 void Cfftplt( fitsfile **fptr, const char *filename, const char *tempname,
258 int *status );
Cfftplt(fitsfile ** fptr,const char * filename,const char * tempname,int * status)259 void Cfftplt( fitsfile **fptr, const char *filename, const char *tempname,
260 int *status )
261 {
262 if( *fptr==NULL || *fptr==(fitsfile*)1 ) {
263 fftplt( fptr, filename, tempname, status );
264 } else {
265 *status = FILE_NOT_CREATED;
266 ffpmsg("Cfftplt tried to use an already opened unit.");
267 }
268 }
269 FCALLSCSUB4(Cfftplt,FTTPLT,fttplt,PFITSUNIT,STRING,STRING,PINT)
270
271 FCALLSCSUB2(ffflus,FTFLUS,ftflus,FITSUNIT,PINT)
272 FCALLSCSUB3(ffflsh,FTFLSH,ftflsh,FITSUNIT, INT, PINT)
273
274 void Cffclos( int unit, int *status );
Cffclos(int unit,int * status)275 void Cffclos( int unit, int *status )
276 {
277 if( gFitsFiles[unit]!=NULL && gFitsFiles[unit]!=(void*)1 ) {
278 ffclos( gFitsFiles[unit], status ); /* Flag unit number as unavailable */
279 gFitsFiles[unit]=(fitsfile*)1; /* in case want to reuse it */
280 }
281 }
282 FCALLSCSUB2(Cffclos,FTCLOS,ftclos,INT,PINT)
283
284 void Cffdelt( int unit, int *status );
Cffdelt(int unit,int * status)285 void Cffdelt( int unit, int *status )
286 {
287 if( gFitsFiles[unit]!=NULL && gFitsFiles[unit]!=(void*)1 ) {
288 ffdelt( gFitsFiles[unit], status ); /* Flag unit number as unavailable */
289 gFitsFiles[unit]=(fitsfile*)1; /* in case want to reuse it */
290 }
291 }
292 FCALLSCSUB2(Cffdelt,FTDELT,ftdelt,INT,PINT)
293
294 FCALLSCSUB3(ffflnm,FTFLNM,ftflnm,FITSUNIT,PSTRING,PINT)
295 FCALLSCSUB3(ffflmd,FTFLMD,ftflmd,FITSUNIT,PINT,PINT)
296
297 /*--------------- utility routines ---------------*/
298 FCALLSCSUB1(ffvers,FTVERS,ftvers,PFLOAT)
299 FCALLSCSUB1(ffupch,FTUPCH,ftupch,PSTRING)
300 FCALLSCSUB2(ffgerr,FTGERR,ftgerr,INT,PSTRING)
301 FCALLSCSUB1(ffpmsg,FTPMSG,ftpmsg,STRING)
302 FCALLSCSUB1(ffgmsg,FTGMSG,ftgmsg,PSTRING)
303 FCALLSCSUB0(ffcmsg,FTCMSG,ftcmsg)
304 FCALLSCSUB0(ffpmrk,FTPMRK,ftpmrk)
305 FCALLSCSUB0(ffcmrk,FTCMRK,ftcmrk)
306
307 void Cffrprt( char *fname, int status );
Cffrprt(char * fname,int status)308 void Cffrprt( char *fname, int status )
309 {
310 if( !strcmp(fname,"STDOUT") || !strcmp(fname,"stdout") )
311 ffrprt( stdout, status );
312 else if( !strcmp(fname,"STDERR") || !strcmp(fname,"stderr") )
313 ffrprt( stderr, status );
314 else {
315 FILE *fptr;
316
317 fptr = fopen(fname, "a");
318 if (fptr==NULL)
319 printf("file pointer is null.\n");
320 else {
321 ffrprt(fptr,status);
322 fclose(fptr);
323 }
324 }
325 }
326 FCALLSCSUB2(Cffrprt,FTRPRT,ftrprt,STRING,INT)
327
328 FCALLSCSUB5(ffcmps,FTCMPS,ftcmps,STRING,STRING,LOGICAL,PLOGICAL,PLOGICAL)
329 FCALLSCSUB2(fftkey,FTTKEY,fttkey,STRING,PINT)
330 FCALLSCSUB2(fftrec,FTTREC,fttrec,STRING,PINT)
331 FCALLSCSUB2(ffnchk,FTNCHK,ftnchk,FITSUNIT,PINT)
332 FCALLSCSUB4(ffkeyn,FTKEYN,ftkeyn,STRING,INT,PSTRING,PINT)
333 FCALLSCSUB4(ffgknm,FTGKNM,ftgknm,STRING,PSTRING, PINT, PINT)
334 FCALLSCSUB4(ffnkey,FTNKEY,ftnkey,INT,STRING,PSTRING,PINT)
335 FCALLSCSUB3(ffdtyp,FTDTYP,ftdtyp,STRING,PSTRING,PINT)
336 FCALLSCFUN1(INT,ffgkcl,FTGKCL,ftgkcl,STRING)
337 FCALLSCSUB5(ffmkky,FTMKKY,ftmkky,STRING,STRING,STRING,PSTRING,PINT)
338 FCALLSCSUB4(ffpsvc,FTPSVC,ftpsvc,STRING,PSTRING,PSTRING,PINT)
339 FCALLSCSUB4(ffgthd,FTGTHD,ftgthd,STRING,PSTRING,PINT,PINT)
340 FCALLSCSUB5(ffasfm,FTASFM,ftasfm,STRING,PINT,PLONG,PINT,PINT)
341 FCALLSCSUB5(ffbnfm,FTBNFM,ftbnfm,STRING,PINT,PLONG,PLONG,PINT)
342
343 #define ftgabc_STRV_A2 NUM_ELEM_ARG(1)
344 #define ftgabc_LONGV_A5 A1
345 FCALLSCSUB6(ffgabc,FTGABC,ftgabc,INT,STRINGV,INT,PLONG,LONGV,PINT)
346
347 /* File download diagnostic functions */
348 FCALLSCSUB1(ffvhtps,FTVHTPS,ftvhtps,INT)
349 FCALLSCSUB1(ffshdwn,FTSHDWN,ftshdwn,INT)
350 void Cffgtmo(int *secs);
Cffgtmo(int * secs)351 void Cffgtmo(int *secs)
352 {
353 *secs = ffgtmo();
354 }
355 FCALLSCSUB1(Cffgtmo,FTGTMO,ftgtmo,PINT)
356 FCALLSCSUB2(ffstmo,FTSTMO,ftstmo,INT,PINT)
357
358
359