diff options
Diffstat (limited to 'vendor/cfitsio/f77_wrap1.c')
| -rw-r--r-- | vendor/cfitsio/f77_wrap1.c | 345 |
1 files changed, 345 insertions, 0 deletions
diff --git a/vendor/cfitsio/f77_wrap1.c b/vendor/cfitsio/f77_wrap1.c new file mode 100644 index 00000000..db7001b3 --- /dev/null +++ b/vendor/cfitsio/f77_wrap1.c @@ -0,0 +1,345 @@ +/************************************************************************ + + f77_wrap1.c and f77_wrap2.c have now been split into 4 files to + prevent compile-time memory errors (from expansion of compiler commands). + f77_wrap1.c was split into f77_wrap1.c and f77_wrap3.c, and + f77_wrap2.c was split into f77_wrap2.c and f77_wrap4.c: + + f77_wrap1.c contains routines operating on whole files and some + utility routines. + + f77_wrap2.c contains routines operating on primary array, image, + or column elements. + + f77_wrap3.c contains routines operating on headers & keywords. + + f77_wrap4.c contains miscellaneous routines. + + Peter's original comments: + + Together, f77_wrap1.c and f77_wrap2.c contain C wrappers for all + the CFITSIO routines prototyped in fitsio.h, except for the + generic datatype routines and features not supported in fortran + (eg, unsigned integers), a few routines prototyped in fitsio2.h, + which only a handful of FTOOLS use, plus a few obsolete FITSIO + routines not present in CFITSIO. This file allows Fortran code + to use the CFITSIO library instead of the FITSIO library without + modification. It also gives access to new routines not present + in FITSIO. Fortran FTOOLS must continue using the old routine + names from FITSIO (ie, ftxxxx), but most of the C-wrappers simply + redirect those calls to the corresponding CFITSIO routines (ie, + ffxxxx), with appropriate parameter massaging where necessary. + The main exception are read/write routines ending in j (ie, long + data) which get redirected to C routines ending in k (ie, int + data). This is more consistent with the default integer type in + Fortran. f77_wrap1.c primarily holds routines operating on whole + files and extension headers. f77_wrap2.c handle routines which + read and write the data portion, plus miscellaneous extra routines. + + File created by Peter Wilson (HSTX), Oct-Dec. 1997 +************************************************************************/ + +#include "fitsio2.h" +#include "f77_wrap.h" + +unsigned long gMinStrLen=80L; +fitsfile *gFitsFiles[MAXFITSFILES]={0}; + +/*---------------- Fortran Unit Number Allocation -------------*/ + +void Cffgiou( int *unit, int *status ); +void Cffgiou( int *unit, int *status ) +{ + int i; + + if( *status>0 ) return; + for( i=50;i<MAXFITSFILES;i++ ) /* Using a unit=0 sounds bad, so start at 1 */ + if( gFitsFiles[i]==NULL ) break; + if( i==MAXFITSFILES ) { + *unit = 0; + *status = TOO_MANY_FILES; + ffpmsg("Cffgiou has no more available unit numbers."); + } else { + *unit=i; + gFitsFiles[i] = (fitsfile *)1; /* Flag it as taken until ftopen/init */ + /* can be called and set a real value */ + } +} +FCALLSCSUB2(Cffgiou,FTGIOU,ftgiou,PINT,PINT) + +void Cfffiou( int unit, int *status ); +void Cfffiou( int unit, int *status ) +{ + if( *status>0 ) return; + if( unit == -1 ) { + int i; for( i=50; i<MAXFITSFILES; ) gFitsFiles[i++]=NULL; + } else if( unit<1 || unit>=MAXFITSFILES ) { + *status = BAD_FILEPTR; + ffpmsg("Cfffiou was sent an unacceptable unit number."); + } else gFitsFiles[unit]=NULL; +} +FCALLSCSUB2(Cfffiou,FTFIOU,ftfiou,INT,PINT) + + +int CFITS2Unit( fitsfile *fptr ) + /* Utility routine to convert a fitspointer to a Fortran unit number */ + /* for use when a C program is calling a Fortran routine which could */ + /* in turn call CFITSIO... Modelled after code by Ning Gan. */ +{ + static fitsfile *last_fptr = (fitsfile *)NULL; /* Remember last fptr */ + static int last_unit = 0; /* Remember last unit */ + int status = 0; + + /* Test whether we are repeating the last lookup */ + + if( last_unit && fptr==gFitsFiles[last_unit] ) + return( last_unit ); + + /* Check if gFitsFiles has an entry for this fptr. */ + /* Allows Fortran to call C to call Fortran to */ + /* call CFITSIO... OUCH!!! */ + + last_fptr = fptr; + for( last_unit=1; last_unit<MAXFITSFILES; last_unit++ ) { + if( fptr == gFitsFiles[last_unit] ) + return( last_unit ); + } + + /* Allocate a new unit number for this fptr */ + Cffgiou( &last_unit, &status ); + if( status ) + last_unit = 0; + else + gFitsFiles[last_unit] = fptr; + return( last_unit ); +} + + +fitsfile* CUnit2FITS(int unit) +{ + if( unit<1 || unit>=MAXFITSFILES ) + return(0); + + return(gFitsFiles[unit]); +} + + /**************************************************/ + /* Start of wrappers for routines in fitsio.h */ + /**************************************************/ + +/*---------------- FITS file URL parsing routines -------------*/ + +FCALLSCSUB9(ffiurl,FTIURL,ftiurl,STRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PSTRING,PINT) +FCALLSCSUB3(ffrtnm,FTRTNM,ftrtnm,STRING,PSTRING,PINT) +FCALLSCSUB3(ffexist,FTEXIST,ftexist,STRING,PINT,PINT) +FCALLSCSUB3(ffextn,FTEXTN,ftextn,STRING,PINT,PINT) +FCALLSCSUB7(ffrwrg,FTRWRG,ftrwrg,STRING,LONG,INT,PINT,PLONG,PLONG,PINT) + +/*---------------- FITS file I/O routines ---------------*/ + +void Cffopen( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status ); +void Cffopen( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status ) +{ + int hdutype; + + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffopen( fptr, filename, iomode, status ); + ffmahd( *fptr, 1, &hdutype, status ); + *blocksize = 1; + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffopen tried to use an already opened unit."); + } +} +FCALLSCSUB5(Cffopen,FTOPEN,ftopen,PFITSUNIT,STRING,INT,PINT,PINT) + +void Cffdkopn( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status ); +void Cffdkopn( fitsfile **fptr, const char *filename, int iomode, int *blocksize, int *status ) +{ + int hdutype; + + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffdkopn( fptr, filename, iomode, status ); + ffmahd( *fptr, 1, &hdutype, status ); + *blocksize = 1; + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffdkopn tried to use an already opened unit."); + } +} +FCALLSCSUB5(Cffdkopn,FTDKOPN,ftdkopn,PFITSUNIT,STRING,INT,PINT,PINT) + + +void Cffnopn( fitsfile **fptr, const char *filename, int iomode, int *status ); +void Cffnopn( fitsfile **fptr, const char *filename, int iomode, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffopen( fptr, filename, iomode, status ); + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffnopn tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cffnopn,FTNOPN,ftnopn,PFITSUNIT,STRING,INT,PINT) + +void Cffdopn( fitsfile **fptr, const char *filename, int iomode, int *status ); +void Cffdopn( fitsfile **fptr, const char *filename, int iomode, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffdopn( fptr, filename, iomode, status ); + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffdopn tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cffdopn,FTDOPN,ftdopn,PFITSUNIT,STRING,INT,PINT) + +void Cfftopn( fitsfile **fptr, const char *filename, int iomode, int *status ); +void Cfftopn( fitsfile **fptr, const char *filename, int iomode, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + fftopn( fptr, filename, iomode, status ); + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cfftopn tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cfftopn,FTTOPN,fttopn,PFITSUNIT,STRING,INT,PINT) + +void Cffiopn( fitsfile **fptr, const char *filename, int iomode, int *status ); +void Cffiopn( fitsfile **fptr, const char *filename, int iomode, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffiopn( fptr, filename, iomode, status ); + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffiopn tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cffiopn,FTIOPN,ftiopn,PFITSUNIT,STRING,INT,PINT) + +void Cffreopen( fitsfile *openfptr, fitsfile **newfptr, int *status ); +void Cffreopen( fitsfile *openfptr, fitsfile **newfptr, int *status ) +{ + if( *newfptr==NULL || *newfptr==(fitsfile*)1 ) { + ffreopen( openfptr, newfptr, status ); + } else { + *status = FILE_NOT_OPENED; + ffpmsg("Cffreopen tried to use an already opened unit."); + } +} +FCALLSCSUB3(Cffreopen,FTREOPEN,ftreopen,FITSUNIT,PFITSUNIT,PINT) + +void Cffinit( fitsfile **fptr, const char *filename, int blocksize, int *status ); +void Cffinit( fitsfile **fptr, const char *filename, int blocksize, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffinit( fptr, filename, status ); + } else { + *status = FILE_NOT_CREATED; + ffpmsg("Cffinit tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cffinit,FTINIT,ftinit,PFITSUNIT,STRING,INT,PINT) + +void Cffdkinit( fitsfile **fptr, const char *filename, int blocksize, int *status ); +void Cffdkinit( fitsfile **fptr, const char *filename, int blocksize, int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + ffdkinit( fptr, filename, status ); + } else { + *status = FILE_NOT_CREATED; + ffpmsg("Cffdkinit tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cffdkinit,FTDKINIT,ftdkinit,PFITSUNIT,STRING,INT,PINT) + +void Cfftplt( fitsfile **fptr, const char *filename, const char *tempname, + int *status ); +void Cfftplt( fitsfile **fptr, const char *filename, const char *tempname, + int *status ) +{ + if( *fptr==NULL || *fptr==(fitsfile*)1 ) { + fftplt( fptr, filename, tempname, status ); + } else { + *status = FILE_NOT_CREATED; + ffpmsg("Cfftplt tried to use an already opened unit."); + } +} +FCALLSCSUB4(Cfftplt,FTTPLT,fttplt,PFITSUNIT,STRING,STRING,PINT) + +FCALLSCSUB2(ffflus,FTFLUS,ftflus,FITSUNIT,PINT) +FCALLSCSUB3(ffflsh,FTFLSH,ftflsh,FITSUNIT, INT, PINT) + +void Cffclos( int unit, int *status ); +void Cffclos( int unit, int *status ) +{ + if( gFitsFiles[unit]!=NULL && gFitsFiles[unit]!=(void*)1 ) { + ffclos( gFitsFiles[unit], status ); /* Flag unit number as unavailable */ + gFitsFiles[unit]=(fitsfile*)1; /* in case want to reuse it */ + } +} +FCALLSCSUB2(Cffclos,FTCLOS,ftclos,INT,PINT) + +void Cffdelt( int unit, int *status ); +void Cffdelt( int unit, int *status ) +{ + if( gFitsFiles[unit]!=NULL && gFitsFiles[unit]!=(void*)1 ) { + ffdelt( gFitsFiles[unit], status ); /* Flag unit number as unavailable */ + gFitsFiles[unit]=(fitsfile*)1; /* in case want to reuse it */ + } +} +FCALLSCSUB2(Cffdelt,FTDELT,ftdelt,INT,PINT) + +FCALLSCSUB3(ffflnm,FTFLNM,ftflnm,FITSUNIT,PSTRING,PINT) +FCALLSCSUB3(ffflmd,FTFLMD,ftflmd,FITSUNIT,PINT,PINT) + +/*--------------- utility routines ---------------*/ +FCALLSCSUB1(ffvers,FTVERS,ftvers,PFLOAT) +FCALLSCSUB1(ffupch,FTUPCH,ftupch,PSTRING) +FCALLSCSUB2(ffgerr,FTGERR,ftgerr,INT,PSTRING) +FCALLSCSUB1(ffpmsg,FTPMSG,ftpmsg,STRING) +FCALLSCSUB1(ffgmsg,FTGMSG,ftgmsg,PSTRING) +FCALLSCSUB0(ffcmsg,FTCMSG,ftcmsg) +FCALLSCSUB0(ffpmrk,FTPMRK,ftpmrk) +FCALLSCSUB0(ffcmrk,FTCMRK,ftcmrk) + +void Cffrprt( char *fname, int status ); +void Cffrprt( char *fname, int status ) +{ + if( !strcmp(fname,"STDOUT") || !strcmp(fname,"stdout") ) + ffrprt( stdout, status ); + else if( !strcmp(fname,"STDERR") || !strcmp(fname,"stderr") ) + ffrprt( stderr, status ); + else { + FILE *fptr; + + fptr = fopen(fname, "a"); + if (fptr==NULL) + printf("file pointer is null.\n"); + else { + ffrprt(fptr,status); + fclose(fptr); + } + } +} +FCALLSCSUB2(Cffrprt,FTRPRT,ftrprt,STRING,INT) + +FCALLSCSUB5(ffcmps,FTCMPS,ftcmps,STRING,STRING,LOGICAL,PLOGICAL,PLOGICAL) +FCALLSCSUB2(fftkey,FTTKEY,fttkey,STRING,PINT) +FCALLSCSUB2(fftrec,FTTREC,fttrec,STRING,PINT) +FCALLSCSUB2(ffnchk,FTNCHK,ftnchk,FITSUNIT,PINT) +FCALLSCSUB4(ffkeyn,FTKEYN,ftkeyn,STRING,INT,PSTRING,PINT) +FCALLSCSUB4(ffgknm,FTGKNM,ftgknm,STRING,PSTRING, PINT, PINT) +FCALLSCSUB4(ffnkey,FTNKEY,ftnkey,INT,STRING,PSTRING,PINT) +FCALLSCSUB3(ffdtyp,FTDTYP,ftdtyp,STRING,PSTRING,PINT) +FCALLSCFUN1(INT,ffgkcl,FTGKCL,ftgkcl,STRING) +FCALLSCSUB4(ffpsvc,FTPSVC,ftpsvc,STRING,PSTRING,PSTRING,PINT) +FCALLSCSUB4(ffgthd,FTGTHD,ftgthd,STRING,PSTRING,PINT,PINT) +FCALLSCSUB5(ffasfm,FTASFM,ftasfm,STRING,PINT,PLONG,PINT,PINT) +FCALLSCSUB5(ffbnfm,FTBNFM,ftbnfm,STRING,PINT,PLONG,PLONG,PINT) + +#define ftgabc_STRV_A2 NUM_ELEM_ARG(1) +#define ftgabc_LONGV_A5 A1 +FCALLSCSUB6(ffgabc,FTGABC,ftgabc,INT,STRINGV,INT,PLONG,LONGV,PINT) + |