diff options
| author | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
|---|---|---|
| committer | Joseph Hunkeler <jhunkeler@gmail.com> | 2015-07-08 20:46:52 -0400 |
| commit | fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4 (patch) | |
| tree | bdda434976bc09c864f2e4fa6f16ba1952b1e555 /pkg/tbtables/fitsio | |
| download | iraf-linux-fa080de7afc95aa1c19a6e6fc0e0708ced2eadc4.tar.gz | |
Initial commit
Diffstat (limited to 'pkg/tbtables/fitsio')
625 files changed, 35711 insertions, 0 deletions
diff --git a/pkg/tbtables/fitsio/README b/pkg/tbtables/fitsio/README new file mode 100644 index 00000000..750f9700 --- /dev/null +++ b/pkg/tbtables/fitsio/README @@ -0,0 +1,11 @@ +# These routines are part of the FITSIO library and are designed to run in +# the IRAF/SPP environment. +#------------------------------------------------------------------------------ +# This software was prepared by High Energy Astrophysics Science Archive +# Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +# shall not, without prior written permission of the U.S. Government, +# establish a claim to statutory copyright. The Government and others acting +# on its behalf shall have a royalty-free, non-exclusive, irrevocable, +# worldwide license for Government purposes to publish, distribute, +# translate, copy, exhibit, and perform such material. +#------------------------------------------------------------------------------ diff --git a/pkg/tbtables/fitsio/fitsspp.com b/pkg/tbtables/fitsio/fitsspp.com new file mode 100644 index 00000000..04e4ad79 --- /dev/null +++ b/pkg/tbtables/fitsio/fitsspp.com @@ -0,0 +1,23 @@ +# FITSSPP.COM -- Common block definitions used in fitsspp.x. + +define NB 20 # number of file buffers +define NE 200 # maximun allowed number of extensions + # in the FITS files +define MAXFILES 199 # more than needed + +# The following common is used throughout the fitsio code. +int bufnum, chdu, hdutyp, maxhdu, hdstrt, hdend, nxthdr, dtstrt +int nxtfld +bool wrmode + +common /ft0001/ bufnum[MAXFILES],chdu[NB],hdutyp[NB],maxhdu[NB], + wrmode[NB],hdstrt[NB,NE],hdend[NB],nxthdr[NB],dtstrt[NB],nxtfld + +int compid +common /ftcpid/compid + +int buflun, reclen, bytnum, filesize, recnum, bufid + +common /ftsbuf/buflun[NB],reclen[NB], + bytnum[NB],filesize[NB],recnum[NB],bufid[MAXFILES] + diff --git a/pkg/tbtables/fitsio/fitsspp.x b/pkg/tbtables/fitsio/fitsspp.x new file mode 100644 index 00000000..436ba4d6 --- /dev/null +++ b/pkg/tbtables/fitsio/fitsspp.x @@ -0,0 +1,831 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <mach.h> +include <time.h> +include <fset.h> +include <mii.h> + +#------------------------------------------------------------------------------ +# FITSSPP.X - IRAF/SPP interface for FITSIO. +# These routines are part of the FITSIO library and are designed to run in +# the IRAF/SPP environment. +# +# FTOPNX -- Open or create a file. NOTE: calls ieesnan[rd] +# FTCLSX -- Close a file opened with FTOPNX. +# FTFLSH -- dummy routine to flush a file to disk. Not needed in IRAF. +# +# FTGSDT -- Get the current date and time. +# +# FTMBYT -- move internal file pointer to specified byte +# FTMOFF -- offset internal file pointer to specified byte +# +# FTPI2B -- Write an array of Integer*2 bytes to the output FITS file. +# FTPI4B -- Write an array of Integer*4 bytes to the output FITS file. +# FTPR4B -- Write an array of Real*4 bytes to the output FITS file. +# FTPR8B -- Write an array of Real*8 bytes to the output FITS file. +# +# FTGI2B -- Read an array of Integer*2 bytes from the input FITS file. +# FTGI4B -- Read an array of Integer*4 bytes from the input FITS file. +# FTGR4B -- Read an array of Real*4 bytes from the input FITS file. +# FTGR8B -- Read an array of Real*8 bytes from the input FITS file. +# +# FTUPCH -- Convert input string to upper case. +# +# FTPBYT -- Write a byte sequence to a file. +# FTPCBF -- Write a sequence of characters to a file. (see unix/ or [.vms]) +# +# FTGBYT -- Read a byte sequence from a file. +# FTGCBF -- Read a sequence of characters from a file. (see unix/ or [.vms]) +# +# FTWRIT -- Write a sequence of bytes to a file +# FTREAD -- Read a sequence of bytes from a file +#------------------------------------------------------------------------------ +# This software was prepared by High Energy Astrophysic Science Archive +# Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +# shall not, without prior written permission of the U.S. Government, +# establish a claim to statutory copyright. The Government and others acting +# on its behalf, shall have a royalty-free, non-exclusive, irrevocable, +# worldwide license for Government purposes to publish, distribute, +# translate, copy, exhibit, and perform such material. +#------------------------------------------------------------------------------ + +define SZ_FITSREC 1440 # FITS record size in chars + +# FTOPNX -- Open or create a file. + +procedure ftopnx (funit, pkname, oldnew, rwmode, block, status) + +int funit #I Fortran I/O unit number +% character*(*) pkname +int oldnew #I file status: 0 = existing file; else new file +int rwmode #I file access mode: 0 = readonly; else = read/write +int block #O FITS record blocking factor +int status #U returned error status (0=ok) + +bool firsttime +int mode, i, nbuff, fd +char fname[SZ_PATHNAME] +int access(), open() +int fstati() +include "fitsspp.com" +data firsttime /true/ + +begin + if (status > 0) + return + + # Initialize fitsspp common. + if (firsttime) { + nxtfld=0 + call aclri (buflun, NB) + firsttime = false + } + + # Determine at run time what type of machine we are running on. + call ftarch(compid) + if (compid == 4) + compid=3 + + # Set the values for real and double undefined values, and turn on + # conversion between IEEE NaN and IRAF INDEF. (added by PEH) + # NOTE: This has a global effect for any task in any executable + # that is linked with this (ftopnx) routine. + call ieesnanr (INDEFR) + call ieesnand (INDEFD) + + # Check for valid unit number. + if (funit < 1 || funit > 199) { + status = 101 + return + } + + # Find available buffer slot for this file. + nbuff = ERR + do i = 1, NB { + if (buflun[i] == 0) { + nbuff = i + break + } + } + + # Error: no vacant buffer slots left. + if (nbuff == ERR) { + status = 102 + return + } + + # Convert Fortran string to an SPP string. + call f77upk (pkname, fname, SZ_PATHNAME) + + # Get the file access mode. + if (oldnew == 0) { + # Test if file exists. + if (access (fname, 0,0) == NO) { + # Error: file doesn't exist. + status = 103 + return + } + + # Set the access mode. + if (rwmode == 0) + mode = READ_ONLY + else + mode = READ_WRITE + + # Set the FITS blocking factor. + block = 1 + } else + mode = NEW_FILE + + # Open the file. + iferr (fd = open (fname, mode, BINARY_FILE)) { + if (oldnew == 0) + status = 104 + else + status = 105 + return + } + + # advise fio that the I/O will be primarily sequential + call fseti (fd, F_ADVICE, SEQUENTIAL) + + # Store the current size of the file + filesize[nbuff] = fstati (fd, F_FILESIZE) + + # Initialize the HDU parameters + bufnum[funit] = nbuff + chdu[nbuff] = 1 + hdutyp[nbuff] = 0 + maxhdu[nbuff] = 1 + hdstrt[nbuff,1] = 0 + hdend[nbuff] = 0 + nxthdr[nbuff] = 0 + # Data start location is undefined. + dtstrt[nbuff] = -1000000000 + + buflun[nbuff] = funit + reclen[nbuff] = 2880 + recnum[nbuff] = 0 + bytnum[nbuff] = 2880 + + wrmode[nbuff] = (rwmode != 0) + + bufid[funit] = fd +end + +# FTCLSX -- Close a file opened with FTOPNX. + +procedure ftclsx (iunit, keep, status) + +int iunit #I Fortran I/O unit number +bool keep #I keep the file (or delete it)? +int status #U returned error status (0=ok) + +int fd +int nbuff +char fname[SZ_PATHNAME] +include "fitsspp.com" + +begin + fd = bufid[iunit] + nbuff = bufnum[iunit] + + if (keep) { + iferr (call close(fd)) +# set error code, if it has not previous been set + if (status <= 0) status = 110 + } else { + call fstats (fd, F_FILENAME, fname, SZ_PATHNAME) + iferr (call close(fd)) +# set error code, if it has not previous been set + if (status <= 0) status = 110 + +# now delete the file + call delete (fname) + } + + bufnum[iunit] = 0 + buflun[nbuff] = 0 +end + +# FTFLSH -- dummy routine to flush a file to disk. Not needed in IRAF. + +procedure ftflsh (nbuff, status) + +int nbuff #I number of the buffer to be written +int status #U output error status + +begin +end + +# FTGSDT -- Get the current date and time. + +procedure ftgsdt (dd, mm, yy, status) + +int dd #O day of the month (1-31) +int mm #O month of the year (1-12) +int yy #O last 2 digits of the year (1992 = 92, 2001 = 01) +int status #U returned error status + +int itime +int tm[LEN_TMSTRUCT] +int clktime() + +begin + if (status > 0) + return + + itime = clktime (0) + call brktime (itime, tm) + + dd = TM_MDAY(tm) + mm = TM_MONTH(tm) + yy = mod (TM_YEAR(tm), 100) +end + +# FTMBYT -- move internal file pointer to specified byte + +procedure ftmbyt (iunit, bytno, igneof, status) + +int iunit #I fortran I/O unit number +int bytno #I byte to move to +bool igneof #I ignore moves past EOF? +int status #U output error status + +int nbuff +include "fitsspp.com" + +begin + if (status > 0) + return + + nbuff = bufnum[iunit] + + recnum[nbuff] = (bytno / reclen[nbuff]) + 1 + bytnum[nbuff] = mod ((bytno), reclen[nbuff]) + + if ((bytno >= (filesize[nbuff] * SZB_CHAR)) && !(igneof) ) + status = 107 +end + +# FTMOFF -- offset internal file pointer to specified byte + +procedure ftmoff (iunit, offset, igneof, status) + +int iunit #I fortran I/O unit number +int offset #I number of byte to move +bool igneof #I ignore moves past EOF? +int status #U output error status + +int nbuff,bytno +include "fitsspp.com" + +begin + if (status > 0) + return + + nbuff = bufnum[iunit] + bytno = ((recnum[nbuff]-1) * reclen[nbuff]) + bytnum[nbuff] + offset + + recnum[nbuff] = (bytno / reclen[nbuff]) + 1 + bytnum[nbuff] = mod ((bytno), reclen[nbuff]) + + if ((bytno >= (filesize[nbuff] * SZB_CHAR)) && !(igneof) ) + status = 107 +end + +# FTPI2B -- Write an array of Integer*2 bytes to the output FITS file. +# Does any required translation from internal machine format to FITS. + +procedure ftpi2b (ounit, nvals, incre, i2vals, status) + +int ounit #I fortran I/O unit number +int nvals #I number of pixels in the i2vals array +int incre #I byte increment between values +short i2vals[ARB] #I array of input integer*2 values +int status #U output error status + +int i +int offset + +begin + call miipak(i2vals,i2vals,nvals,TY_SHORT,MII_SHORT) + + if (incre .le. 2) + call ftpbyt(ounit,nvals*2,i2vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-2 + call ftpbyt(ounit,2,i2vals,status) + do i=2,nvals { + call ftmoff(ounit,offset,true,status) + call ftpbyt(ounit,2,i2vals[i],status) + } + } +end + + +# FTPI4B -- Write an array of Integer*4 bytes to the output FITS file. +# Does any required translation from internal machine format to FITS. + +procedure ftpi4b (ounit, nvals, incre, i4vals, status) + +int ounit #I fortran I/O unit number +int nvals #I number of pixels in the i4vals array +int incre #I byte increment between values +int i4vals[ARB] #I array of input integer*4 values +int status #U output error status + +int i +int offset + +begin + call miipak(i4vals,i4vals,nvals,TY_INT,MII_LONG) + + if (incre .le. 4) + call ftpbyt(ounit,nvals*4,i4vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-4 + call ftpbyt(ounit,4,i4vals,status) + do i=2,nvals { + call ftmoff(ounit,offset,true,status) + call ftpbyt(ounit,4,i4vals[i],status) + } + } +end + + +# FTPR4B -- Write an array of Real*4 bytes to the output FITS file. +# Does any required translation from internal machine format to FITS. + +procedure ftpr4b (ounit, nvals, incre, r4vals, status) + +int ounit #I fortran I/O unit number +int nvals #I number of pixels in the r4vals array +int incre #I byte increment between values +real r4vals[ARB] #I array of input real*4 values +int status #U output error status + +int i +int offset + +begin + call miipak(r4vals,r4vals,nvals,TY_REAL,MII_REAL) + + if (incre .le. 4) + call ftpbyt(ounit,nvals*4,r4vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-4 + call ftpbyt(ounit,4,r4vals,status) + do i=2,nvals { + call ftmoff(ounit,offset,true,status) + call ftpbyt(ounit,4,r4vals[i],status) + } + } +end + + +# FTPR8B -- Write an array of Real*8 bytes to the output FITS file. +# Does any required translation from internal machine format to FITS. + +procedure ftpr8b (ounit, nvals, incre, r8vals, status) + +int ounit #I fortran I/O unit number +int nvals #I number of pixels in the r8vals array +int incre #I byte increment between values +double r8vals[ARB] #I array of input real*8 values +int status #U output error status + +int i +int offset + +begin + call miipak(r8vals,r8vals,nvals,TY_DOUBLE,MII_DOUBLE) + + if (incre .le. 8) + call ftpbyt(ounit,nvals*8,r8vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-8 + call ftpbyt(ounit,8,r8vals,status) + do i=2,nvals { + call ftmoff(ounit,offset,true,status) + call ftpbyt(ounit,8,r8vals[i],status) + } + } +end + + +# FTGI2B -- Read an array of Integer*2 bytes from the input FITS file. +# Does any required translation from FITS to internal machine format + +procedure ftgi2b (iunit, nvals, incre, i2vals, status) + +int iunit #I fortran I/O unit number +int nvals #I number of pixels in the i2vals array +int incre #I byte increment between values +short i2vals[ARB] #O array of output integer*2 values +int status #U output error status + +int i +int offset + +begin + if (incre .le. 2) + call ftgbyt(iunit,nvals*2,i2vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-2 + call ftgbyt(iunit,2,i2vals,status) + do i=2,nvals { + call ftmoff(iunit,offset,false,status) + call ftgbyt(iunit,2,i2vals[i],status) + } + } + call miiupk(i2vals,i2vals,nvals,MII_SHORT,TY_SHORT) +end + + +# FTGI4B -- Read an array of Integer*4 bytes from the intput FITS file. +# Does any required translation from FITS to internal machine format + +procedure ftgi4b (iunit, nvals, incre, i4vals, status) + +int iunit #I fortran I/O unit number +int nvals #I number of pixels in the i4vals array +int incre #I byte increment between values +int i4vals[ARB] #O array of output integer*4 values +int status #U output error status + +int i +int offset + +begin + if (incre .le. 4) + call ftgbyt(iunit,nvals*4,i4vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-4 + call ftgbyt(iunit,4,i4vals,status) + do i=2,nvals { + call ftmoff(iunit,offset,false,status) + call ftgbyt(iunit,4,i4vals[i],status) + } + } + call miiupk(i4vals,i4vals,nvals,MII_LONG,TY_INT) +end + + +# FTGR4B -- Read an array of Real*4 bytes from the intput FITS file. +# Does any required translation from FITS to internal machine format + +procedure ftgr4b (iunit, nvals, incre, r4vals, status) + +int iunit #I fortran I/O unit number +int nvals #I number of pixels in the r4vals array +int incre #I byte increment between values +real r4vals[ARB] #O array of output real*4 values +int status #U output error status + +int i +int offset + +begin + if (incre .le. 4) + call ftgbyt(iunit,nvals*4,r4vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-4 + call ftgbyt(iunit,4,r4vals,status) + do i=2,nvals { + call ftmoff(iunit,offset,false,status) + call ftgbyt(iunit,4,r4vals[i],status) + } + } + call miiupk(r4vals,r4vals,nvals,MII_REAL,TY_REAL) +end + + +# FTGR8B -- Read an array of Real*8 bytes from the intput FITS file. +# Does any required translation from FITS to internal machine format + +procedure ftgr8b (iunit, nvals, incre, r8vals, status) + +int iunit #I fortran I/O unit number +int nvals #I number of pixels in the r8vals array +int incre #I byte increment between values +double r8vals[ARB] #O array of output real*8 values +int status #U output error status + +int i +int offset + +begin + if (incre .le. 8) + call ftgbyt(iunit,nvals*8,r8vals,status) + else { +# offset is the number of bytes to move between each value + offset=incre-8 + call ftgbyt(iunit,8,r8vals,status) + do i=2,nvals { + call ftmoff(iunit,offset,false,status) + call ftgbyt(iunit,8,r8vals[i],status) + } + } + call miiupk(r8vals,r8vals,nvals,MII_DOUBLE,TY_DOUBLE) +end + +# FTUPCH -- Convert input string (a Fortran character string) to upper case. + +procedure ftupch (fstr) + +% character fstr*(*) +char sstr[SZ_LINE] + +begin + call f77upk (fstr, sstr, SZ_LINE) + call strupr (sstr) + call f77pak (sstr, fstr, SZ_LINE) +end + +# FTPBYT -- Write a byte sequence to a file. The sequence may begin on any +# byte boundary and may be any number of bytes long. + +procedure ftpbyt (iunit, nbytes, array, status) + +int iunit #I fortran unit number +int nbytes #I number of bytes to be transferred +char array[ARB] #I input data buffer +int status #U output error status + +int fd, nbuff, fpos, hdtype +int bytes_per_record +include "fitsspp.com" + +begin + # Special cases. + if (status > 0) + return + if (nbytes <= 0) { + status = 306 + return + } + + fd = bufid[iunit] + + # Get byte index in file. + nbuff = bufnum[iunit] + bytes_per_record = reclen[nbuff] + hdtype = hdutyp[nbuff] + + # zero indexed byte position in the file + fpos = bytes_per_record * (recnum[nbuff]-1) + bytnum[nbuff] + + # Write the data. + iferr (call ftwrit (fd, array, hdtype, fpos, nbytes, + filesize[nbuff])) { + status = 107 + return + } + + # Update the FITSIO common to track the new file position. + fpos = fpos + nbytes + + recnum[nbuff] = (fpos / bytes_per_record)+1 + bytnum[nbuff] = mod (fpos, bytes_per_record) +end + +# FTGBYT -- Read a byte sequence from a file. The sequence may begin on any +# byte boundary and may be any number of bytes long. An error status is +# returned if less than the requested amount of data is read. + +procedure ftgbyt (iunit, nbytes, array, status) + +int iunit #I fortran unit number +int nbytes #I number of bytes to be transferred +char array[ARB] #O output data buffer +int status #U output error status + +int bytes_per_record +int fd, nbuff, fpos, nb +int ftread() +include "fitsspp.com" + +begin + # Special cases. + if (status > 0 || nbytes == 0) + return + if (nbytes < 0) { + status = 306 + return + } + + fd = bufid[iunit] + + # Get byte index in file. + nbuff = bufnum[iunit] + bytes_per_record = reclen[nbuff] + + # zero indexed byte position in the file + fpos = bytes_per_record * (recnum[nbuff]-1) + bytnum[nbuff] + + # Read the data. + iferr (nb = ftread (fd, array, fpos, nbytes)) { + status = 107 + return + } else if (nb != nbytes) { + status = 107 + } + + # Update the FITSIO common to track the new file position. + fpos = fpos + max (0, nb) + + recnum[nbuff] = (fpos / bytes_per_record)+1 + bytnum[nbuff] = mod (fpos, bytes_per_record) +end + +# FTWRIT -- Write a sequence of bytes to a file at the indicated +# position. The sequence can begin at any byte and can be any number of +# bytes long. +# +# This routine could be implemented more efficiently using fwritep to +# directly access the file buffer for unaligned transfers, but so long +# as most transfers are aligned the following code is as fast as anything. + +procedure ftwrit (fd, ibuf, hdtype, fpos, nbytes, fsize) + +int fd #I file descriptor +char ibuf[ARB] #I data buffer +int hdtype #I type of HDU (1=ASCII table) +int fpos #I starting byte (0 index) in output file +int nbytes #I number of bytes to transfer +int fsize #I current size of the file + +char ch +pointer sp, bp +int start_char, endchr +int nchars, boff, junk, bufsize, nc +errchk getc, seek, write, malloc +char getc() + +bool initialized +char blanks[SZ_FITSREC], zeros[SZ_FITSREC] +data initialized /false/ + +begin + call smark (sp) + + # The first time we are called initialize the empty (blank or + # zero fill) FITS records. + + if (!initialized) { + bufsize = SZ_FITSREC * SZB_CHAR + call malloc (bp, bufsize, TY_CHAR) + + ch = ' ' + call amovkc (ch, Memc[bp], bufsize) + call achtcb (Memc[bp], blanks, bufsize) + call aclrc (zeros, SZ_FITSREC) + + call mfree (bp, TY_CHAR) + initialized = true + } + + # Get index of first and last file chars. + start_char = fpos / SZB_CHAR + 1 + endchr = (fpos+nbytes - 1) / SZB_CHAR + 1 + nchars = endchr - start_char + 1 + boff = mod (fpos, SZB_CHAR) + + # If write starting point is beyond the end of file, + # then insert fill bytes from the current end of file to + # the starting point. + + if (start_char > fsize+1) { + + # Extend the file, using blank or zero fill. Blank fill is + # used for ascii tables (hdtype=1) otherwise zero fill is used. + + call seek (fd, fsize + 1) + while (fsize < start_char) { + nc=min(start_char-fsize, SZ_FITSREC) + if (hdtype == 1) + call write (fd, blanks, nc) + else + call write (fd, zeros, nc) + + fsize = fsize + nc + } + } + + # If things are nicely aligned write data directly to the output file + + if (boff == 0 && mod(nbytes,SZB_CHAR) == 0) { + call seek (fd, start_char) + call write (fd, ibuf, nchars) + + } else { + + # Allocate intermediate buffer. + call salloc (bp, nchars, TY_CHAR) + + # Get any partial chars at ends of sequence. + if (boff > 0) { + call seek (fd, start_char) + junk = getc (fd, Memc[bp]) + } + if (mod (fpos+nbytes, SZB_CHAR) != 0) { + if (endchr > fsize) { + # off end of file, so add correct fill value to last char + if (hdtype == 1) + Memc[bp+nchars-1]=blanks[1] + else + Memc[bp+nchars-1]=0 + } else { + # read existing byte in file, and insert the char + call seek (fd, endchr) + junk = getc (fd, Memc[bp+nchars-1]) + } + } + + # Insert data segment into buffer. + call bytmov (ibuf, 1, Memc[bp], boff + 1, nbytes) + + # Write edited sequence to output file. + call seek (fd, start_char) + call write (fd, Memc[bp], nchars) + } + + fsize=max(fsize,endchr) + + # Now, if file is not a multiple of 2880 bytes long, pad it with fill + + nc=SZ_FITSREC - mod(fsize, SZ_FITSREC) + if (nc .ne. SZ_FITSREC) { + + call seek (fd, fsize + 1) + if (hdtype == 1) + call write (fd, blanks, nc) + else + call write (fd, zeros, nc) + fsize = fsize + nc + } + + call sfree (sp) +end + +# FTREAD -- Read a sequence of bytes from a file at the indicated +# position. The sequence can begin at any byte and can be any number of +# bytes long. +# +# This routine could be implemented more efficiently using freadp to +# directly access the file buffer for unaligned transfers, but so long +# as most transfers are aligned the following code is as fast as anything. + +int procedure ftread (fd, obuf, fpos, nbytes) + +int fd #I file descriptor +char obuf[ARB] #O output buffer +int fpos #I starting byte (zero index) in input file +int nbytes #I number of bytes to transfer + +pointer sp, bp +int start_char, endchr +int nchars, boff, iostat, nout +int read() +errchk read + +begin + # Get index of first and last file chars. + start_char = fpos / SZB_CHAR + 1 + endchr = (fpos+nbytes - 1) / SZB_CHAR + 1 + nchars = endchr - start_char + 1 + boff = mod (fpos, SZB_CHAR) + + # If things are nicely aligned read data directly into the output + # buffer and we are done. + + call seek (fd, start_char) + if (boff == 0 && mod(nbytes,SZB_CHAR) == 0) + return (read (fd, obuf, nchars) * SZB_CHAR) + + # Allocate intermediate buffer. + call smark (sp) + call salloc (bp, nchars, TY_CHAR) + + # Read raw file segment. + iostat = read (fd, Memc[bp], nchars) + if (iostat == EOF) { + call sfree (sp) + return (0) + } + + # Extract and return desired bytes. + nout = min (nbytes, iostat * SZB_CHAR - boff) + call bytmov (Memc[bp], boff + 1, obuf, 1, nout) + + call sfree (sp) + return (nout) +end diff --git a/pkg/tbtables/fitsio/fitssppb/README b/pkg/tbtables/fitsio/fitssppb/README new file mode 100644 index 00000000..a0207701 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/README @@ -0,0 +1,14 @@ +# These routines are part of the FITSIO library and are designed to run in +# the IRAF/SPP environment. +#------------------------------------------------------------------------------ +# This software was prepared by High Energy Astrophysics Science Archive +# Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +# shall not, without prior written permission of the U.S. Government, +# establish a claim to statutory copyright. The Government and others acting +# on its behalf shall have a royalty-free, non-exclusive, irrevocable, +# worldwide license for Government purposes to publish, distribute, +# translate, copy, exhibit, and perform such material. +#------------------------------------------------------------------------------ +# +# In the standard FITSIO distribution, the SPP source files in this +# directory are contained in a single file, fitssppb.x. diff --git a/pkg/tbtables/fitsio/fitssppb/fitsio.h b/pkg/tbtables/fitsio/fitssppb/fitsio.h new file mode 100644 index 00000000..1bb75ded --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fitsio.h @@ -0,0 +1,15 @@ +# This file contains the global defines for the IRAF/SPP version of FITSIO. +# (This is not a C header file) +# SZ_FTTYPE, SZ_FTFORM, and SZ_FTUNIT were changed on 1999 Mar 10 by PEH + +define SZ_FERRTXT 30 # length of FITSIO error message +define SZ_FKEYWORD 8 # length of keyword name string +define SZ_FSTRVAL 70 # length of keyword value string +define SZ_FCOMMENT 48 # length of keyword comment string +define SZ_FLONGCOMM 72 # length of long keyword comment +define SZ_FCARD 80 # length of 'card' record +define SZ_FTTYPE 70 # length of column name string +define SZ_FTFORM 70 # len of col datatype and display format strings +define SZ_FTUNIT 70 # length of column units string +define SZ_FEXTNAME 24 # length of extension name string +define SZ_FTNULL 16 # length of null value string diff --git a/pkg/tbtables/fitsio/fitssppb/fsadef.x b/pkg/tbtables/fitsio/fitssppb/fsadef.x new file mode 100644 index 00000000..c3b4ea82 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsadef.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsadef(ounit,lenrow,nfield,tbcol,tform,nrows,status) + +# Ascii table data DEFinition +# define the structure of the ASCII table data unit + +int ounit # i output file pointer +int lenrow # o length of a table row +int nfield # i number of fields +int tbcol[ARB] # i beginning volumn +char tform[SZ_FTFORM,ARB] # i column datatype +% character*16 ftform(512) +int nrows # i number of rows +int status # o error status +int i + +begin + +do i=1,nfield + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + +call ftadef(ounit,lenrow,nfield,tbcol,ftform,nrows,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsarch.x b/pkg/tbtables/fitsio/fitssppb/fsarch.x new file mode 100644 index 00000000..f5fe6c60 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsarch.x @@ -0,0 +1,9 @@ +include "fitsio.h" + +procedure fsarch(machid) + +int machid # machine ID code + +begin +call ftarch(machid) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsasfm.x b/pkg/tbtables/fitsio/fitssppb/fsasfm.x new file mode 100644 index 00000000..02d00fab --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsasfm.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsasfm(tform,code,width,decims,status) + +char tform[SZ_FTTYPE] +% character ftform*24 +int code,width,decims +int status # o error status + +begin + +call f77pak(tform,ftform,4) +call ftasfm(ftform,code,width,decims,status) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsbdef.x b/pkg/tbtables/fitsio/fitssppb/fsbdef.x new file mode 100644 index 00000000..ba99ad1e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsbdef.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsbdef(ounit,nfield,tform,pcount,nrows,status) + +# Binary table data DEFinition +# define the structure of the binary table data unit + +int ounit # i output file pointer +int nfield # i number of fields +char tform[SZ_FTFORM,ARB] # i column datatype +% character*16 ftform(512) +int pcount # i number of group parame +int nrows # i number of rows +int status # o error status +int i + +begin + +do i=1,nfield + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + +call ftbdef(ounit,nfield,ftform,pcount,nrows,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsbnfm.x b/pkg/tbtables/fitsio/fitssppb/fsbnfm.x new file mode 100644 index 00000000..37ddb13f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsbnfm.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsbnfm(tform,dtype,rcount,width,status) + +# 'Binary Format' +# parse the binary table column format to determine the data +# type and the repeat count (and string width, if it is an ASCII field) + +char tform[SZ_FTFORM] # i column format +% character*16 ftform +int dtype # o datatype code +int rcount # o vector column repeat count +int width # o width of character string +int status # o error status + +begin + +call f77pak(tform ,ftform ,SZ_FTFORM) + +call ftbnfm(ftform,dtype,rcount,width,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsclos.x b/pkg/tbtables/fitsio/fitssppb/fsclos.x new file mode 100644 index 00000000..ddd39b2a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsclos.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsclos(iunit,status) + +# close a FITS file that was previously opened with ftopen or ftinit + +int iunit # i input file pointer +int status # o error status + +begin + +call ftclos(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fscmps.x b/pkg/tbtables/fitsio/fitssppb/fscmps.x new file mode 100644 index 00000000..a3261a41 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fscmps.x @@ -0,0 +1,18 @@ +include "fitsio.h" + +procedure fscmps(templ,strng,casesn,match,exact) + +char templ[SZ_FTTYPE] # i column name template +% character ftemp*24 +char strng[SZ_FTTYPE] # i column name +% character fstrng*24 +bool casesn # i require same case? +bool match # o do the strings match? +bool exact # o is it an exact match? + +begin + +call f77pak(templ,ftemp,SZ_FTTYPE) +call f77pak(strng,fstrng,SZ_FTTYPE) +call ftcmps(ftemp,fstrng,casesn,match,exact) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fscmsg.x b/pkg/tbtables/fitsio/fitssppb/fscmsg.x new file mode 100644 index 00000000..d6f0c292 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fscmsg.x @@ -0,0 +1,11 @@ +include "fitsio.h" + +procedure fscmsg + +# clear the FITSIO error stack + +begin + + +call ftcmsg +end diff --git a/pkg/tbtables/fitsio/fitssppb/fscopy.x b/pkg/tbtables/fitsio/fitssppb/fscopy.x new file mode 100644 index 00000000..aa508f34 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fscopy.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fscopy(iunit,ounit,moreky,status) + +# copies the CHDU from IUNIT to the CHDU of OUNIT. +# This will also reserve space in the header for MOREKY keywords +# if MOREKY > 0. + +int iunit # i input file pointer +int ounit # i output file pointer +int moreky # i how many more keywords +int status # o error status + +begin + +call ftcopy(iunit,ounit,moreky,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fscpdt.x b/pkg/tbtables/fitsio/fitssppb/fscpdt.x new file mode 100644 index 00000000..2da715ff --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fscpdt.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fscpdt(iunit,ounit,status) + +# copies the data from IUNIT to the CHDU of OUNIT. + + +int iunit # i input file pointer +int ounit # i output file pointer +int status # o error status + +begin + +call ftcpdt(iunit,ounit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fscrhd.x b/pkg/tbtables/fitsio/fitssppb/fscrhd.x new file mode 100644 index 00000000..69ae8b9d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fscrhd.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fscrhd(iunit,status) + +# 'CReate Header Data unit' +# create, initialize, and move the i/o pointer to a new extension at +# the end of the FITS file. + +int iunit # i input file pointer +int status # o error status + +begin + +call ftcrhd(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdcol.x b/pkg/tbtables/fitsio/fitssppb/fsdcol.x new file mode 100644 index 00000000..25aa36f7 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdcol.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsdcol(ounit,colnum,status) + +# delete column in a table + +int ounit # i output file pointer +int colnum # i column to be deleted +int status # o error status + +begin + +call ftdcol(ounit,colnum,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsddef.x b/pkg/tbtables/fitsio/fitssppb/fsddef.x new file mode 100644 index 00000000..c07bb65a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsddef.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsddef(ounit,bytlen,status) + +# Data DEFinition +# re-define the length of the data unit +# this simply redefines the start of the next HDU + +int ounit # i output file pointer +int bytlen # i length in bytes +int status # o error status + +begin + +call ftddef(ounit,bytlen,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdelt.x b/pkg/tbtables/fitsio/fitssppb/fsdelt.x new file mode 100644 index 00000000..eae6e2f5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdelt.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsdelt(iunit,status) + +# close and delete a FITS file that was previously opened with ftopen or ftinit + +int iunit # i input file pointer +int status # o error status + +begin + +call ftdelt(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdhdu.x b/pkg/tbtables/fitsio/fitssppb/fsdhdu.x new file mode 100644 index 00000000..cb62ad45 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdhdu.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsdhdu(iunit,hdutyp,status) + +# delete the CHDU + +int iunit # i input file pointer +int hdutyp # o type of the new CHDU +int status # o error status + +begin + +call ftdhdu(iunit,hdutyp,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdkey.x b/pkg/tbtables/fitsio/fitssppb/fsdkey.x new file mode 100644 index 00000000..5b7dc487 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdkey.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsdkey(iunit,keywrd,status) + +# delete a header keyword + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftdkey(iunit,fkeywr,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdrec.x b/pkg/tbtables/fitsio/fitssppb/fsdrec.x new file mode 100644 index 00000000..fc535fc8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdrec.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsdrec(iunit,pos,status) + +# delete a header keyword + +int iunit # i input file pointer +int pos # i position of the keyword to be deleted +int status # o error status + +begin + +call ftdrec(iunit,pos,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdrow.x b/pkg/tbtables/fitsio/fitssppb/fsdrow.x new file mode 100644 index 00000000..dd926469 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdrow.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsdrow(ounit,frow,nrows,status) + +# delete rows in a table + +int ounit # i output file pointer +int frow # first row to delete +int nrows # number of rows +int status # o error status + +begin + +call ftdrow(ounit,frow,nrows,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdsum.x b/pkg/tbtables/fitsio/fitssppb/fsdsum.x new file mode 100644 index 00000000..10f43f2e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdsum.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsdsum(chksum,comp,sum) + +char chksum[16] +bool comp +double sum +% character fsum*16 + +begin + +call f77pak(chksum,fsum,16) +call ftdsum(fsum,comp,sum) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsdtyp.x b/pkg/tbtables/fitsio/fitssppb/fsdtyp.x new file mode 100644 index 00000000..da2ee7f7 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsdtyp.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fsdtyp(value,dtype,status) + +# determine datatype of a FITS value field +# This assumes value field conforms to FITS standards and may not +# detect all invalid formats. +# value c input value field from FITS header record only, +# (usually the value field is in columns 11-30 of record) +# The value string is left justified. +# dtype c output type (C,L,I,F) for Character string, Logical, +# Integer, Floating point, respectively + +char value[SZ_FSTRVAL] # i data value +% character*70 fvalue +char dtype # o datatype code +% character*1 fdtype +int status # o error status +char sdtype[1] +begin + +call f77pak(value,fvalue,SZ_FSTRVAL) +call ftdtyp(fvalue,fdtype,status) +call f77upk(fdtype,sdtype,1) +dtype=sdtype[1] +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsesum.x b/pkg/tbtables/fitsio/fitssppb/fsesum.x new file mode 100644 index 00000000..4ed10305 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsesum.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsesum(sum,comp,chksum) + +double sum +bool comp +char chksum[16] +% character fsum*16 + +begin + +call ftesum(sum,comp,fsum) +call f77upk(fsum,chksum,16) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsfiou.x b/pkg/tbtables/fitsio/fitssppb/fsfiou.x new file mode 100644 index 00000000..e87cbf50 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsfiou.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsfiou(iounit,status) + +# Returns an unused I/O unit number which may then be used as input +# to the fsinit or fsopen procedures. + +int iounit # i I/O unit number +int status # o error status + +begin +call ftfiou(iounit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg2db.x b/pkg/tbtables/fitsio/fitssppb/fsg2db.x new file mode 100644 index 00000000..ee4636eb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg2db.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsg2db(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) + +# Read a 2-d image of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +int nulval # i value for undefined pi +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg2db(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg2dd.x b/pkg/tbtables/fitsio/fitssppb/fsg2dd.x new file mode 100644 index 00000000..989831c9 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg2dd.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsg2dd(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) + +# Read a 2-d image of r*8 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +double nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +double array[ARB] # i array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg2dd(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg2de.x b/pkg/tbtables/fitsio/fitssppb/fsg2de.x new file mode 100644 index 00000000..a8ec666e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg2de.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsg2de(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) + +# Read a 2-d image of real values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +real nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +real array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg2de(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg2di.x b/pkg/tbtables/fitsio/fitssppb/fsg2di.x new file mode 100644 index 00000000..5f47a303 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg2di.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsg2di(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) + +# Read a 2-d image of i*2 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +short nulval # i value for undefined pi +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +short array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg2di(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg2dj.x b/pkg/tbtables/fitsio/fitssppb/fsg2dj.x new file mode 100644 index 00000000..29d7ce3f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg2dj.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsg2dj(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) + +# Read a 2-d image of i*4 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +int nulval # i value for undefined pi +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg2dj(ounit,group,nulval,dim1,nx,ny,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg3db.x b/pkg/tbtables/fitsio/fitssppb/fsg3db.x new file mode 100644 index 00000000..be6562a6 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg3db.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) + +# Read a 3-d cube of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +int nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg3dd.x b/pkg/tbtables/fitsio/fitssppb/fsg3dd.x new file mode 100644 index 00000000..b08eb765 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg3dd.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) + +# Read a 3-d cube of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +double nulval # i value for undefined pi +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +double array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg3de.x b/pkg/tbtables/fitsio/fitssppb/fsg3de.x new file mode 100644 index 00000000..af302158 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg3de.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) + +# Read a 3-d cube of real values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +real nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +real array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg3di.x b/pkg/tbtables/fitsio/fitssppb/fsg3di.x new file mode 100644 index 00000000..3e2fc780 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg3di.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) + +# Read a 3-d cube of i*2 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +short nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +short array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsg3dj.x b/pkg/tbtables/fitsio/fitssppb/fsg3dj.x new file mode 100644 index 00000000..857a7a8e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsg3dj.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) + +# Read a 3-d cube of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int ounit # i output file pointer +int group # i group number +int nulval # i value for undefined pixels +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz, + array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgabc.x b/pkg/tbtables/fitsio/fitssppb/fsgabc.x new file mode 100644 index 00000000..430fed56 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgabc.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgabc(nfield,tform,space,rowlen,tbcol,status) + +# Get ASCII table Beginning Columns +# determine the byte offset of the beginning of each field of a +# ASCII table, and the total width of the table + +int nfield # i number of fields +char tform[SZ_FTFORM,ARB] # i column datatypes +% character*16 ftform(512) +int space # i no. spaces between col +int rowlen # o length of a table row +int tbcol[ARB] # o starting column positions +int status # o error status +int i + +begin + +do i=1,nfield + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + +call ftgabc(nfield,ftform,space,rowlen,tbcol,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgacl.x b/pkg/tbtables/fitsio/fitssppb/fsgacl.x new file mode 100644 index 00000000..09db30a0 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgacl.x @@ -0,0 +1,33 @@ +include "fitsio.h" + +procedure fsgacl(iunit,colnum,ttype,tbcol,tunit,tform, + tscal,tzero,tnull,tdisp,status) + +# Get information about an Ascii table CoLumn +# returns the parameters which define the column + +int iunit # i input file pointer +int colnum # i column number +char ttype[SZ_FTTYPE] # o column name +int tbcol # o starting column position in the row +char tunit[SZ_FTUNIT] # o physical units of the column +char tform[SZ_FTFORM] # o FITS data format of the column +double tscal # o scaling factor +double tzero # o scaling zero point +char tnull[SZ_FTNULL] # o string used to represent null values +char tdisp[SZ_FTFORM] # o Fortran display format +int status # o error status +% character fttype*24, ftunit*24,ftform*16,ftnull*16,ftdisp*16 + +begin + +call ftgacl(iunit,colnum,fttype,tbcol,ftunit,ftform, + tscal,tzero,ftnull,ftdisp,status) + +call f77upk(fttype,ttype,SZ_FTTYPE) +call f77upk(ftunit,tunit,SZ_FTUNIT) +call f77upk(ftform,tform,SZ_FTFORM) +call f77upk(ftnull,tnull,SZ_FTNULL) +call f77upk(ftdisp,tdisp,SZ_FTFORM) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgbcl.x b/pkg/tbtables/fitsio/fitssppb/fsgbcl.x new file mode 100644 index 00000000..b6281f49 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgbcl.x @@ -0,0 +1,32 @@ +include "fitsio.h" + +procedure fsgbcl(iunit,colnum,ttype,tunit,dtype,rcount, + tscal,tzero,tnull,tdisp,status) + +# Get information about a Binary table CoLumn +# returns the parameters which define the column + +int iunit # i input file pointer +int colnum # i column number +char ttype[SZ_FTTYPE] # o column name +char tunit[SZ_FTUNIT] # o physical units of the column +char dtype[SZ_FTFORM] # o datatype code +int rcount # o repeat count for vector column +double tscal # o scaling factor +double tzero # o scaling zero point +int tnull # o integer used to represent null values +char tdisp[SZ_FTFORM] # o Fortran display format +int status # o error status +% character fttype*24, ftunit*24, ftdisp*16, fdtype*16 + +begin + +call ftgbcl(iunit,colnum,fttype,ftunit,fdtype,rcount, + tscal,tzero,tnull,ftdisp,status) + +call f77upk(fttype,ttype,SZ_FTTYPE) +call f77upk(ftunit,tunit,SZ_FTUNIT) +call f77upk(ftdisp,tdisp,SZ_FTFORM) +call f77upk(fdtype,dtype,SZ_FTFORM) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfb.x b/pkg/tbtables/fitsio/fitssppb/fsgcfb.x new file mode 100644 index 00000000..d61d749a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfb.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfb(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of byte values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfb(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfc.x b/pkg/tbtables/fitsio/fitssppb/fsgcfc.x new file mode 100644 index 00000000..9bf07063 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfc.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfc(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of complex values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfc(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfd.x b/pkg/tbtables/fitsio/fitssppb/fsgcfd.x new file mode 100644 index 00000000..3c2b846e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfd(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of r*8 values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfd(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfe.x b/pkg/tbtables/fitsio/fitssppb/fsgcfe.x new file mode 100644 index 00000000..8e24508b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfe.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfe(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of R*4 values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfe(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfi.x b/pkg/tbtables/fitsio/fitssppb/fsgcfi.x new file mode 100644 index 00000000..566a60d8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfi.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfi(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of I*2 values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfi(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfj.x b/pkg/tbtables/fitsio/fitssppb/fsgcfj.x new file mode 100644 index 00000000..cfc7da3f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfj.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcfj(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of I*4 values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfj(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfl.x b/pkg/tbtables/fitsio/fitssppb/fsgcfl.x new file mode 100644 index 00000000..ce8384ef --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfl.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgcfl(iunit,colnum,frow,felem,nelem,lray, + flgval,anynul,status) + +# read an array of logical values from a specified column of the table. +# The binary table column being read from must have datatype 'L' +# and no datatype conversion will be perform if it is not. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +bool lray[ARB] # o logical array +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfl(iunit,colnum,frow,felem,nelem,lray, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfm.x b/pkg/tbtables/fitsio/fitssppb/fsgcfm.x new file mode 100644 index 00000000..25447f55 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfm.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fsgcfm(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) + +# read an array of double precision complex values from a specified +# column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcfm(iunit,colnum,frow,felem,nelem,array, + flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcfs.x b/pkg/tbtables/fitsio/fitssppb/fsgcfs.x new file mode 100644 index 00000000..a9f81e22 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcfs.x @@ -0,0 +1,38 @@ +include "fitsio.h" + +procedure fsgcfs(iunit,colnum,frow,felem,nelem,array,dim1, + flgval,anynul,status) + +# read an array of string values from a specified column of the table. +# Any undefined pixels will be have the corresponding value of FLGVAL +# set equal to .true., and ANYNUL will be set equal to .true. if +# any pixels are undefined. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +char array[dim1,ARB] # o array of values +% character farray*256 +int dim1 # i size of 1st dimension of 2D character string array +bool flgval[ARB] # o is corresponding value undefined? +bool anynul # o any null values? +int status # o error status +int i +int elem +bool null + +begin + +anynul=false +elem=felem +do i=1,nelem { + call ftgcfs(iunit,colnum,frow,elem,1,farray,flgval(i),null,status) + if (null) + anynul=true + + call f77upk(farray,array(1,i),dim1) + elem=elem+1 + } +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcks.x b/pkg/tbtables/fitsio/fitssppb/fsgcks.x new file mode 100644 index 00000000..3085ce58 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcks.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsgcks(iunit,datasum,hdusum,status) + +int iunit +double datasum +double hdusum +int status # o error status + +begin + +call ftgcks(iunit,datasum,hdusum,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcl.x b/pkg/tbtables/fitsio/fitssppb/fsgcl.x new file mode 100644 index 00000000..3d3132c2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgcl(iunit,colnum,frow,felem,nelem,lray,status) + +# read an array of logical values from a specified column of the table. +# The binary table column being read from must have datatype 'L' +# and no datatype conversion will be perform if it is not. +# This routine ignores any undefined values in the logical array. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +bool lray[ARB] # o logical array +int status # o error status + +begin + +call ftgcl(iunit,colnum,frow,felem,nelem,lray,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcnn.x b/pkg/tbtables/fitsio/fitssppb/fsgcnn.x new file mode 100644 index 00000000..bd31a11a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcnn.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgcnn(iunit,exact,colnam,realnm,colnum,status) + +# determine the column number corresponding to an input column name. + +int iunit # i input file pointer +bool exact # i require same case? +char colnam[SZ_FTTYPE] # i column name template +% character fcolna*24 +char realnm[SZ_FTTYPE] # o column name +% character frealn*24 +int colnum # o column number +int status # o error status + +begin + +call f77pak(colnam,fcolna,SZ_FTTYPE) +call ftgcnn(iunit,exact,fcolna,frealn,colnum,status) +call f77upk(frealn,realnm,SZ_FTTYPE) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcno.x b/pkg/tbtables/fitsio/fitssppb/fsgcno.x new file mode 100644 index 00000000..a69e0ef1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcno.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsgcno(iunit,exact,colnam,colnum,status) + +# determine the column number corresponding to an input column name. +# this assumes that the first 16 characters uniquely define the name + +int iunit # i input file pointer +bool exact # i require same case? +char colnam[SZ_FTTYPE] # column name +% character fcolna*24 +int colnum # o column number +int status # o error status + +begin + +call f77pak(colnam,fcolna,SZ_FTTYPE) + +call ftgcno(iunit,exact,fcolna,colnum,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcrd.x b/pkg/tbtables/fitsio/fitssppb/fsgcrd.x new file mode 100644 index 00000000..e2ceb9e5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcrd.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgcrd(iunit,keywrd,card,status) + +# Read the 80 character card image of a specified header keyword record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char card[SZ_FCARD] # o 80-char header record +% character fcard*80 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgcrd(iunit,fkeywr,fcard,status) + +call f77upk(fcard ,card ,SZ_FCARD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvb.x b/pkg/tbtables/fitsio/fitssppb/fsgcvb.x new file mode 100644 index 00000000..21297842 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvb.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcvb(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of byte values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int nulval # i value for undefined pixels +int array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvb(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvc.x b/pkg/tbtables/fitsio/fitssppb/fsgcvc.x new file mode 100644 index 00000000..1a804e49 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvc.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcvc(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of complex values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real nulval[2] # i value for undefined pixels +real array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvc(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvd.x b/pkg/tbtables/fitsio/fitssppb/fsgcvd.x new file mode 100644 index 00000000..860363d7 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcvd(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of r*8 values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double nulval # i value for undefined pixels +double array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvd(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcve.x b/pkg/tbtables/fitsio/fitssppb/fsgcve.x new file mode 100644 index 00000000..3753b0f1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcve.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcve(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of R*4 values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real nulval # i value for undefined pixels +real array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcve(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvi.x b/pkg/tbtables/fitsio/fitssppb/fsgcvi.x new file mode 100644 index 00000000..66fd4bf8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvi.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcvi(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of I*2 values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +short nulval # i value for undefined pixels +short array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvi(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvj.x b/pkg/tbtables/fitsio/fitssppb/fsgcvj.x new file mode 100644 index 00000000..8cab67a2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvj.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgcvj(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of I*4 values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int nulval # i value for undefined pixels +int array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvj(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvm.x b/pkg/tbtables/fitsio/fitssppb/fsgcvm.x new file mode 100644 index 00000000..a787faf0 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvm.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fsgcvm(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) + +# read an array of double precision complex values from a specified +# column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=0, in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double nulval[2] # i value for undefined pixels +double array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgcvm(iunit,colnum,frow,felem,nelem,nulval,array, + anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcvs.x b/pkg/tbtables/fitsio/fitssppb/fsgcvs.x new file mode 100644 index 00000000..b5bd9c05 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcvs.x @@ -0,0 +1,41 @@ +include "fitsio.h" + +procedure fsgcvs(iunit,colnum,frow,felem,nelem,nulval,array,dim1,anynul, + status) + +# read an array of string values from a specified column of the table. +# Any undefined pixels will be set equal to the value of NULVAL, +# unless NULVAL=' ', in which case no checks for undefined pixels +# will be made. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +char nulval[SZ_FTNULL] # i value for undefined pixels +% character fnulva*16 +char array[dim1,ARB] # o array of values +% character farray*256 +int dim1 # i size of 1st dimension of 2D character string array +bool anynul # o any null values returned? +int status # o error status +int i +int elem +bool null + +begin + +call f77pak(nulval,fnulva,SZ_FTNULL) + +anynul=false +elem=felem +do i=1,nelem { + call ftgcvs(iunit,colnum,frow,elem,1,fnulva,farray,null,status) + if (null) + anynul=true + + call f77upk(farray,array(1,i),dim1) + elem=elem+1 + } +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcx.x b/pkg/tbtables/fitsio/fitssppb/fsgcx.x new file mode 100644 index 00000000..8cedb3f3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcx.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgcx(iunit,colnum,frow,fbit,nbit,lray,status) + +# read an array of logical values from a specified bit or byte +# column of the binary table. A logical .true. value is returned +# if the corresponding bit is 1, and a logical .false. value is +# returned if the bit is 0. +# The binary table column being read from must have datatype 'B' +# or 'X'. This routine ignores any undefined values in the 'B' array. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int fbit # i first bit +int nbit # i number of bits +bool lray[ARB] # o logical array +int status # o error status + +begin + +call ftgcx(iunit,colnum,frow,fbit,nbit,lray,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcxd.x b/pkg/tbtables/fitsio/fitssppb/fsgcxd.x new file mode 100644 index 00000000..624143d4 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcxd.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsgcxd(iunit,colnum,frow,nrow,fbit,nbit,dvalue,status) + +# read consecutive bits from 'X' or 'B' column as an unsigned integer + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int nrow # i number of rows +int fbit # i first bit +int nbit # i number of bits +double dvalue[ARB] # o double integer array +int status # o error status + +begin + +call ftgcxd(iunit,colnum,frow,nrow,fbit,nbit,dvalue,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcxi.x b/pkg/tbtables/fitsio/fitssppb/fsgcxi.x new file mode 100644 index 00000000..319146f1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcxi.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsgcxi(iunit,colnum,frow,nrow,fbit,nbit,ivalue,status) + +# read consecutive bits from 'X' or 'B' column as an unsigned integer + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int nrow # i number of rows +int fbit # i first bit +int nbit # i number of bits +short ivalue[ARB] # o short integer array +int status # o error status + +begin + +call ftgcxi(iunit,colnum,frow,nrow,fbit,nbit,ivalue,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgcxj.x b/pkg/tbtables/fitsio/fitssppb/fsgcxj.x new file mode 100644 index 00000000..a38400bf --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgcxj.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsgcxj(iunit,colnum,frow,nrow,fbit,nbit,jvalue,status) + +# read consecutive bits from 'X' or 'B' column as an unsigned integer + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int nrow # i number of rows +int fbit # i first bit +int nbit # i number of bits +int jvalue[ARB] # o integer array +int status # o error status + +begin + +call ftgcxj(iunit,colnum,frow,nrow,fbit,nbit,jvalue,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgdes.x b/pkg/tbtables/fitsio/fitssppb/fsgdes.x new file mode 100644 index 00000000..c180304d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgdes.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsgdes(iunit,colnum,rownum,nelem,offset,status) + +# read the descriptor values from a binary table. This is only +# used for column which have TFORMn = 'P', i.e., for variable +# length arrays. + +int iunit # i input file pointer +int colnum # i column number +int rownum # i row number +int nelem # o number of elements +int offset # o offset +int status # o error status + +begin + +call ftgdes(iunit,colnum,rownum,nelem,offset,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgerr.x b/pkg/tbtables/fitsio/fitssppb/fsgerr.x new file mode 100644 index 00000000..039454c8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgerr.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsgerr(errnum,text) + +# Return a descriptive error message corresponding to the error number + +int errnum # i error number +char text[SZ_FERRTXT] # i text string +% character ftext*30 + +begin + +call ftgerr(errnum,ftext) + +call f77upk(ftext ,text ,SZ_FERRTXT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsggpb.x b/pkg/tbtables/fitsio/fitssppb/fsggpb.x new file mode 100644 index 00000000..763d2533 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsggpb.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsggpb(iunit,group,fparm,nparm,array,status) + +# Read an array of group parameter values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +int array[ARB] # o array of values +int status # o error status + +begin + +call ftggpb(iunit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsggpd.x b/pkg/tbtables/fitsio/fitssppb/fsggpd.x new file mode 100644 index 00000000..fea28527 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsggpd.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsggpd(iunit,group,fparm,nparm,array,status) + +# Read an array of group parameter values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +double array[ARB] # i array of values +int status # o error status + +begin + +call ftggpd(iunit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsggpe.x b/pkg/tbtables/fitsio/fitssppb/fsggpe.x new file mode 100644 index 00000000..9ca8b786 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsggpe.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsggpe(iunit,group,fparm,nparm,array,status) + +# Read an array of group parameter values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +real array[ARB] # i array of values +int status # o error status + +begin + +call ftggpe(iunit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsggpi.x b/pkg/tbtables/fitsio/fitssppb/fsggpi.x new file mode 100644 index 00000000..4ac34cdf --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsggpi.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsggpi(iunit,group,fparm,nparm,array,status) + +# Read an array of group parameter values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +short array[ARB] # o array of values +int status # o error status + +begin + +call ftggpi(iunit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsggpj.x b/pkg/tbtables/fitsio/fitssppb/fsggpj.x new file mode 100644 index 00000000..f5e91a34 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsggpj.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsggpj(iunit,group,fparm,nparm,array,status) + +# Read an array of group parameter values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +int array[ARB] # i array of values +int status # o error status + +begin + +call ftggpj(iunit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghad.x b/pkg/tbtables/fitsio/fitssppb/fsghad.x new file mode 100644 index 00000000..5511af26 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghad.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsghad(iunit,curadd,nxtadd) + +# delete the CHDU + +int iunit # i input file pointer +int curadd # o starting byte address of the CHDU +int nxtadd # o starting byte address of the next HDU + +begin + +call ftghad(iunit,curadd,nxtadd) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghbn.x b/pkg/tbtables/fitsio/fitssppb/fsghbn.x new file mode 100644 index 00000000..b5122129 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghbn.x @@ -0,0 +1,38 @@ +include "fitsio.h" + +procedure fsghbn(iunit,maxfld,nrows,nfield,ttype,tform, + tunit,extnam,pcount,status) + +# read required standard header keywords from a binary table extension + +int iunit # i input file pointer +int maxfld # i max. number of fields +int nrows # o number of rows +int nfield # o number of fields +char ttype[SZ_FTTYPE,ARB] # o column name +% character*24 fttype(512) +char tform[SZ_FTFORM,ARB] # o column datatype +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # o column units +% character*16 ftunit(512) +char extnam +% character fextna*48 +int pcount # o size of 'heap' +int status # o error status +int i +int n + +begin + +call ftghbn(iunit,maxfld,nrows,nfield,fttype,ftform, + ftunit,fextna,pcount,status) +n=min(maxfld,nfield) +do i = 1, n + { call f77upk(fttype(i) ,ttype(1,i),SZ_FTTYPE) + call f77upk(ftform(i) ,tform(1,i),SZ_FTFORM) + call f77upk(ftunit(i) ,tunit(1,i),SZ_FTUNIT) + } + +call f77upk(fextna ,extnam,SZ_FEXTNAME) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghdn.x b/pkg/tbtables/fitsio/fitssppb/fsghdn.x new file mode 100644 index 00000000..9748b924 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghdn.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsghdn(iunit,hdunum) + +# return the number of the current header data unit. The +# first HDU (the primary array) is number 1. + +int iunit # i input file pointer +int hdunum # o returned number of the current HDU + +begin + +call ftghdn(iunit,hdunum) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghpr.x b/pkg/tbtables/fitsio/fitssppb/fsghpr.x new file mode 100644 index 00000000..ed0bf343 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghpr.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsghpr(iunit,maxdim,simple,bitpix,naxis,naxes, + pcount,gcount,extend,status) + +# get the required primary header or image extension keywords + +int iunit # i input file pointer +int maxdim # i max. number of dimensions +bool simple # o simple FITS file? +int bitpix # o bits per pixel +int naxis # o number of axes +int naxes[ARB] # o dimension of each axis +int pcount # o no. of group parameters +int gcount # o no. of groups +bool extend # o EXTEND keyword = TRUE? +int status # o error status + +begin + +call ftghpr(iunit,maxdim,simple,bitpix,naxis,naxes, + pcount,gcount,extend,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghps.x b/pkg/tbtables/fitsio/fitssppb/fsghps.x new file mode 100644 index 00000000..1d431117 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghps.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsghps(ounit,nexist,keyno,status) + +# return the current position in the header + +int ounit # i output file pointer +int nexist # o how many exist? +int keyno # o position of the last keyword that was read + 1 +int status # o error status + +begin + +call ftghps(ounit,nexist,keyno,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghsp.x b/pkg/tbtables/fitsio/fitssppb/fsghsp.x new file mode 100644 index 00000000..916efd3c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghsp.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsghsp(ounit,nexist,nmore,status) + +# Get Header SPace +# return the number of additional keywords that will fit in the header + +int ounit # i output file pointer +int nexist # o how many exist? +int nmore # o this many more will fit +int status # o error status + +begin + +call ftghsp(ounit,nexist,nmore,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsghtb.x b/pkg/tbtables/fitsio/fitssppb/fsghtb.x new file mode 100644 index 00000000..3d769a12 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsghtb.x @@ -0,0 +1,40 @@ +include "fitsio.h" + +procedure fsghtb(iunit,maxfld,ncols,nrows,nfield,ttype, + tbcol,tform,tunit,extnam,status) + +# read required standard header keywords from an ASCII table extension + +int iunit # i input file pointer +int maxfld # i max. number of fields to return +int ncols # o number of columns +int nrows # o number of rows +int nfield # o number of fields +char ttype[SZ_FTTYPE,ARB] # o column name +% character*24 fttype(512) +int tbcol[ARB] # o starting column position +char tform[SZ_FTFORM,ARB] # i column data format +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # i column units +% character*24 ftunit(512) +char extnam[SZ_FEXTNAME] # i extension name +% character fextna*24 +int status # o error status +int i +int n + +begin + +call ftghtb(iunit,maxfld,ncols,nrows,nfield,fttype, + tbcol,ftform,ftunit,fextna,status) + +n=min(maxfld,nfield) +do i = 1, n + { call f77upk(fttype(i) ,ttype(1,i),SZ_FTTYPE) + call f77upk(ftform(i) ,tform(1,i),SZ_FTFORM) + call f77upk(ftunit(i) ,tunit(1,i),SZ_FTUNIT) + } + +call f77upk(fextna ,extnam,SZ_FEXTNAME) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgics.x b/pkg/tbtables/fitsio/fitssppb/fsgics.x new file mode 100644 index 00000000..1453e054 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgics.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,coord,status) + +int iunit +double xrval,yrval,xrpix,yrpix,xinc,yinc,rot +char coord[4] +% character fcoord*4 +int status # o error status + +begin + +call ftgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,fcoord,status) +call f77upk(fcoord,coord,4) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgiou.x b/pkg/tbtables/fitsio/fitssppb/fsgiou.x new file mode 100644 index 00000000..eee38391 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgiou.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsgiou(iounit,status) + +# Returns an unused I/O unit number which may then be used as input +# to the fsinit or fsopen procedures. + +int iounit # o unused I/O unit number +int status # o error status + +begin +call ftgiou(iounit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkey.x b/pkg/tbtables/fitsio/fitssppb/fsgkey.x new file mode 100644 index 00000000..a5f2cd52 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkey.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgkey(iunit,keywrd,value,comm,status) + +# Read value and comment of a header keyword from the keyword buffer + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char value[SZ_FSTRVAL] # o keyword value +% character fvalue*70 +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkey(iunit,fkeywr,fvalue,fcomm,status) + +call f77upk(fvalue ,value ,SZ_FSTRVAL) +call f77upk(fcomm ,comm ,SZ_FCOMMENT) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgknd.x b/pkg/tbtables/fitsio/fitssppb/fsgknd.x new file mode 100644 index 00000000..8a34bb21 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgknd.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgknd(iunit,keywrd,nstart,nmax,dval,nfound,status) + +# read an array of real*8 values from header records + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nmax # i max. number of keyword +double dval[ARB] # o real*8 value +int nfound # o no. of keywords found +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgknd(iunit,fkeywr,nstart,nmax,dval,nfound,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkne.x b/pkg/tbtables/fitsio/fitssppb/fsgkne.x new file mode 100644 index 00000000..b71ba65b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkne.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgkne(iunit,keywrd,nstart,nmax,rval,nfound,status) + +# read an array of real*4 values from header records + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nmax # i max. number of keyword +real rval[ARB] # o real*4 values +int nfound # o no. of keywords found +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkne(iunit,fkeywr,nstart,nmax,rval,nfound,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgknj.x b/pkg/tbtables/fitsio/fitssppb/fsgknj.x new file mode 100644 index 00000000..7f95bc07 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgknj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgknj(iunit,keywrd,nstart,nmax,intval,nfound,status) + +# read an array of integer values from header records + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nmax # i max. number of keyword +int intval[ARB] # o integer values +int nfound # o no. of keywords found +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgknj(iunit,fkeywr,nstart,nmax,intval,nfound,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgknl.x b/pkg/tbtables/fitsio/fitssppb/fsgknl.x new file mode 100644 index 00000000..929c1173 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgknl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsgknl(iunit,keywrd,nstart,nmax,logval,nfound,status) + +# read an array of logical values from header records + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nmax # i max. number of keyword +bool logval[ARB] # o logical values +int nfound # o no. of keywords found +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgknl(iunit,fkeywr,nstart,nmax,logval,nfound,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkns.x b/pkg/tbtables/fitsio/fitssppb/fsgkns.x new file mode 100644 index 00000000..b2ad098a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkns.x @@ -0,0 +1,49 @@ +include "fitsio.h" + +procedure fsgkns(iunit,keywrd,nstart,nmax,strval,nfound,status) + +# read an array of character string values from header records + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nmax # i max. number of keyword +char strval[SZ_FSTRVAL,ARB] # o string value +% character*70 fstrva +% character*48 comm +% character*8 keynam + +int nfound # o no. of keywords found +int status # o error status +int i +int j + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +nfound=0 +j=nstart + +do i=1,nmax { + call ftkeyn(fkeywr,j,keynam,status) + if (status > 0) + go to 10 + + call ftgkys(iunit,keynam,fstrva,comm,status) + + if (status <= 0) { + nfound=i + call f77upk(fstrva,strval(1,i),SZ_FSTRVAL) + + } else if (status == 202) { +# ignore keyword not found error + status=0 + } + j=j+1 + } + +10 + j=0 +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkyd.x b/pkg/tbtables/fitsio/fitssppb/fsgkyd.x new file mode 100644 index 00000000..96ae59a3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkyd.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsgkyd(iunit,keywrd,dval,comm,status) + +# read a double precision value and comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # o real*8 value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkyd(iunit,fkeywr,dval,fcomm,status) + +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkye.x b/pkg/tbtables/fitsio/fitssppb/fsgkye.x new file mode 100644 index 00000000..8442e96b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkye.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsgkye(iunit,keywrd,rval,comm,status) + +# read a real*4 value and the comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # o real*4 value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkye(iunit,fkeywr,rval,fcomm,status) + +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkyj.x b/pkg/tbtables/fitsio/fitssppb/fsgkyj.x new file mode 100644 index 00000000..2260b3d5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkyj.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsgkyj(iunit,keywrd,intval,comm,status) + +# read an integer value and the comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # o integer value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkyj(iunit,fkeywr,intval,fcomm,status) + +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkyl.x b/pkg/tbtables/fitsio/fitssppb/fsgkyl.x new file mode 100644 index 00000000..9ba9aea4 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkyl.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsgkyl(iunit,keywrd,logval,comm,status) + +# read a logical value and the comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +bool logval # o logical value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkyl(iunit,fkeywr,logval,fcomm,status) + +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkyn.x b/pkg/tbtables/fitsio/fitssppb/fsgkyn.x new file mode 100644 index 00000000..7f52b7e4 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkyn.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fsgkyn(iunit,nkey,keywrd,value,comm,status) + +# Read the name, value, and comment of the NKEYth header record +# This routine is useful for reading the entire header, one +# record at a time. + +int iunit # i input file pointer +int nkey # i number of keywords +char keywrd[SZ_FKEYWORD] # o keyword name +% character fkeywr*8 +char value[SZ_FSTRVAL] # o data value +% character fvalue*70 +char comm[SZ_FLONGCOMM] # o keyword comment +% character fcomm*72 +int status # o error status + +begin + +call ftgkyn(iunit,nkey,fkeywr,fvalue,fcomm,status) + +call f77upk(fkeywr ,keywrd ,SZ_FKEYWORD) +call f77upk(fvalue ,value ,SZ_FSTRVAL) +call f77upk(fcomm ,comm ,SZ_FLONGCOMM) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkys.x b/pkg/tbtables/fitsio/fitssppb/fsgkys.x new file mode 100644 index 00000000..a93a8bcf --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkys.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsgkys(iunit,keywrd,strval,comm,status) + +# read a character string value and comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # o string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkys(iunit,fkeywr,fstrva,fcomm,status) + +call f77upk(fstrva,strval,SZ_FSTRVAL) +call f77upk(fcomm ,comm ,SZ_FCOMMENT) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgkyt.x b/pkg/tbtables/fitsio/fitssppb/fsgkyt.x new file mode 100644 index 00000000..c3db4645 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgkyt.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgkyt(iunit,keywrd,intval,dval,comm,status) + +# read an integer value and fractional parts of a keyword value +# and the comment string from a header record + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # o integer value +double dval # o real*8 value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftgkyt(iunit,fkeywr,intval,dval,fcomm,status) + +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgmsg.x b/pkg/tbtables/fitsio/fitssppb/fsgmsg.x new file mode 100644 index 00000000..7c6f6a2e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgmsg.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsgmsg(text) + +# Return oldest error message from the FITSIO error stack + +char text[SZ_FCARD] # o text string +% character ftext*80 + +begin + +call ftgmsg(ftext) + +call f77upk(ftext ,text ,SZ_FCARD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpfb.x b/pkg/tbtables/fitsio/fitssppb/fsgpfb.x new file mode 100644 index 00000000..941123cb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpfb.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpfb(iunit,group,felem,nelem, + array,flgval,anynul,status) + +# Read an array of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will have the corresponding element of +# FLGVAL set equal to .true. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding element undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpfb(iunit,group,felem,nelem, + array,flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpfd.x b/pkg/tbtables/fitsio/fitssppb/fsgpfd.x new file mode 100644 index 00000000..b222425e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpfd.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpfd(iunit,group,felem,nelem, + array,flgval,anynul,status) + +# Read an array of r*8 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will have the corresponding element of +# FLGVAL set equal to .true. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # o array of values +bool flgval[ARB] # o is corresponding element undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpfd(iunit,group,felem,nelem, + array,flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpfe.x b/pkg/tbtables/fitsio/fitssppb/fsgpfe.x new file mode 100644 index 00000000..91f63dff --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpfe.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpfe(iunit,group,felem,nelem, + array,flgval,anynul,status) + +# Read an array of r*4 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will have the corresponding element of +# FLGVAL set equal to .true. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # o array of values +bool flgval[ARB] # o is corresponding element undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpfe(iunit,group,felem,nelem, + array,flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpfi.x b/pkg/tbtables/fitsio/fitssppb/fsgpfi.x new file mode 100644 index 00000000..33ec211c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpfi.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpfi(iunit,group,felem,nelem, + array,flgval,anynul,status) + +# Read an array of I*2 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will have the corresponding element of +# FLGVAL set equal to .true. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # o array of values +bool flgval[ARB] # o is corresponding element undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpfi(iunit,group,felem,nelem, + array,flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpfj.x b/pkg/tbtables/fitsio/fitssppb/fsgpfj.x new file mode 100644 index 00000000..2cef04ea --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpfj.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpfj(iunit,group,felem,nelem, + array,flgval,anynul,status) + +# Read an array of I*4 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will have the corresponding element of +# FLGVAL set equal to .true. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding element undefined? +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpfj(iunit,group,felem,nelem, + array,flgval,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpvb.x b/pkg/tbtables/fitsio/fitssppb/fsgpvb.x new file mode 100644 index 00000000..f1a8f79d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpvb.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpvb(iunit,group,felem,nelem,nulval, + array,anynul,status) + +# Read an array of byte values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will be set equal to NULVAL, unless NULVAL=0 +# in which case no checking for undefined values will be performed. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int nulval # i value for undefined pixel +int array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpvb(iunit,group,felem,nelem,nulval, + array,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpvd.x b/pkg/tbtables/fitsio/fitssppb/fsgpvd.x new file mode 100644 index 00000000..d3e9bd9b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpvd.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpvd(iunit,group,felem,nelem,nulval, + array,anynul,status) + +# Read an array of r*8 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will be set equal to NULVAL, unless NULVAL=0 +# in which case no checking for undefined values will be performed. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +double nulval # i value for undefined pixels +double array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpvd(iunit,group,felem,nelem,nulval, + array,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpve.x b/pkg/tbtables/fitsio/fitssppb/fsgpve.x new file mode 100644 index 00000000..ac7f6e79 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpve.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpve(iunit,group,felem,nelem,nulval, + array,anynul,status) + +# Read an array of r*4 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will be set equal to NULVAL, unless NULVAL=0 +# in which case no checking for undefined values will be performed. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +real nulval # i value for undefined pixels +real array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpve(iunit,group,felem,nelem,nulval, + array,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpvi.x b/pkg/tbtables/fitsio/fitssppb/fsgpvi.x new file mode 100644 index 00000000..e68c1625 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpvi.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpvi(iunit,group,felem,nelem,nulval, + array,anynul,status) + +# Read an array of i*2 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will be set equal to NULVAL, unless NULVAL=0 +# in which case no checking for undefined values will be performed. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +short nulval # i value for undefined pixels +short array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpvi(iunit,group,felem,nelem,nulval, + array,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgpvj.x b/pkg/tbtables/fitsio/fitssppb/fsgpvj.x new file mode 100644 index 00000000..45e55099 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgpvj.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fsgpvj(iunit,group,felem,nelem,nulval, + array,anynul,status) + +# Read an array of i*4 values from the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). +# Undefined elements will be set equal to NULVAL, unless NULVAL=0 +# in which case no checking for undefined values will be performed. +# ANYNUL is return with a value of .true. if any pixels were undefined. + +int iunit # i input file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int nulval # i value for undefined pixels +int array[ARB] # o array of values +bool anynul # o any null values? +int status # o error status + +begin + +call ftgpvj(iunit,group,felem,nelem,nulval, + array,anynul,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgrec.x b/pkg/tbtables/fitsio/fitssppb/fsgrec.x new file mode 100644 index 00000000..440c8bdb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgrec.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsgrec(iunit,nrec,record,status) + +# Read the Nth 80-byte header record +# This routine is useful for reading the entire header, one +# record at a time. + +int iunit # i input file pointer +int nrec # i number of keywords +char record[SZ_FCARD] # o 80-char header record +% character frecor*80 +int status # o error status + +begin + +call ftgrec(iunit,nrec,frecor,status) + +call f77upk(frecor,record,SZ_FCARD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgrsz.x b/pkg/tbtables/fitsio/fitssppb/fsgrsz.x new file mode 100644 index 00000000..83dca679 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgrsz.x @@ -0,0 +1,35 @@ +include <fset.h> +include "fitsio.h" + +# This was added for compatibility with CFITSIO. + +procedure fsgrsz (iunit, maxrows, status) + + +int iunit # i input file pointer +int maxrows # o number of rows that fit in buffer +int status # o error status +#-- +int fd +int bufsize +int naxis1 +char comm[SZ_FCOMMENT] +int fstati() +include "../fitsspp.com" # in order to get fd from iunit + +begin + call fsgkyj (iunit, "NAXIS1", naxis1, comm, status) + if (status != 0) + return + naxis1 = naxis1 / 2 # convert from bytes to SPP char + + fd = bufid[iunit] + + bufsize = fstati (fd, F_BUFSIZE) + if (naxis1 > 0) { + maxrows = bufsize / naxis1 + maxrows = max (1, maxrows) + } else { + maxrows = bufsize + } +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsdt.x b/pkg/tbtables/fitsio/fitssppb/fsgsdt.x new file mode 100644 index 00000000..8a223280 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsdt.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsgsdt(dd,mm,yy,status) + +# get the current date + +int dd #O day of the month (1-31) +int mm #O month of the year (1-12) +int yy #O last 2 digits of the year (1992 = 92, 2001 = 01) +int status # o error status + +begin +call ftgsdt (dd, mm, yy, status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsfb.x b/pkg/tbtables/fitsio/fitssppb/fsgsfb.x new file mode 100644 index 00000000..2f5be792 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsfb.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgsfb(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +# Read a subsection of byte values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsfb(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsfd.x b/pkg/tbtables/fitsio/fitssppb/fsgsfd.x new file mode 100644 index 00000000..3f3fa6c9 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsfd.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgsfd(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) + +# Read a subsection of double precision values from the primary array. +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +double array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsfd(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsfe.x b/pkg/tbtables/fitsio/fitssppb/fsgsfe.x new file mode 100644 index 00000000..8360592a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsfe.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsfe(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) + +# Read a subsection of real values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +real array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsfe(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsfi.x b/pkg/tbtables/fitsio/fitssppb/fsgsfi.x new file mode 100644 index 00000000..13ff31e5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsfi.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsfi(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) + +# Read a subsection of Integer*2 values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +short array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsfi(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsfj.x b/pkg/tbtables/fitsio/fitssppb/fsgsfj.x new file mode 100644 index 00000000..255705f2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsfj.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsfj(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) + +# Read a subsection of integer values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +int array[ARB] # o array of values +bool flgval[ARB] # o is corresponding value undefined? +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsfj(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + array,flgval,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsvb.x b/pkg/tbtables/fitsio/fitssppb/fsgsvb.x new file mode 100644 index 00000000..4fa8556b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsvb.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgsvb(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +# Read a subsection of byte values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +int nulval # i value for undefined pi +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsvb(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsvd.x b/pkg/tbtables/fitsio/fitssppb/fsgsvd.x new file mode 100644 index 00000000..c66993a6 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsvd.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgsvd(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) + +# Read a subsection of double precision values from the primary array. +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +double nulval # i value for undefined pi +double array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsvd(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsve.x b/pkg/tbtables/fitsio/fitssppb/fsgsve.x new file mode 100644 index 00000000..b65e565f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsve.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsve(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) + +# Read a subsection of real values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +real nulval # i value for undefined pi +real array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsve(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsvi.x b/pkg/tbtables/fitsio/fitssppb/fsgsvi.x new file mode 100644 index 00000000..37276fd8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsvi.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsvi(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) + +# Read a subsection of Integer*2 values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +short nulval # i value for undefined pi +short array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsvi(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgsvj.x b/pkg/tbtables/fitsio/fitssppb/fsgsvj.x new file mode 100644 index 00000000..7c2144f8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgsvj.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fsgsvj(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) + +# Read a subsection of integer values from the primary array. + +int iunit # i input file pointer +int colnum # i colnum number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int inc[ARB] # i increment +int nulval # i value for undefined pi +int array[ARB] # o array of values +bool anyflg # o any null values? +int status # o error status + +begin + +call ftgsvj(iunit,colnum,naxis,naxes,fpixel,lpixel,inc, + nulval,array,anyflg,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgtbb.x b/pkg/tbtables/fitsio/fitssppb/fsgtbb.x new file mode 100644 index 00000000..423300c3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgtbb.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsgtbb(iunit,frow,fchar,nchars,value,status) + +# read a consecutive string of bytes from an ascii or binary +# table. This will span multiple rows of the table if NCHARS+FCHAR is +# greater than the length of a row. + +int iunit # i input file pointer +int frow # i first row +int fchar # i first character +int nchars # i number of bytes +int value[ARB] # o data value +int status # o error status + +begin + +call ftgtbb(iunit,frow,fchar,nchars,value,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgtbs.x b/pkg/tbtables/fitsio/fitssppb/fsgtbs.x new file mode 100644 index 00000000..63f13469 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgtbs.x @@ -0,0 +1,38 @@ +include "fitsio.h" + +procedure fsgtbs(iunit,frow,fchar,nchars,svalue,status) + +# read a consecutive string of characters from an ascii or binary +# table. This will span multiple rows of the table if NCHARS+FCHAR is +# greater than the length of a row. + +int iunit # i input file pointer +int frow # i first row +int fchar # i first character +int nchars # i number of characters +char svalue[ARB] # o string value +% character fsvalu*256 +int status # o error status +int readfirst +int writefirst +int ntodo +int itodo + +begin + +# since the string may be arbitrarily long, read it in pieces +readfirst=fchar +writefirst=1 +ntodo=nchars +itodo=min(256,ntodo) + +while (itodo > 0) { + call ftgtbs(iunit,frow,readfirst,itodo,fsvalu,status) + call fsupk(fsvalu,svalue[writefirst],itodo) + writefirst=writefirst+itodo + readfirst=readfirst+itodo + ntodo=ntodo-itodo + itodo=min(256,ntodo) + } + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgtcl.x b/pkg/tbtables/fitsio/fitssppb/fsgtcl.x new file mode 100644 index 00000000..43dcbd8d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgtcl.x @@ -0,0 +1,12 @@ +include "fitsio.h" + +procedure fsgtcl(iunit,colnum,tcode,rpeat,wdth,status) + +int iunit,colnum,tcode,rpeat,wdth +int status # o error status + +begin + +call ftgtcl(iunit,colnum,tcode,rpeat,wdth,status) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgtcs.x b/pkg/tbtables/fitsio/fitssppb/fsgtcs.x new file mode 100644 index 00000000..5ef0818e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgtcs.x @@ -0,0 +1,18 @@ +include "fitsio.h" + +procedure fsgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix,xinc,yinc, + rot,coord,status) + +int iunit,xcol,ycol +double xrval,yrval,xrpix,yrpix,xinc,yinc,rot +char coord[4] +% character fcoord*4 +int status # o error status + +begin + +call ftgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix,xinc,yinc,rot, + fcoord,status) +call f77upk(fcoord,coord,4) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgtdm.x b/pkg/tbtables/fitsio/fitssppb/fsgtdm.x new file mode 100644 index 00000000..d2482b08 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgtdm.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsgtdm(iunit,colnum,maxdim,naxis,naxes,status) + +# read the TDIMnnn keyword + +int iunit # i input file pointer +int colnum # i column number +int maxdim # i maximum number of dimensions to return +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int status # o error status + +begin + +call ftgtdm(iunit,colnum,maxdim,naxis,naxes,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsgthd.x b/pkg/tbtables/fitsio/fitssppb/fsgthd.x new file mode 100644 index 00000000..c7ff0e71 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsgthd.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsgthd(tmplat,card,hdtype,status) + +# 'Get Template HeaDer' +# parse a template header line and create a formated +# 80-character string which is suitable for appending to a FITS header + +char tmplat[ARB] # i template string +% character ftmpla*100 +char card[SZ_FCARD] # o 80-char header record +% character fcard*80 +int hdtype # o hdu type code +int status # o error status + +begin + +call f77pak(tmplat,ftmpla,100) + +call ftgthd(ftmpla,fcard,hdtype,status) + +call f77upk(fcard ,card ,SZ_FCARD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fshdef.x b/pkg/tbtables/fitsio/fitssppb/fshdef.x new file mode 100644 index 00000000..56ceab74 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fshdef.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fshdef(ounit,moreky,status) + +# Header DEFinition +# define the size of the current header unit; this simply lets +# us determine where the data unit will start + +int ounit # i output file pointer +int moreky # i reserve space for this many more keywords +int status # o error status + +begin + +call fthdef(ounit,moreky,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsibin.x b/pkg/tbtables/fitsio/fitssppb/fsibin.x new file mode 100644 index 00000000..ee585149 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsibin.x @@ -0,0 +1,35 @@ +include "fitsio.h" + +procedure fsibin(ounit,nrows,nfield,ttype,tform,tunit, + extnam,pcount,status) + +# insert a binary table extension + +int ounit # i output file pointer +int nrows # i number of rows +int nfield # i number of fields +char ttype[SZ_FTTYPE,ARB] # i column name +% character*24 fttype(512) +char tform[SZ_FTFORM,ARB] # i column data format +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # i column units +% character*24 ftunit(512) +char extnam[SZ_FEXTNAME] # i extension name +% character fextna*24 +int pcount # i size of 'heap' +int status # o error status +int i + +begin + +do i = 1, nfield + { call f77pak(ttype(1,i) ,fttype(i),SZ_FTTYPE) + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + call f77pak(tunit(1,i) ,ftunit(i),SZ_FTUNIT) + } + +call f77pak(extnam ,fextna,SZ_FEXTNAME) + +call ftibin(ounit,nrows,nfield,fttype,ftform,ftunit, + fextna,pcount,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsicol.x b/pkg/tbtables/fitsio/fitssppb/fsicol.x new file mode 100644 index 00000000..500aeb62 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsicol.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsicol(ounit,colnum,ttype,tform,status) + +# insert column in a table + +int ounit # i output file pointer +int colnum # i column to be inserted +char ttype[SZ_FTTYPE] # i column name +% character*24 ftype +char tform[SZ_FTFORM] # i column data format +% character*16 fform +int status # o error status + +begin + +call f77pak(ttype ,ftype,SZ_FTTYPE) +call f77pak(tform ,fform,SZ_FTFORM) + +call fticol(ounit,colnum,ftype,fform,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsiimg.x b/pkg/tbtables/fitsio/fitssppb/fsiimg.x new file mode 100644 index 00000000..78d224fb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsiimg.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsiimg(ounit,bitpix,naxis,naxes,status) + +# insert an IMAGE extension + +int ounit # i output file pointer +int bitpix # i bits per pixel +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int status # o error status + +begin + +call ftiimg(ounit,bitpix,naxis,naxes,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikyd.x b/pkg/tbtables/fitsio/fitssppb/fsikyd.x new file mode 100644 index 00000000..be4af4f7 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikyd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsikyd(ounit,keywrd,dval,decim,comm,status) + +# insert a double precision value to a header record in E format +# If it will fit, the value field will be 20 characters wide; +# otherwise it will be expanded to up to 35 characters, left +# justified. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikyd(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikye.x b/pkg/tbtables/fitsio/fitssppb/fsikye.x new file mode 100644 index 00000000..a43a1a74 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikye.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsikye(ounit,keywrd,rval,decim,comm,status) + +# insert a real*4 value to a header record in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikye(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikyf.x b/pkg/tbtables/fitsio/fitssppb/fsikyf.x new file mode 100644 index 00000000..5806ae6d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikyf.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsikyf(ounit,keywrd,rval,decim,comm,status) + +# insert a real*4 value to a header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikyf(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikyg.x b/pkg/tbtables/fitsio/fitssppb/fsikyg.x new file mode 100644 index 00000000..c5d877e5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikyg.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsikyg(ounit,keywrd,dval,decim,comm,status) + +# insert a double precision value to a header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikyg(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikyj.x b/pkg/tbtables/fitsio/fitssppb/fsikyj.x new file mode 100644 index 00000000..cf8e89f7 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikyj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsikyj(ounit,keywrd,intval,comm,status) + +# insert an integer value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # i integer value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikyj(ounit,fkeywr,intval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikyl.x b/pkg/tbtables/fitsio/fitssppb/fsikyl.x new file mode 100644 index 00000000..f63fd370 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikyl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsikyl(ounit,keywrd,logval,comm,status) + +# insert a logical value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +bool logval # i logical value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikyl(ounit,fkeywr,logval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsikys.x b/pkg/tbtables/fitsio/fitssppb/fsikys.x new file mode 100644 index 00000000..0ad5821e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsikys.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsikys(ounit,keywrd,strval,comm,status) + +# insert a character string value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(strval,fstrva,SZ_FSTRVAL) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftikys(ounit,fkeywr,fstrva,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsinit.x b/pkg/tbtables/fitsio/fitssppb/fsinit.x new file mode 100644 index 00000000..85cd96de --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsinit.x @@ -0,0 +1,18 @@ +include "fitsio.h" + +procedure fsinit(funit,fname,block,status) + +# open a new FITS file with write access + +int funit # i file I/O pointer +char fname[ARB] # i file name +% character ffname*255 +int block # i FITS blocking factor +int status # o error status + +begin + +call f77pak(fname ,ffname,255) + +call ftinit(funit,ffname,block,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsirec.x b/pkg/tbtables/fitsio/fitssppb/fsirec.x new file mode 100644 index 00000000..35f0190c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsirec.x @@ -0,0 +1,18 @@ +include "fitsio.h" + +procedure fsirec(ounit,keyno,record,status) + +# insert a character string card record to a header + +int ounit # i output file pointer +int keyno # i number of the keyword to insert before +char record[SZ_FCARD] # i 80-char header record +% character frecor*80 +int status # o error status + +begin + +call f77pak(record,frecor,SZ_FCARD) + +call ftirec(ounit,keyno,frecor,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsirow.x b/pkg/tbtables/fitsio/fitssppb/fsirow.x new file mode 100644 index 00000000..7d735c2c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsirow.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsirow(ounit,frow,nrows,status) + +# insert rows in a table + +int ounit # i output file pointer +int frow # insert rows after this row +int nrows # number of rows +int status # o error status + +begin + +call ftirow(ounit,frow,nrows,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsitab.x b/pkg/tbtables/fitsio/fitssppb/fsitab.x new file mode 100644 index 00000000..cf8b852e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsitab.x @@ -0,0 +1,36 @@ +include "fitsio.h" + +procedure fsitab(ounit,ncols,nrows,nfield,ttype,tbcol, + tform,tunit,extnam,status) + +# insert an ASCII table extension + +int ounit # i output file pointer +int ncols # i number of columns +int nrows # i number of rows +int nfield # i number of fields +char ttype[SZ_FTTYPE,ARB] # i column name +% character*24 fttype(512) +int tbcol[ARB] # i starting column position +char tform[SZ_FTFORM,ARB] # i column data format +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # i column units +% character*24 ftunit(512) +char extnam[SZ_FEXTNAME] # i extension name +% character fextna*24 +int status # o error status +int i + +begin + +do i = 1, nfield + { call f77pak(ttype(1,i) ,fttype(i),SZ_FTTYPE) + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + call f77pak(tunit(1,i) ,ftunit(i),SZ_FTUNIT) + } + +call f77pak(extnam ,fextna,SZ_FEXTNAME) + +call ftitab(ounit,ncols,nrows,nfield,fttype,tbcol, + ftform,ftunit,fextna,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fskeyn.x b/pkg/tbtables/fitsio/fitssppb/fskeyn.x new file mode 100644 index 00000000..1ce2ff8f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fskeyn.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fskeyn(keywrd,nseq,keyout,status) + +# Make a keyword name by concatinating the root name and a +# sequence number + +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nseq # i keyword sequence no. +char keyout[SZ_FKEYWORD] # o output keyword +% character fkeyou*8 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftkeyn(fkeywr,nseq,fkeyou,status) + +call f77upk(fkeyou,keyout,SZ_FKEYWORD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmahd.x b/pkg/tbtables/fitsio/fitssppb/fsmahd.x new file mode 100644 index 00000000..61479f04 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmahd.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsmahd(iunit,extno,xtend,status) + +# Move to Absolute Header Data unit +# move the i/o pointer to the specified HDU and initialize all +# the common block parameters which describe the extension + +int iunit # i input file pointer +int extno # i extension number +int xtend # o type of extension +int status # o error status + +begin + +call ftmahd(iunit,extno,xtend,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmcom.x b/pkg/tbtables/fitsio/fitssppb/fsmcom.x new file mode 100644 index 00000000..7c762ecd --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmcom.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsmcom(ounit,keywrd,comm,status) + +# modify the comment string in a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char comm[SZ_FLONGCOMM] # i keyword comment +% character fcomm*72 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FLONGCOMM) + +call ftmcom(ounit,fkeywr,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmcrd.x b/pkg/tbtables/fitsio/fitssppb/fsmcrd.x new file mode 100644 index 00000000..a4e3be3f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmcrd.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsmcrd(ounit,keywrd,card,status) + +# modify (overwrite) a given header record specified by keyword name. +# This can be used to overwrite the name of the keyword as well as +# the value and comment fields. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char card[SZ_FCARD] # i 80-char header record +% character fcard*80 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(card ,fcard, SZ_FCARD) + +call ftmcrd(ounit,fkeywr,fcard,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkyd.x b/pkg/tbtables/fitsio/fitssppb/fsmkyd.x new file mode 100644 index 00000000..3715c59d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkyd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsmkyd(ounit,keywrd,dval,decim,comm,status) + +# modify a double precision value header record in E format +# If it will fit, the value field will be 20 characters wide; +# otherwise it will be expanded to up to 35 characters, left +# justified. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkyd(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkye.x b/pkg/tbtables/fitsio/fitssppb/fsmkye.x new file mode 100644 index 00000000..7b6fdeb6 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkye.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsmkye(ounit,keywrd,rval,decim,comm,status) + +# modify a real*4 value header record in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkye(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkyf.x b/pkg/tbtables/fitsio/fitssppb/fsmkyf.x new file mode 100644 index 00000000..7b4deb8a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkyf.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsmkyf(ounit,keywrd,rval,decim,comm,status) + +# modify a real*4 value header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkyf(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkyg.x b/pkg/tbtables/fitsio/fitssppb/fsmkyg.x new file mode 100644 index 00000000..928e69e1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkyg.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsmkyg(ounit,keywrd,dval,decim,comm,status) + +# modify a double precision value header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkyg(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkyj.x b/pkg/tbtables/fitsio/fitssppb/fsmkyj.x new file mode 100644 index 00000000..66ab5bbe --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkyj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsmkyj(ounit,keywrd,intval,comm,status) + +# modify an integer value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # i integer value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkyj(ounit,fkeywr,intval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkyl.x b/pkg/tbtables/fitsio/fitssppb/fsmkyl.x new file mode 100644 index 00000000..ba902380 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkyl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsmkyl(ounit,keywrd,logval,comm,status) + +# modify a logical value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +bool logval # i logical value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkyl(ounit,fkeywr,logval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmkys.x b/pkg/tbtables/fitsio/fitssppb/fsmkys.x new file mode 100644 index 00000000..e0417e72 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmkys.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsmkys(ounit,keywrd,strval,comm,status) + +# modify a character string value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(strval,fstrva,SZ_FSTRVAL) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftmkys(ounit,fkeywr,fstrva,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmnam.x b/pkg/tbtables/fitsio/fitssppb/fsmnam.x new file mode 100644 index 00000000..8c7d4e82 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmnam.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsmnam(ounit,oldkey,newkey,status) + +# modify the name of a header keyword + +int ounit # i output file pointer +char oldkey[SZ_FKEYWORD] # i keyword name +% character fokey*8 +char newkey[SZ_FKEYWORD] # i keyword name +% character fnkey*8 +int status # o error status + +begin + +call f77pak(oldkey,fokey,SZ_FKEYWORD) +call f77pak(newkey,fnkey,SZ_FKEYWORD) + +call ftmnam(ounit,fokey,fnkey,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmrec.x b/pkg/tbtables/fitsio/fitssppb/fsmrec.x new file mode 100644 index 00000000..5951427b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmrec.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsmrec(ounit,nkey,record,status) + +# modify the nth keyword in the CHU, by replacing it with the +# input 80 character string. + +int ounit # i output file pointer +int nkey # i number of keyword to be modified +char record[SZ_FCARD] # i 80-char header record +% character frecor*80 +int status # o error status + +begin + +call f77pak(record,frecor,SZ_FCARD) + +call ftmrec(ounit,nkey,frecor,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsmrhd.x b/pkg/tbtables/fitsio/fitssppb/fsmrhd.x new file mode 100644 index 00000000..d253bc5b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsmrhd.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsmrhd(iunit,extmov,xtend,status) + +# Move Relative Header Data unit +# move the i/o pointer to the specified HDU and initialize all +# the common block parameters which describe the extension + +int iunit # i input file pointer +int extmov # i relative extension number +int xtend # o type of extension +int status # o error status + +begin + +call ftmrhd(iunit,extmov,xtend,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsnkey.x b/pkg/tbtables/fitsio/fitssppb/fsnkey.x new file mode 100644 index 00000000..92f7d8fb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsnkey.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsnkey(nseq,keywrd,keyout,status) + +# Make a keyword name by concatinating the root name and a +# sequence number + +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nseq # i keyword sequence no. +char keyout[SZ_FKEYWORD] # o output keyword +% character fkeyou*8 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call ftnkey(nseq,fkeywr,fkeyou,status) + +call f77upk(fkeyou,keyout,SZ_FKEYWORD) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsopen.x b/pkg/tbtables/fitsio/fitssppb/fsopen.x new file mode 100644 index 00000000..c31f832b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsopen.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsopen(funit,fname,rwmode,block,status) + +# open an existing FITS file with readonly or read/write access + +int funit # i file I/O pointer +char fname[ARB] # i file name +% character ffname*255 +int rwmode # i file read/write mode +int block # i FITS blocking factor +int status # o error status + +begin + +call f77pak(fname ,ffname,255) + +call ftopen(funit,ffname,rwmode,block,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp2db.x b/pkg/tbtables/fitsio/fitssppb/fsp2db.x new file mode 100644 index 00000000..5f02278c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp2db.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsp2db(ounit,group,dim1,nx,ny,array,status) + +# Write a 2-d image of byte values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +int array[ARB] # i array of values +int status # o error status + +begin + +call ftp2db(ounit,group,dim1,nx,ny,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp2dd.x b/pkg/tbtables/fitsio/fitssppb/fsp2dd.x new file mode 100644 index 00000000..1ae13748 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp2dd.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsp2dd(ounit,group,dim1,nx,ny,array,status) + +# Write a 2-d image of r*8 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +double array[ARB] # i array of values +int status # o error status + +begin + +call ftp2dd(ounit,group,dim1,nx,ny,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp2de.x b/pkg/tbtables/fitsio/fitssppb/fsp2de.x new file mode 100644 index 00000000..3449af47 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp2de.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsp2de(ounit,group,dim1,nx,ny,array,status) + +# Write a 2-d image of r*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +real array[ARB] # i array of values +int status # o error status + +begin + +call ftp2de(ounit,group,dim1,nx,ny,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp2di.x b/pkg/tbtables/fitsio/fitssppb/fsp2di.x new file mode 100644 index 00000000..7678af53 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp2di.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsp2di(ounit,group,dim1,nx,ny,array,status) + +# Write a 2-d image of i*2 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +short array[ARB] # i array of values +int status # o error status + +begin + +call ftp2di(ounit,group,dim1,nx,ny,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp2dj.x b/pkg/tbtables/fitsio/fitssppb/fsp2dj.x new file mode 100644 index 00000000..444e4ee4 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp2dj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsp2dj(ounit,group,dim1,nx,ny,array,status) + +# Write a 2-d image of i*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int nx # i size of x axis +int ny # i size of y axis +int array[ARB] # i array of values +int status # o error status + +begin + +call ftp2dj(ounit,group,dim1,nx,ny,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp3db.x b/pkg/tbtables/fitsio/fitssppb/fsp3db.x new file mode 100644 index 00000000..04152f97 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp3db.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsp3db(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +# Write a 3-d cube of byte values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +int array[ARB] # i array of values +int status # o error status + +begin + +call ftp3db(ounit,group,dim1,dim2,nx,ny,nz,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp3dd.x b/pkg/tbtables/fitsio/fitssppb/fsp3dd.x new file mode 100644 index 00000000..35db8e93 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp3dd.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsp3dd(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +# Write a 3-d cube of r*8 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +double array[ARB] # i array of values +int status # o error status + +begin + +call ftp3dd(ounit,group,dim1,dim2,nx,ny,nz,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp3de.x b/pkg/tbtables/fitsio/fitssppb/fsp3de.x new file mode 100644 index 00000000..806f7b02 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp3de.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsp3de(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +# Write a 3-d cube of r*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +real array[ARB] # i array of values +int status # o error status + +begin + +call ftp3de(ounit,group,dim1,dim2,nx,ny,nz,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp3di.x b/pkg/tbtables/fitsio/fitssppb/fsp3di.x new file mode 100644 index 00000000..9f4ac32c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp3di.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsp3di(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +# Write a 3-d cube of i*2 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +short array[ARB] # i array of values +int status # o error status + +begin + +call ftp3di(ounit,group,dim1,dim2,nx,ny,nz,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsp3dj.x b/pkg/tbtables/fitsio/fitssppb/fsp3dj.x new file mode 100644 index 00000000..fc1967e3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsp3dj.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsp3dj(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +# Write a 3-d cube of i*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int dim1 # i size of 1st dimension +int dim2 # i size of 2nd dimension +int nx # i size of x axis +int ny # i size of y axis +int nz # i size of z axis +int array[ARB] # i array of values +int status # o error status + +begin + +call ftp3dj(ounit,group,dim1,dim2,nx,ny,nz,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcks.x b/pkg/tbtables/fitsio/fitssppb/fspcks.x new file mode 100644 index 00000000..a5b9039a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcks.x @@ -0,0 +1,11 @@ +include "fitsio.h" + +procedure fspcks(iunit,status) + +int iunit +int status # o error status + +begin + +call ftpcks(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclb.x b/pkg/tbtables/fitsio/fitssppb/fspclb.x new file mode 100644 index 00000000..5a994710 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclb.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspclb(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of unsigned byte data values to the +# specified column of the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpclb(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclc.x b/pkg/tbtables/fitsio/fitssppb/fspclc.x new file mode 100644 index 00000000..ac198fa3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclc.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fspclc(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of single precision complex data values to the +# specified column of the table. +# The binary table column being written to must have datatype 'C' +# and no datatype conversion will be perform if it is not. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # i array of values +int status # o error status + +begin + +call ftpclc(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcld.x b/pkg/tbtables/fitsio/fitssppb/fspcld.x new file mode 100644 index 00000000..21d413fa --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcld.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspcld(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of double precision data values to the specified column +# of the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # i array of values +int status # o error status + +begin + +call ftpcld(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcle.x b/pkg/tbtables/fitsio/fitssppb/fspcle.x new file mode 100644 index 00000000..9727c8ea --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcle.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspcle(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of real data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # i array of values +int status # o error status + +begin + +call ftpcle(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcli.x b/pkg/tbtables/fitsio/fitssppb/fspcli.x new file mode 100644 index 00000000..c89d2730 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcli.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspcli(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of integer*2 data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # i array of values +int status # o error status + +begin + +call ftpcli(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclj.x b/pkg/tbtables/fitsio/fitssppb/fspclj.x new file mode 100644 index 00000000..22e5561c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclj.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspclj(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of integer data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpclj(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcll.x b/pkg/tbtables/fitsio/fitssppb/fspcll.x new file mode 100644 index 00000000..6ade3400 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcll.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcll(ounit,colnum,frow,felem,nelem,lray,status) + +# write an array of logical values to the specified column of the table. +# The binary table column being written to must have datatype 'L' +# and no datatype conversion will be perform if it is not. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +bool lray[ARB] # i logical array +int status # o error status + +begin + +call ftpcll(ounit,colnum,frow,felem,nelem,lray,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclm.x b/pkg/tbtables/fitsio/fitssppb/fspclm.x new file mode 100644 index 00000000..4cdef809 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclm.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fspclm(ounit,colnum,frow,felem,nelem,array,status) + +# write an array of double precision complex data values to the +# specified column of the table. +# The binary table column being written to must have datatype 'M' +# and no datatype conversion will be perform if it is not. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # i array of values +int status # o error status + +begin + +call ftpclm(ounit,colnum,frow,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcls.x b/pkg/tbtables/fitsio/fitssppb/fspcls.x new file mode 100644 index 00000000..2d4f4a56 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcls.x @@ -0,0 +1,29 @@ +include "fitsio.h" + +procedure fspcls(ounit,colnum,frow,felem,nelem,sray,dim1,status) + +# write an array of character string values to the specified column of +# the table. +# The binary or ASCII table column being written to must have datatype 'A' + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +char sray[dim1,ARB] # i array of strings +int dim1 # i size of 1st dimension of 2D character string array +% character*256 fsray +int status # o error status +int i +int elem + +begin + +elem=felem +do i=1,nelem { + call f77pak(sray(1,i),fsray,dim1) + call ftpcls(ounit,colnum,frow,elem,1,fsray,status) + elem=elem+1 +} +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclu.x b/pkg/tbtables/fitsio/fitssppb/fspclu.x new file mode 100644 index 00000000..8d341d3c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclu.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fspclu(ounit,colnum,frow,felem,nelem,status) + +# set elements of a table to be undefined + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int status # o error status + +begin + +call ftpclu(ounit,colnum,frow,felem,nelem,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspclx.x b/pkg/tbtables/fitsio/fitssppb/fspclx.x new file mode 100644 index 00000000..140be2b9 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspclx.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fspclx(iunit,colnum,frow,fbit,nbit,lray,status) + +# write an array of logical values to a specified bit or byte +# column of the binary table. If the LRAY parameter is .true., +# then the corresponding bit is set to 1, otherwise it is set +# to 0. +# The binary table column being written to must have datatype 'B' +# or 'X'. + +int iunit # i input file pointer +int colnum # i column number +int frow # i first row +int fbit # i first bit +int nbit # i number of bits +bool lray[ARB] # i logical array +int status # o error status + +begin + +call ftpclx(iunit,colnum,frow,fbit,nbit,lray,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcnb.x b/pkg/tbtables/fitsio/fitssppb/fspcnb.x new file mode 100644 index 00000000..6e158397 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcnb.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcnb(ounit,colnum,frow,felem,nelem,array,nulval,status) + +# write an array of unsigned byte data values to the +# specified column of the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int nulval # i value representing a null +int status # o error status + +begin + +call ftpcnb(ounit,colnum,frow,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcnd.x b/pkg/tbtables/fitsio/fitssppb/fspcnd.x new file mode 100644 index 00000000..6fc182be --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcnd.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcnd(ounit,colnum,frow,felem,nelem,array,nulval,status) + +# write an array of double precision data values to the specified column +# of the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # i array of values +double nulval # d value representing a null +int status # o error status + +begin + +call ftpcnd(ounit,colnum,frow,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcne.x b/pkg/tbtables/fitsio/fitssppb/fspcne.x new file mode 100644 index 00000000..413ab23a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcne.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcne(ounit,colnum,frow,felem,nelem,array,nulval,status) + +# write an array of real data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # r array of values +real nulval # r value representing a null +int status # o error status + +begin + +call ftpcne(ounit,colnum,frow,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcni.x b/pkg/tbtables/fitsio/fitssppb/fspcni.x new file mode 100644 index 00000000..1c4bc5bc --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcni.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcni(ounit,colnum,frow,felem,nelem,array,nulval,status) + +# write an array of integer*2 data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # i array of values +short nulval # i value representing a null +int status # o error status + +begin + +call ftpcni(ounit,colnum,frow,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcnj.x b/pkg/tbtables/fitsio/fitssppb/fspcnj.x new file mode 100644 index 00000000..a64b8e9e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcnj.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspcnj(ounit,colnum,frow,felem,nelem,array,nulval,status) + +# write an array of integer data values to the specified column of +# the table. + +int ounit # i output file pointer +int colnum # i column number +int frow # i first row +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int nulval # i value representing a null +int status # o error status + +begin + +call ftpcnj(ounit,colnum,frow,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspcom.x b/pkg/tbtables/fitsio/fitssppb/fspcom.x new file mode 100644 index 00000000..9e9f2f14 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspcom.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fspcom(ounit,commnt,status) + +# write a COMMENT record to the FITS header + +int ounit # i output file pointer +char commnt[SZ_FLONGCOMM] # i comment keyword +% character fcommn*72 +int status # o error status + +begin + +call f77pak(commnt,fcommn,SZ_FLONGCOMM) + +call ftpcom(ounit,fcommn,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspdat.x b/pkg/tbtables/fitsio/fitssppb/fspdat.x new file mode 100644 index 00000000..bfddbe94 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspdat.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fspdat(ounit,status) + +# write the current date to the DATE keyword in the ounit CHU + +int ounit # i output file pointer +int status # o error status + +begin + +call ftpdat(ounit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspdef.x b/pkg/tbtables/fitsio/fitssppb/fspdef.x new file mode 100644 index 00000000..f9368e99 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspdef.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspdef(ounit,bitpix,naxis,naxes,pcount,gcount,status) + +# Primary data DEFinition +# define the structure of the primary data unit or an IMAGE extension + +int ounit # i output file pointer +int bitpix # i bits per pixel +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int pcount # i number of group parame +int gcount # i number of groups +int status # o error status + +begin + +call ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspdes.x b/pkg/tbtables/fitsio/fitssppb/fspdes.x new file mode 100644 index 00000000..ca1561f1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspdes.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fspdes(ounit,colnum,rownum,nelem,offset,status) + +# write the descriptor values to a binary table. This is only +# used for column which have TFORMn = 'P', i.e., for variable +# length arrays. + +int ounit # i output file pointer +int colnum # i column number +int rownum # i row number +int nelem # i number of elements +int offset # i offset +int status # o error status + +begin + +call ftpdes(ounit,colnum,rownum,nelem,offset,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspgpb.x b/pkg/tbtables/fitsio/fitssppb/fspgpb.x new file mode 100644 index 00000000..ee9ae600 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspgpb.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspgpb(ounit,group,fparm,nparm,array,status) + +# Write an array of group parmeters into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpgpb(ounit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspgpd.x b/pkg/tbtables/fitsio/fitssppb/fspgpd.x new file mode 100644 index 00000000..d7b53ef2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspgpd.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspgpd(ounit,group,fparm,nparm,array,status) + +# Write an array of group parmeters into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +double array[ARB] # i array of values +int status # o error status + +begin + +call ftpgpd(ounit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspgpe.x b/pkg/tbtables/fitsio/fitssppb/fspgpe.x new file mode 100644 index 00000000..ff117afe --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspgpe.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspgpe(ounit,group,fparm,nparm,array,status) + +# Write an array of group parmeters into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +real array[ARB] # i array of values +int status # o error status + +begin + +call ftpgpe(ounit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspgpi.x b/pkg/tbtables/fitsio/fitssppb/fspgpi.x new file mode 100644 index 00000000..455ec26d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspgpi.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspgpi(ounit,group,fparm,nparm,array,status) + +# Write an array of group parmeters into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +short array[ARB] # i array of values +int status # o error status + +begin + +call ftpgpi(ounit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspgpj.x b/pkg/tbtables/fitsio/fitssppb/fspgpj.x new file mode 100644 index 00000000..3f3cbd66 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspgpj.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspgpj(ounit,group,fparm,nparm,array,status) + +# Write an array of group parmeters into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int fparm # i first parameter +int nparm # i number of parameters +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpgpj(ounit,group,fparm,nparm,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsphbn.x b/pkg/tbtables/fitsio/fitssppb/fsphbn.x new file mode 100644 index 00000000..d9e8af02 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsphbn.x @@ -0,0 +1,35 @@ +include "fitsio.h" + +procedure fsphbn(ounit,nrows,nfield,ttype,tform,tunit, + extnam,pcount,status) + +# write required standard header keywords for a binary table extension + +int ounit # i output file pointer +int nrows # i number of rows +int nfield # i number of fields +char ttype[SZ_FTTYPE,ARB] # i column name +% character*24 fttype(512) +char tform[SZ_FTFORM,ARB] # i column data format +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # i column units +% character*24 ftunit(512) +char extnam[SZ_FEXTNAME] # i extension name +% character fextna*24 +int pcount # i size of 'heap' +int status # o error status +int i + +begin + +do i = 1, nfield + { call f77pak(ttype(1,i) ,fttype(i),SZ_FTTYPE) + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + call f77pak(tunit(1,i) ,ftunit(i),SZ_FTUNIT) + } + +call f77pak(extnam ,fextna,SZ_FEXTNAME) + +call ftphbn(ounit,nrows,nfield,fttype,ftform,ftunit, + fextna,pcount,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsphis.x b/pkg/tbtables/fitsio/fitssppb/fsphis.x new file mode 100644 index 00000000..a83669ed --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsphis.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsphis(ounit,histry,status) + +# write a HISTORY record to the FITS header + +int ounit # i output file pointer +char histry[SZ_FLONGCOMM] # i history keyword +% character fhistr*72 +int status # o error status + +begin + +call f77pak(histry,fhistr,SZ_FLONGCOMM) + +call ftphis(ounit,fhistr,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsphpr.x b/pkg/tbtables/fitsio/fitssppb/fsphpr.x new file mode 100644 index 00000000..28977af1 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsphpr.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsphpr(ounit,simple,bitpix,naxis,naxes, + pcount,gcount,extend,status) + +# write required primary header keywords + +int ounit # i output file pointer +bool simple # i simple FITS file? +int bitpix # i bits per pixel +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int pcount # i no. of group parameters +int gcount # i no. of groups +bool extend # i EXTEND keyword = TRUE? +int status # o error status + +begin + +call ftphpr(ounit,simple,bitpix,naxis,naxes, + pcount,gcount,extend,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsphtb.x b/pkg/tbtables/fitsio/fitssppb/fsphtb.x new file mode 100644 index 00000000..b7bcf953 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsphtb.x @@ -0,0 +1,36 @@ +include "fitsio.h" + +procedure fsphtb(ounit,ncols,nrows,nfield,ttype,tbcol, + tform,tunit,extnam,status) + +# write required standard header keywords for an ASCII table extension + +int ounit # i output file pointer +int ncols # i number of columns +int nrows # i number of rows +int nfield # i number of fields +char ttype[SZ_FTTYPE,ARB] # i column name +% character*24 fttype(512) +int tbcol[ARB] # i starting column position +char tform[SZ_FTFORM,ARB] # i column data format +% character*16 ftform(512) +char tunit[SZ_FTUNIT,ARB] # i column units +% character*24 ftunit(512) +char extnam[SZ_FEXTNAME] # i extension name +% character fextna*24 +int status # o error status +int i + +begin + +do i = 1, nfield + { call f77pak(ttype(1,i) ,fttype(i),SZ_FTTYPE) + call f77pak(tform(1,i) ,ftform(i),SZ_FTFORM) + call f77pak(tunit(1,i) ,ftunit(i),SZ_FTUNIT) + } + +call f77pak(extnam ,fextna,SZ_FEXTNAME) + +call ftphtb(ounit,ncols,nrows,nfield,fttype,tbcol, + ftform,ftunit,fextna,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkls.x b/pkg/tbtables/fitsio/fitssppb/fspkls.x new file mode 100644 index 00000000..f16108cb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkls.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fspkls(ounit,keywrd,strval,comm,status) + +# write a character string value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(strval,fstrva,SZ_FSTRVAL) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkls(ounit,fkeywr,fstrva,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspknd.x b/pkg/tbtables/fitsio/fitssppb/fspknd.x new file mode 100644 index 00000000..c5b384f5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspknd.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fspknd(ounit,keywrd,nstart,nkey,dval,decim,comm,status) + +# write an array of real*8 values to header records in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpknd(ounit,fkeywr,nstart,nkey,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkne.x b/pkg/tbtables/fitsio/fitssppb/fspkne.x new file mode 100644 index 00000000..45a9c4dc --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkne.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fspkne(ounit,keywrd,nstart,nkey,rval,decim,comm,status) + +# write an array of real*4 values to header records in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpkne(ounit,fkeywr,nstart,nkey,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspknf.x b/pkg/tbtables/fitsio/fitssppb/fspknf.x new file mode 100644 index 00000000..8579d358 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspknf.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fspknf(ounit,keywrd,nstart,nkey,rval,decim,comm,status) + +# write an array of real*4 values to header records in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpknf(ounit,fkeywr,nstart,nkey,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkng.x b/pkg/tbtables/fitsio/fitssppb/fspkng.x new file mode 100644 index 00000000..d4225e4d --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkng.x @@ -0,0 +1,27 @@ +include "fitsio.h" + +procedure fspkng(ounit,keywrd,nstart,nkey,dval,decim,comm,status) + +# write an array of real*8 values to header records in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpkng(ounit,fkeywr,nstart,nkey,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspknj.x b/pkg/tbtables/fitsio/fitssppb/fspknj.x new file mode 100644 index 00000000..8d303f1a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspknj.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fspknj(ounit,keywrd,nstart,nkey,intval,comm,status) + +# write an array of integer values to header records + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +int intval # i integer value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpknj(ounit,fkeywr,nstart,nkey,intval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspknl.x b/pkg/tbtables/fitsio/fitssppb/fspknl.x new file mode 100644 index 00000000..89a9c569 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspknl.x @@ -0,0 +1,26 @@ +include "fitsio.h" + +procedure fspknl(ounit,keywrd,nstart,nkey,logval,comm,status) + +# write an array of logical values to header records + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +bool logval[ARB] # i logical value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +call ftpknl(ounit,fkeywr,nstart,nkey,logval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkns.x b/pkg/tbtables/fitsio/fitssppb/fspkns.x new file mode 100644 index 00000000..1ac5b007 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkns.x @@ -0,0 +1,34 @@ +include "fitsio.h" + +procedure fspkns(ounit,keywrd,nstart,nkey,strval,comm,status) + +# write an array of character string values to header records + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int nstart # i first sequence number +int nkey # i number of keywords +char strval[SZ_FSTRVAL,ARB] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status +int i +int n1 + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) +# only support a single comment string for all the keywords in the SPP version +% fcomm(48:48)='&' + +n1=nstart +do i=1,nkey { + call f77pak(strval(1,i),fstrva,SZ_FSTRVAL) + call ftpkns(ounit,fkeywr,n1,1,fstrva,fcomm,status) + n1=n1+1 + } + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyd.x b/pkg/tbtables/fitsio/fitssppb/fspkyd.x new file mode 100644 index 00000000..6169674b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fspkyd(ounit,keywrd,dval,decim,comm,status) + +# write a double precision value to a header record in E format +# If it will fit, the value field will be 20 characters wide; +# otherwise it will be expanded to up to 35 characters, left +# justified. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyd(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkye.x b/pkg/tbtables/fitsio/fitssppb/fspkye.x new file mode 100644 index 00000000..395e6b6f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkye.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fspkye(ounit,keywrd,rval,decim,comm,status) + +# write a real*4 value to a header record in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkye(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyf.x b/pkg/tbtables/fitsio/fitssppb/fspkyf.x new file mode 100644 index 00000000..9ef7d359 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyf.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fspkyf(ounit,keywrd,rval,decim,comm,status) + +# write a real*4 value to a header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyf(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyg.x b/pkg/tbtables/fitsio/fitssppb/fspkyg.x new file mode 100644 index 00000000..a9faccec --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyg.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fspkyg(ounit,keywrd,dval,decim,comm,status) + +# write a double precision value to a header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyg(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyj.x b/pkg/tbtables/fitsio/fitssppb/fspkyj.x new file mode 100644 index 00000000..8cbc90e5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fspkyj(ounit,keywrd,intval,comm,status) + +# write an integer value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # i integer value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyj(ounit,fkeywr,intval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyl.x b/pkg/tbtables/fitsio/fitssppb/fspkyl.x new file mode 100644 index 00000000..69f57797 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fspkyl(ounit,keywrd,logval,comm,status) + +# write a logical value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +bool logval # i logical value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyl(ounit,fkeywr,logval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkys.x b/pkg/tbtables/fitsio/fitssppb/fspkys.x new file mode 100644 index 00000000..6d2b45c5 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkys.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fspkys(ounit,keywrd,strval,comm,status) + +# write a character string value to a header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(strval,fstrva,SZ_FSTRVAL) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkys(ounit,fkeywr,fstrva,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspkyt.x b/pkg/tbtables/fitsio/fitssppb/fspkyt.x new file mode 100644 index 00000000..d78bad96 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspkyt.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspkyt(iunit,keywrd,intval,dval,comm,status) + +# concatinate a integer value with a double precision fraction +# and write it to the FITS header along with the comment string +# The value will be displayed in F28.16 format + +int iunit # i input file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # i integer value +double dval # i real*8 value +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftpkyt(iunit,fkeywr,intval,dval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsplsw.x b/pkg/tbtables/fitsio/fitssppb/fsplsw.x new file mode 100644 index 00000000..d8d12137 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsplsw.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsplsw(iunit,status) + +# write keywords to warn users that longstring convention may be used + +int iunit # i input file pointer +int status # o error status + +begin + +call ftplsw(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspmsg.x b/pkg/tbtables/fitsio/fitssppb/fspmsg.x new file mode 100644 index 00000000..ec9f66ae --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspmsg.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fspmsg(text) + +# write a 80 character record to the FITSIO error stack + +char text[SZ_FCARD] # i 80-char message +% character ftext*80 + +begin + +call f77pak(text,ftext,SZ_FCARD) + +call ftpmsg(ftext) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspnul.x b/pkg/tbtables/fitsio/fitssppb/fspnul.x new file mode 100644 index 00000000..56cb31b3 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspnul.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fspnul(ounit,blank,status) + +# Primary Null value definition +# Define the null value for an integer primary array. +# This must be the first HDU of the FITS file. + +int ounit # i output file pointer +int blank # i value used to represent undefined values +int status # o error status + +begin + +call ftpnul(ounit,blank,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppnb.x b/pkg/tbtables/fitsio/fitssppb/fsppnb.x new file mode 100644 index 00000000..45d09699 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppnb.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsppnb(ounit,group,felem,nelem,array,nulval,status) + +# Write an array of byte values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int nulval # i value used for null pixels +int status # o error status + +begin + +call ftppnb(ounit,group,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppnd.x b/pkg/tbtables/fitsio/fitssppb/fsppnd.x new file mode 100644 index 00000000..4f808aa8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppnd.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsppnd(ounit,group,felem,nelem,array,nulval,status) + +# Write an array of r*8 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # i array of values +double nulval # d value used for null pixels +int status # o error status + +begin + +call ftppnd(ounit,group,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppne.x b/pkg/tbtables/fitsio/fitssppb/fsppne.x new file mode 100644 index 00000000..6279e59f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppne.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsppne(ounit,group,felem,nelem,array,nulval,status) + +# Write an array of r*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # r array of values +real nulval # r value used for null pixels +int status # o error status + +begin + +call ftppne(ounit,group,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppni.x b/pkg/tbtables/fitsio/fitssppb/fsppni.x new file mode 100644 index 00000000..dca6f308 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppni.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsppni(ounit,group,felem,nelem,array,nulval,status) + +# Write an array of i*2 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # i array of values +short nulval # i value used for null pixels +int status # o error status + +begin + +call ftppni(ounit,group,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppnj.x b/pkg/tbtables/fitsio/fitssppb/fsppnj.x new file mode 100644 index 00000000..4ec4b718 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppnj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsppnj(ounit,group,felem,nelem,array,nulval,status) + +# Write an array of i*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int nulval # i value used for null pixels +int status # o error status + +begin + +call ftppnj(ounit,group,felem,nelem,array,nulval,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspprb.x b/pkg/tbtables/fitsio/fitssppb/fspprb.x new file mode 100644 index 00000000..6a9bf554 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspprb.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspprb(ounit,group,felem,nelem,array,status) + +# Write an array of byte values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpprb(ounit,group,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspprd.x b/pkg/tbtables/fitsio/fitssppb/fspprd.x new file mode 100644 index 00000000..d5cd4565 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspprd.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspprd(ounit,group,felem,nelem,array,status) + +# Write an array of r*8 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +double array[ARB] # i array of values +int status # o error status + +begin + +call ftpprd(ounit,group,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppre.x b/pkg/tbtables/fitsio/fitssppb/fsppre.x new file mode 100644 index 00000000..fa9b2853 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppre.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsppre(ounit,group,felem,nelem,array,status) + +# Write an array of r*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +real array[ARB] # i array of values +int status # o error status + +begin + +call ftppre(ounit,group,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppri.x b/pkg/tbtables/fitsio/fitssppb/fsppri.x new file mode 100644 index 00000000..ab6afd59 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppri.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fsppri(ounit,group,felem,nelem,array,status) + +# Write an array of i*2 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +short array[ARB] # i array of values +int status # o error status + +begin + +call ftppri(ounit,group,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspprj.x b/pkg/tbtables/fitsio/fitssppb/fspprj.x new file mode 100644 index 00000000..b9d86710 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspprj.x @@ -0,0 +1,20 @@ +include "fitsio.h" + +procedure fspprj(ounit,group,felem,nelem,array,status) + +# Write an array of i*4 values into the primary array. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being written). + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpprj(ounit,group,felem,nelem,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsppru.x b/pkg/tbtables/fitsio/fitssppb/fsppru.x new file mode 100644 index 00000000..eedd82bd --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsppru.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsppru(ounit,group,felem,nelem,status) + +# set elements of the primary array equal to the undefined value + +int ounit # i output file pointer +int group # i group number +int felem # i first element in row +int nelem # i number of elements +int status # o error status + +begin + +call ftppru(ounit,group,felem,nelem,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsprec.x b/pkg/tbtables/fitsio/fitssppb/fsprec.x new file mode 100644 index 00000000..ee91cead --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsprec.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsprec(ounit,record,status) + +# write a 80 character record to the FITS header + +int ounit # i output file pointer +char record[SZ_FCARD] # i 80-char header record +% character frecor*80 +int status # o error status + +begin + +call f77pak(record,frecor,SZ_FCARD) + +call ftprec(ounit,frecor,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspscl.x b/pkg/tbtables/fitsio/fitssppb/fspscl.x new file mode 100644 index 00000000..df7d8233 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspscl.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fspscl(ounit,bscale,bzero,status) + +# Primary SCaLing factor definition +# Define the scaling factor for the primary header data. +# This must be the first HDU of the FITS file. + +int ounit # i output file pointer +double bscale # i scaling factor +double bzero # i scaling zeropoint +int status # o error status + +begin + +call ftpscl(ounit,bscale,bzero,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspssb.x b/pkg/tbtables/fitsio/fitssppb/fspssb.x new file mode 100644 index 00000000..3a26ef08 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspssb.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspssb(iunit,group,naxis,naxes,fpixel,lpixel,array,status) + +# Write a subsection of byte values to the primary array. +# A subsection is defined to be any contiguous rectangular +# array of pixels within the n-dimensional FITS data file. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpssb(iunit,group,naxis,naxes,fpixel,lpixel,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspssd.x b/pkg/tbtables/fitsio/fitssppb/fspssd.x new file mode 100644 index 00000000..0960c17f --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspssd.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspssd(iunit,group,naxis,naxes,fpixel,lpixel,array,status) + +# Write a subsection of double precision values to the primary array. +# A subsection is defined to be any contiguous rectangular +# array of pixels within the n-dimensional FITS data file. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +double array[ARB] # i array of values +int status # o error status + +begin + +call ftpssd(iunit,group,naxis,naxes,fpixel,lpixel,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspsse.x b/pkg/tbtables/fitsio/fitssppb/fspsse.x new file mode 100644 index 00000000..ffe42b34 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspsse.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspsse(iunit,group,naxis,naxes,fpixel,lpixel,array,status) + +# Write a subsection of real values to the primary array. +# A subsection is defined to be any contiguous rectangular +# array of pixels within the n-dimensional FITS data file. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +real array[ARB] # i array of values +int status # o error status + +begin + +call ftpsse(iunit,group,naxis,naxes,fpixel,lpixel,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspssi.x b/pkg/tbtables/fitsio/fitssppb/fspssi.x new file mode 100644 index 00000000..10612a9a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspssi.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspssi(iunit,group,naxis,naxes,fpixel,lpixel,array,status) + +# Write a subsection of integer*2 values to the primary array. +# A subsection is defined to be any contiguous rectangular +# array of pixels within the n-dimensional FITS data file. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +short array[ARB] # i array of values +int status # o error status + +begin + +call ftpssi(iunit,group,naxis,naxes,fpixel,lpixel,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspssj.x b/pkg/tbtables/fitsio/fitssppb/fspssj.x new file mode 100644 index 00000000..46c7770e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspssj.x @@ -0,0 +1,24 @@ +include "fitsio.h" + +procedure fspssj(iunit,group,naxis,naxes,fpixel,lpixel,array,status) + +# Write a subsection of integer values to the primary array. +# A subsection is defined to be any contiguous rectangular +# array of pixels within the n-dimensional FITS data file. +# Data conversion and scaling will be performed if necessary +# (e.g, if the datatype of the FITS array is not the same +# as the array being read). + +int iunit # i input file pointer +int group # i group number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int fpixel[ARB] # i first pixel +int lpixel[ARB] # i last pixel +int array[ARB] # i array of values +int status # o error status + +begin + +call ftpssj(iunit,group,naxis,naxes,fpixel,lpixel,array,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspsvc.x b/pkg/tbtables/fitsio/fitssppb/fspsvc.x new file mode 100644 index 00000000..2c6ac3eb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspsvc.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fspsvc(keyrec,value,comm,status) + +# parse the header record to find value and comment strings + +char keyrec[SZ_FCARD] # i header keyword string +% character fkeyre*80 +char value[SZ_FSTRVAL] # o data value +% character fvalue*70 +char comm[SZ_FCOMMENT] # o keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keyrec,fkeyre,SZ_FCARD) + +call ftpsvc(fkeyre,fvalue,fcomm,status) + +call f77upk(fvalue ,value,SZ_FSTRVAL) +call f77upk(fcomm ,comm ,SZ_FCOMMENT) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsptbb.x b/pkg/tbtables/fitsio/fitssppb/fsptbb.x new file mode 100644 index 00000000..1f424db2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsptbb.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fsptbb(iunit,frow,fchar,nchars,value,status) + +# write a consecutive string of bytes to an ascii or binary +# table. This will span multiple rows of the table if NCHARS+FCHAR is +# greater than the length of a row. + +int iunit # i input file pointer +int frow # i first row +int fchar # i first character +int nchars # i number of bytes +int value[ARB] # i data value +int status # o error status + +begin + +call ftptbb(iunit,frow,fchar,nchars,value,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsptbs.x b/pkg/tbtables/fitsio/fitssppb/fsptbs.x new file mode 100644 index 00000000..c1c52b40 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsptbs.x @@ -0,0 +1,38 @@ +include "fitsio.h" + +procedure fsptbs(iunit,frow,fchar,nchars,svalue,status) + +# write a consecutive string of characters to an ascii or binary +# table. This will span multiple rows of the table if NCHARS+FCHAR is +# greater than the length of a row. + +int iunit # i input file pointer +int frow # i first row +int fchar # i first character +int nchars # i number of characters +char svalue[ARB] # i string value +% character fsvalu*256 +int status # o error status +int readfirst +int writefirst +int ntodo +int itodo + +begin + +# since the string may be arbitrarily long, write it in pieces +readfirst=1 +writefirst=fchar +ntodo=nchars +itodo=min(256,ntodo) + +while (itodo > 0) { + call f77pak(svalue[readfirst],fsvalu,itodo) + call ftptbs(iunit,frow,writefirst,itodo,fsvalu,status) + writefirst=writefirst+itodo + readfirst=readfirst+itodo + ntodo=ntodo-itodo + itodo=min(256,ntodo) + } + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsptdm.x b/pkg/tbtables/fitsio/fitssppb/fsptdm.x new file mode 100644 index 00000000..32f96fca --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsptdm.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fsptdm(ounit,colnum,naxis,naxes,status) + +# write the TDIMnnn keyword + +int ounit # i output file pointer +int colnum # i column number +int naxis # i number of axes +int naxes[ARB] # i dimension of each axis +int status # o error status + +begin + +call ftptdm(ounit,colnum,naxis,naxes,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fspthp.x b/pkg/tbtables/fitsio/fitssppb/fspthp.x new file mode 100644 index 00000000..1c11c2e9 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fspthp.x @@ -0,0 +1,18 @@ +include "fitsio.h" + +procedure fspthp(ounit,heap,status) + +# Define the starting address for the heap for a binary table. +# The default address is NAXIS1 * NAXIS2. It is in units of +# bytes relative to the beginning of the regular binary table data. +# This routine also writes the appropriate THEAP keyword to the +# FITS header. + +int ounit # i output file pointer +int heap # i heap starting address +int status # o error status + +begin + +call ftpthp(ounit,heap,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsrdef.x b/pkg/tbtables/fitsio/fitssppb/fsrdef.x new file mode 100644 index 00000000..afa92419 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsrdef.x @@ -0,0 +1,15 @@ +include "fitsio.h" + +procedure fsrdef(ounit,status) + +# Data DEFinition +# re-define the length of the data unit +# this simply redefines the start of the next HDU + +int ounit # i output file pointer +int status # o error status + +begin + +call ftrdef(ounit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fssnul.x b/pkg/tbtables/fitsio/fitssppb/fssnul.x new file mode 100644 index 00000000..6a11962b --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fssnul.x @@ -0,0 +1,19 @@ +include "fitsio.h" + +procedure fssnul(ounit,colnum,nulval,status) + +# ascii table Column NULl value definition +# Define the null value for an ASCII table column. + +int ounit # i output file pointer +int colnum # i column number +char nulval # i value for undefined pixels +% character*16 fnulva +int status # o error status + +begin + +call f77pak(nulval,fnulva,16) + +call ftsnul(ounit,colnum,fnulva,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fstkey.x b/pkg/tbtables/fitsio/fitssppb/fstkey.x new file mode 100644 index 00000000..0b98485e --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fstkey.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fstkey(keywrd,status) + +# test that keyword name contains only legal characters: +# uppercase letters, numbers, hyphen, underscore, or space + +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) + +call fttkey(fkeywr,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fstnul.x b/pkg/tbtables/fitsio/fitssppb/fstnul.x new file mode 100644 index 00000000..1c8997b4 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fstnul.x @@ -0,0 +1,16 @@ +include "fitsio.h" + +procedure fstnul(ounit,colnum,inull,status) + +# Table column NULl value definition +# Define the null value for an integer binary table column + +int ounit # i output file pointer +int colnum # i column number +int inull # integer null value +int status # o error status + +begin + +call fttnul(ounit,colnum,inull,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fstscl.x b/pkg/tbtables/fitsio/fitssppb/fstscl.x new file mode 100644 index 00000000..09d86cb2 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fstscl.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fstscl(ounit,colnum,bscale,bzero,status) + +# Table column SCaLing factor definition +# Define the scaling factor for a table column. + +int ounit # i output file pointer +int colnum # i column number +double bscale # i scaling factor +double bzero # i scaling zeropoint +int status # o error status + +begin + +call fttscl(ounit,colnum,bscale,bzero,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsucks.x b/pkg/tbtables/fitsio/fitssppb/fsucks.x new file mode 100644 index 00000000..d024f2d8 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsucks.x @@ -0,0 +1,11 @@ +include "fitsio.h" + +procedure fsucks(iunit,status) + +int iunit +int status # o error status + +begin + +call ftucks(iunit,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsucrd.x b/pkg/tbtables/fitsio/fitssppb/fsucrd.x new file mode 100644 index 00000000..70c0a609 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsucrd.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsucrd(ounit,keywrd,card,status) + +# update a given header record specified by keyword name. +# new record is appended to header if it doesn't exist. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char card[SZ_FCARD] # i 80-char header record +% character fcard*80 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(card ,fcard, SZ_FCARD) + +call ftucrd(ounit,fkeywr,fcard,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukyd.x b/pkg/tbtables/fitsio/fitssppb/fsukyd.x new file mode 100644 index 00000000..1de99474 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukyd.x @@ -0,0 +1,25 @@ +include "fitsio.h" + +procedure fsukyd(ounit,keywrd,dval,decim,comm,status) + +# update a double precision value header record in E format +# If it will fit, the value field will be 20 characters wide; +# otherwise it will be expanded to up to 35 characters, left +# justified. + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukyd(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukye.x b/pkg/tbtables/fitsio/fitssppb/fsukye.x new file mode 100644 index 00000000..31668640 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukye.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsukye(ounit,keywrd,rval,decim,comm,status) + +# update a real*4 value header record in E format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukye(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukyf.x b/pkg/tbtables/fitsio/fitssppb/fsukyf.x new file mode 100644 index 00000000..6c8fa1eb --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukyf.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsukyf(ounit,keywrd,rval,decim,comm,status) + +# update a real*4 value header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +real rval # i real*4 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukyf(ounit,fkeywr,rval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukyg.x b/pkg/tbtables/fitsio/fitssppb/fsukyg.x new file mode 100644 index 00000000..8922299a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukyg.x @@ -0,0 +1,22 @@ +include "fitsio.h" + +procedure fsukyg(ounit,keywrd,dval,decim,comm,status) + +# update a double precision value header record in F format + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +double dval # i real*8 value +int decim # i number of decimal plac +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukyg(ounit,fkeywr,dval,decim,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukyj.x b/pkg/tbtables/fitsio/fitssppb/fsukyj.x new file mode 100644 index 00000000..2a639547 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukyj.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsukyj(ounit,keywrd,intval,comm,status) + +# update an integer value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +int intval # i integer value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukyj(ounit,fkeywr,intval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukyl.x b/pkg/tbtables/fitsio/fitssppb/fsukyl.x new file mode 100644 index 00000000..4f32127c --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukyl.x @@ -0,0 +1,21 @@ +include "fitsio.h" + +procedure fsukyl(ounit,keywrd,logval,comm,status) + +# update a logical value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +bool logval # i logical value +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukyl(ounit,fkeywr,logval,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsukys.x b/pkg/tbtables/fitsio/fitssppb/fsukys.x new file mode 100644 index 00000000..71ba3696 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsukys.x @@ -0,0 +1,23 @@ +include "fitsio.h" + +procedure fsukys(ounit,keywrd,strval,comm,status) + +# update a character string value header record + +int ounit # i output file pointer +char keywrd[SZ_FKEYWORD] # i keyword name +% character fkeywr*8 +char strval[SZ_FSTRVAL] # i string value +% character fstrva*70 +char comm[SZ_FCOMMENT] # i keyword comment +% character fcomm*48 +int status # o error status + +begin + +call f77pak(keywrd,fkeywr,SZ_FKEYWORD) +call f77pak(strval,fstrva,SZ_FSTRVAL) +call f77pak(comm ,fcomm ,SZ_FCOMMENT) + +call ftukys(ounit,fkeywr,fstrva,fcomm,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsvcks.x b/pkg/tbtables/fitsio/fitssppb/fsvcks.x new file mode 100644 index 00000000..17149c03 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsvcks.x @@ -0,0 +1,13 @@ +include "fitsio.h" + +procedure fsvcks(iunit,dataok,hduok,status) + +int iunit +int dataok +int hduok +int status # o error status + +begin + +call ftvcks(iunit,dataok,hduok,status) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsvers.x b/pkg/tbtables/fitsio/fitssppb/fsvers.x new file mode 100644 index 00000000..09f1a8e6 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsvers.x @@ -0,0 +1,14 @@ +include "fitsio.h" + +procedure fsvers(vernum) + +# Returns the current revision number of the FITSIO package. +# The revision number will be incremented whenever any modifications, +# bug fixes, or enhancements are made to the package + +real vernum # o FITSIO version number + +begin + +call ftvers(vernum) +end diff --git a/pkg/tbtables/fitsio/fitssppb/fswldp.x b/pkg/tbtables/fitsio/fitssppb/fswldp.x new file mode 100644 index 00000000..006b0480 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fswldp.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fswldp(xpix,ypix,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,coord, + xpos,ypos,status) + +double xpix,ypix,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,xpos,ypos +char coord[4] +% character fcoord*4 +int status # o error status + +begin + +call f77pak(coord,fcoord,4) +call ftwldp(xpix,ypix,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,fcoord, + xpos,ypos,status) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/fsxypx.x b/pkg/tbtables/fitsio/fitssppb/fsxypx.x new file mode 100644 index 00000000..a6343d0a --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/fsxypx.x @@ -0,0 +1,17 @@ +include "fitsio.h" + +procedure fsxypx(xpos,ypos,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,coord, + xpix,ypix,status) + +double xpix,ypix,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,xpos,ypos +char coord[4] +% character fcoord*4 +int status # o error status + +begin + +call f77pak(coord,fcoord,4) +call ftxypx(xpos,ypos,xrval,yrval,xrpix,yrpix,xinc,yinc,rot,fcoord, + xpix,ypix,status) + +end diff --git a/pkg/tbtables/fitsio/fitssppb/mkpkg b/pkg/tbtables/fitsio/fitssppb/mkpkg new file mode 100644 index 00000000..0b527127 --- /dev/null +++ b/pkg/tbtables/fitsio/fitssppb/mkpkg @@ -0,0 +1,262 @@ +# FITSIO -- This IRAF mkpkg file updates the TBTABLES library to include +# the FITSIO interface. + +tbtables: +$checkout libtbtables.a ../ +$update libtbtables.a +$checkin libtbtables.a ../ +$exit + +libtbtables.a: + fsadef.x + fsarch.x + fsasfm.x + fsbdef.x + fsbnfm.x + fsclos.x + fscmps.x + fscmsg.x + fscopy.x + fscpdt.x + fscrhd.x + fsdcol.x + fsddef.x + fsdelt.x + fsdhdu.x + fsdkey.x + fsdrec.x + fsdrow.x + fsdsum.x + fsdtyp.x + fsesum.x + fsfiou.x + fsg2db.x + fsg2dd.x + fsg2de.x + fsg2di.x + fsg2dj.x + fsg3db.x + fsg3dd.x + fsg3de.x + fsg3di.x + fsg3dj.x + fsgabc.x + fsgacl.x + fsgbcl.x + fsgcfb.x + fsgcfc.x + fsgcfd.x + fsgcfe.x + fsgcfi.x + fsgcfj.x + fsgcfl.x + fsgcfm.x + fsgcfs.x + fsgcks.x + fsgcl.x + fsgcnn.x + fsgcno.x + fsgcrd.x + fsgcvb.x + fsgcvc.x + fsgcvd.x + fsgcve.x + fsgcvi.x + fsgcvj.x + fsgcvm.x + fsgcvs.x + fsgcx.x + fsgcxd.x + fsgcxi.x + fsgcxj.x + fsgdes.x + fsgerr.x + fsggpb.x + fsggpd.x + fsggpe.x + fsggpi.x + fsggpj.x + fsghad.x + fsghbn.x + fsghdn.x + fsghpr.x + fsghps.x + fsghsp.x + fsghtb.x + fsgics.x + fsgiou.x + fsgkey.x + fsgknd.x + fsgkne.x + fsgknj.x + fsgknl.x + fsgkns.x + fsgkyd.x + fsgkye.x + fsgkyj.x + fsgkyl.x + fsgkyn.x + fsgkys.x + fsgkyt.x + fsgmsg.x + fsgpfb.x + fsgpfd.x + fsgpfe.x + fsgpfi.x + fsgpfj.x + fsgpvb.x + fsgpvd.x + fsgpve.x + fsgpvi.x + fsgpvj.x + fsgrec.x + fsgrsz.x + fsgsdt.x + fsgsfb.x + fsgsfd.x + fsgsfe.x + fsgsfi.x + fsgsfj.x + fsgsvb.x + fsgsvd.x + fsgsve.x + fsgsvi.x + fsgsvj.x + fsgtbb.x + fsgtbs.x + fsgtcl.x + fsgtcs.x + fsgtdm.x + fsgthd.x + fshdef.x + fsibin.x + fsicol.x + fsiimg.x + fsikyd.x + fsikye.x + fsikyf.x + fsikyg.x + fsikyj.x + fsikyl.x + fsikys.x + fsinit.x + fsirec.x + fsirow.x + fsitab.x + fskeyn.x + fsmahd.x + fsmcom.x + fsmcrd.x + fsmkyd.x + fsmkye.x + fsmkyf.x + fsmkyg.x + fsmkyj.x + fsmkyl.x + fsmkys.x + fsmnam.x + fsmrec.x + fsmrhd.x + fsnkey.x + fsopen.x + fsp2db.x + fsp2dd.x + fsp2de.x + fsp2di.x + fsp2dj.x + fsp3db.x + fsp3dd.x + fsp3de.x + fsp3di.x + fsp3dj.x + fspcks.x + fspclb.x + fspclc.x + fspcld.x + fspcle.x + fspcli.x + fspclj.x + fspcll.x + fspclm.x + fspcls.x + fspclu.x + fspclx.x + fspcnb.x + fspcnd.x + fspcne.x + fspcni.x + fspcnj.x + fspcom.x + fspdat.x + fspdef.x + fspdes.x + fspgpb.x + fspgpd.x + fspgpe.x + fspgpi.x + fspgpj.x + fsphbn.x + fsphis.x + fsphpr.x + fsphtb.x + fspkls.x + fspknd.x + fspkne.x + fspknf.x + fspkng.x + fspknj.x + fspknl.x + fspkns.x + fspkyd.x + fspkye.x + fspkyf.x + fspkyg.x + fspkyj.x + fspkyl.x + fspkys.x + fspkyt.x + fsplsw.x + fspmsg.x + fspnul.x + fsppnb.x + fsppnd.x + fsppne.x + fsppni.x + fsppnj.x + fspprb.x + fspprd.x + fsppre.x + fsppri.x + fspprj.x + fsppru.x + fsprec.x + fspscl.x + fspssb.x + fspssd.x + fspsse.x + fspssi.x + fspssj.x + fspsvc.x + fsptbb.x + fsptbs.x + fsptdm.x + fspthp.x + fsrdef.x + fssnul.x + fstkey.x + fstnul.x + fstscl.x + fsucks.x + fsucrd.x + fsukyd.x + fsukye.x + fsukyf.x + fsukyg.x + fsukyj.x + fsukyl.x + fsukys.x + fsvcks.x + fsvers.x + fswldp.x + fsxypx.x + ; diff --git a/pkg/tbtables/fitsio/ftadef.f b/pkg/tbtables/fitsio/ftadef.f new file mode 100644 index 00000000..5c516448 --- /dev/null +++ b/pkg/tbtables/fitsio/ftadef.f @@ -0,0 +1,143 @@ +C-------------------------------------------------------------------------- + subroutine ftadef(ounit,lenrow,nfield,bcol,tform,nrows,status) + +C Ascii table data DEFinition +C define the structure of the ASCII table data unit +C +C ounit i Fortran I/O unit number +C lenrow i length of a row, in characters +C nfield i number of fields in the table +C bcol i starting position of each column, (starting with 1) +C tform C the data format of the column +C nrows i number of rows in the table +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,lenrow,nfield,bcol(*),nrows,status + character*(*) tform(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,j,clen,c2 + character ctemp*24, cnum*3,cbcol*10,caxis1*10 + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + + if (dtstrt(ibuff) .lt. 0)then +C freeze the header at its current size + call fthdef(ounit,0,status) + if (status .gt. 0)return + end if + + hdutyp(ibuff)=1 + tfield(ibuff)=nfield + + if (nxtfld + nfield .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + return + end if + + tstart(ibuff)=nxtfld + nxtfld=nxtfld+nfield + + if (nfield .eq. 0)then +C no data; the next HDU begins in the next logical block + hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff) + scount(ibuff)=0 + theap(ibuff)=0 + nxheap(ibuff)=0 + else +C initialize the table column parameters + clen=len(tform(1)) + do 20 i=1,nfield + tscale(i+tstart(ibuff))=1. + tzero(i+tstart(ibuff))=0. +C choose special value to indicate null values are not defined + cnull(i+tstart(ibuff))=char(1) + cform(i+tstart(ibuff))=tform(i) + tbcol(i+tstart(ibuff))=bcol(i)-1 + tdtype(i+tstart(ibuff))=16 +C the repeat count is always one for ASCII tables + trept(i+tstart(ibuff))=1 +C store the width of the field in TNULL + c2=0 + do 10 j=2,clen + if (tform(i)(j:j) .ge. '0' .and. + & tform(i)(j:j) .le. '9')then + c2=j + else + go to 15 + end if +10 continue +15 continue + if (c2 .eq. 0)then +C no explicit width, so assume width of 1 character + tnull(i+tstart(ibuff))=1 + else + call ftc2ii(tform(i)(2:c2),tnull(i+tstart(ibuff)) + & ,status) + if (status .gt. 0)then +C error parsing TFORM to determine field width + status=261 + ctemp=tform(i) + call ftpmsg('Error parsing TFORM to get field' + & //' width: '//ctemp) + return + end if + end if + +C check that column fits within the table + if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) + & .gt. lenrow .and. lenrow .ne. 0)then + status=236 + write(cnum,1000)i + write(cbcol,1001)bcol(i) + write(caxis1,1001)lenrow +1000 format(i3) +1001 format(i10) + call ftpmsg('Column '//cnum//' will not fit '// + & 'within the specified width of the ASCII table.') + + call ftpmsg('TFORM='//cform(i+tstart(ibuff))// + & ' TBCOL='//cbcol//' NAXIS1='//caxis1) + return + end if +20 continue + +C calculate the start of the next header unit, based on the +C size of the data unit + rowlen(ibuff)=lenrow + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(lenrow*nrows+2879)/2880*2880 + +C initialize the fictitious heap starting address (immediately following +C the table data) and a zero length heap. This is used to find the +C end of the table data when checking the fill values in the last block. +C ASCII tables have no special data area + scount(ibuff)=0 + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=0 + end if + end diff --git a/pkg/tbtables/fitsio/ftaini.f b/pkg/tbtables/fitsio/ftaini.f new file mode 100644 index 00000000..1f7d2d70 --- /dev/null +++ b/pkg/tbtables/fitsio/ftaini.f @@ -0,0 +1,183 @@ +C-------------------------------------------------------------------------- + subroutine ftaini(iunit,status) + +C initialize the parameters defining the structure of an ASCII table + +C iunit i Fortran I/O unit number +C OUTPUT PARAMETERS: +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer nrows,tfld,nkey,ibuff,i,nblank + character keynam*8,value*70,comm*72,rec*80 + character cnum*3,cbcol*10,caxis1*10 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C store the type of HDU (1 = ASCII table extension) + hdutyp(ibuff)=1 + +C temporarily set the location of the end of the header to a huge number + hdend(ibuff)=2000000000 + hdstrt(ibuff,chdu(ibuff)+1)=2000000000 + +C check that this is a valid ASCII table, and get parameters + call ftgttb(iunit,rowlen(ibuff),nrows,tfld,status) + if (status .gt. 0)go to 900 + + if (tfld .gt. nf)then +C arrays not dimensioned large enough for this many fields + status=111 + call ftpmsg('This ASCII table has too many fields '// + & 'to be read with FITSIO (FTAINI).') + go to 900 + end if + +C store the number of fields in the common block + tfield(ibuff)=tfld + + if (nxtfld + tfld .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + return + end if + + tstart(ibuff)=nxtfld + nxtfld=nxtfld+tfld + +C initialize the table field parameters + do 5 i=1,tfld + tscale(i+tstart(ibuff))=1. + tzero(i+tstart(ibuff))=0. +C choose special value to indicate that null value is not defined + cnull(i+tstart(ibuff))=char(1) +C pre-set required keyword values to a null value + tbcol(i+tstart(ibuff))=-1 + tdtype(i+tstart(ibuff))=-9999 +5 continue + +C initialize the fictitious heap starting address (immediately following +C the table data) and a zero length heap. This is used to find the +C end of the table data when checking the fill values in the last block. +C there is no special data following an ASCII table + scount(ibuff)=0 + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=0 + +C now read through the rest of the header looking for table column +C definition keywords, and the END keyword. + + nkey=8 +8 nblank=0 +10 nkey=nkey+1 + call ftgrec(iunit,nkey,rec,status) + if (status .eq. 107)then +C if we hit the end of file, then set status = no END card found + status=210 + call ftpmsg('Required END keyword not found in ASCII table'// + & ' header (FTAINI).') + go to 900 + else if (status .gt. 0)then + go to 900 + end if + keynam=rec(1:8) + comm=rec(9:80) + + if (keynam(1:1) .eq. 'T')then +C get the ASCII table parameter (if it is one) + call ftpsvc(rec,value,comm,status) + call ftgatp(ibuff,keynam,value,status) + else if (keynam .eq. ' ' .and. comm .eq. ' ')then + nblank=nblank+1 + go to 10 + else if (keynam .eq. 'END')then + go to 20 + end if + go to 8 + +20 continue + +C test that all the required keywords were found + do 25 i=1,tfld + if (tbcol(i+tstart(ibuff)) .eq. -1)then + status=231 + call ftkeyn('TBCOL',i,keynam,status) + call ftpmsg('Required '//keynam// + & ' keyword not found (FTAINI).') + return + else if (tbcol(i+tstart(ibuff)) .lt. 0 .or. + & tbcol(i+tstart(ibuff)) .ge. rowlen(ibuff) + & .and. rowlen(ibuff) .ne. 0)then + status=234 + call ftkeyn('TBCOL',i,keynam,status) + call ftpmsg('Value of the '//keynam// + & ' keyword is out of range (FTAINI).') + return + +C check that column fits within the table + else if (tbcol(i+tstart(ibuff))+tnull(i+tstart(ibuff)) .gt. + & rowlen(ibuff) .and. rowlen(ibuff) .ne. 0)then + status=236 + write(cnum,1000)i + write(cbcol,1001)tbcol(i+tstart(ibuff))+1 + write(caxis1,1001)rowlen(ibuff) +1000 format(i3) +1001 format(i10) + call ftpmsg('Column '//cnum//' will not fit '// + & 'within the specified width of the ASCII table.') + + call ftpmsg('TFORM='//cform(i+tstart(ibuff))// + & ' TBCOL='//cbcol//' NAXIS1='//caxis1) + return + else if (tdtype(i+tstart(ibuff)) .eq. -9999)then + status=232 + call ftkeyn('TFORM',i,keynam,status) + call ftpmsg('Required '//keynam// + & ' keyword not found (FTAINI).') + return + end if +25 continue + +C now we know everything about the table; just fill in the parameters: +C the 'END' record begins 80 bytes before the current position, +C ignoring any trailing blank keywords just before the END keyword + hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) + +C the data unit begins at the beginning of the next logical block + dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 + +C reset header pointer to the first keyword + nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) + +C the next HDU begins in the next logical block after the data + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(rowlen(ibuff)*nrows+2879)/2880*2880 + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftarch.f b/pkg/tbtables/fitsio/ftarch.f new file mode 100644 index 00000000..25d9525c --- /dev/null +++ b/pkg/tbtables/fitsio/ftarch.f @@ -0,0 +1,40 @@ +C------------------------------------------------------------------------------ + subroutine ftarch(compid) + +C This routine looks at how integers and reals are internally +C stored, to figure out what kind of machine it is running on. + +C compid = 1 - VAX or Alpha VMS system +C 2 - Decstation or Alpha OSF/1, or IBM PC +C 3 - SUN workstation +C 4 - IBM mainframe + + integer compid + real rword + integer*2 iword(2) + equivalence (rword, iword) + +C set rword to some arbitrary value + rword=1.1111111111 + +C Then look at the equivalent integer, to distinquish the machine type. +C The machine type is needed when testing for NaNs. + + if (iword(1) .eq. 16270)then +C looks like a SUN workstation (uses IEEE word format) + compid=3 + else if (iword(1) .eq. 14564)then +C looks like a Decstation, alpha OSF/1, or IBM PC (byte swapped) + compid=2 + else if (iword(1) .eq. 16526)then +C looks like a VAX or ALPHA VMS system + compid=1 + else if (iword(1) .eq. 16657)then +C an IBM main frame (the test for NaNs is the same as on SUNs) + compid=4 + else +C unknown machine + compid=0 + return + end if + end diff --git a/pkg/tbtables/fitsio/ftas2c.f b/pkg/tbtables/fitsio/ftas2c.f new file mode 100644 index 00000000..069b2af0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftas2c.f @@ -0,0 +1,52 @@ +C-------------------------------------------------------------------------- + subroutine ftas2c(array,nchar) + +C convert characters in the array from ASCII codes to +C the machine's native character coding sequence + +C array c array of characters to be converted (in place) +C nchar i number of characters to convert + + character*(*) array + integer nchar,i + + integer ebcd1(128),ebcd2(128),ebcdic(256) + equivalence(ebcd1(1),ebcdic(1)) + equivalence(ebcd2(1),ebcdic(129)) + integer compid + common/ftcpid/compid + +C The following look-up table gives the EBCDIC character code for +C the corresponding ASCII code. The conversion is not universally +C established, so some sites may need to modify this table. +C (The table has been broken into 2 arrays to reduce the number of +C continuation lines in a single statement). + + data ebcd1/0,1,2,3,55,45,46,47,22,5,37,11,12,13,14,15,16,17, + & 18,19,60,61,50,38,24,25,63,39,28,29,30,31,64,79,127,123,91,108, + & 80,125,77,93,92,78,107,96,75,97,240,241,242,243,244,245,246, + & 247,248,249,122,94,76,126,110,111,124,193,194,195,196,197, + & 198,199,200,201,209,210,211,212,213,214,215,216,217,226,227, + & 228,229,230,231,232,233,74,224,90,95,109,121,129,130,131,132, + & 133,134,135,136,137,145,146,147,148,149,150,151,152,153,162, + & 163,164,165,166,167,168,169,192,106,208,161,7/ + + data ebcd2/32,33,34,35,36,21, + & 6,23,40,41,42,43,44,9,10,27,48,49,26,51,52,53,54,8,56,57,58,59, + & 4,20,62,225,65,66,67,68,69,70,71,72,73,81,82,83,84,85,86,87,88, + & 89,98,99,100,101,102,103,104,105,112,113,114,115,116,117,118, + & 119,120,128,138,139,140,141,142,143,144,154,155,156,157,158,159, + & 160,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184, + & 185,186,187,188,189,190,191,202,203,204,205,206,207,218,219,220, + & 221,222,223,234,235,236,237,238,239,250,251,252,253,254,255/ + +C this conversion is only necessary on IBM mainframes (compid=4) +C This executable statement was originally located before the +C data statements, and it was moved here by PEH on 19 June 1998. + if (compid .ne. 4)return + + do 10 i=1,nchar +C find the internal equivalent of the character + array(i:i)=char(ebcdic(ichar(array(i:i))+1)) +10 continue + end diff --git a/pkg/tbtables/fitsio/ftasfm.f b/pkg/tbtables/fitsio/ftasfm.f new file mode 100644 index 00000000..0961ce28 --- /dev/null +++ b/pkg/tbtables/fitsio/ftasfm.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------- + subroutine ftasfm(form,dtype,width,decims,status) + +C 'ASCII Format' +C parse the ASCII table TFORM column format to determine the data +C type, the field width, and number of decimal places (if relevant) +C +C form c TFORM format string +C OUTPUT PARAMETERS: +C dattyp i datatype code +C width i width of the field +C decims i number of decimal places +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, November 1994 + + character*(*) form + integer dtype,width,decims,status + character dattyp*1,cform*16 + integer nc,c1,i,nw + + if (status .gt. 0)return + + cform=form + +C find first non-blank character + nc=len(form) + do 5 i=1,nc + if (form(i:i) .ne. ' ')then + c1=i + go to 10 + end if +5 continue + +C error: TFORM is a blank string + status=261 + call ftpmsg('The TFORM keyword has a blank value.') + return + +10 continue + +C now the chararcter at position c1 should be the data type code + dattyp=form(c1:c1) + +C set the numeric datatype code + if (dattyp .eq. 'I')then + dtype=41 + else if (dattyp .eq. 'E')then + dtype=42 + else if (dattyp .eq. 'F')then + dtype=42 + else if (dattyp .eq. 'D')then + dtype=82 + else if (dattyp .eq. 'A')then + dtype=16 + else +C unknown tform datatype code + status=262 + call ftpmsg('Unknown ASCII table TFORMn keyword '// + & 'datatype: '//cform) + return + end if + +C determine the field width + c1=c1+1 + nw=0 + do 40 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then + nw=nw+1 + else + go to 50 + end if +40 continue +50 continue + if (nw .eq. 0)then +C error, no width specified + go to 990 + else + call ftc2ii(form(c1:c1+nw-1),width,status) + if (status .gt. 0 .or. width .eq. 0)then +C unrecognized characters following the type code + go to 990 + end if + end if + +C determine the number of decimal places (if any) + decims=-1 + c1=c1+nw + if (form(c1:c1) .eq. '.')then + c1=c1+1 + nw=0 + do 60 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then + nw=nw+1 + else + go to 70 + end if +60 continue +70 continue + + if (nw .eq. 0)then +C error, no decimals specified + go to 990 + else + call ftc2ii(form(c1:c1+nw-1),decims,status) + if (status .gt. 0)then +C unrecognized characters + go to 990 + end if + end if + else if (form(c1:c1) .ne. ' ')then + go to 990 + end if + +C consistency checks + if (dattyp .eq. 'A' .or. dattyp .eq. 'I')then + if (decims .eq. -1)then + decims=0 + else + go to 990 + end if + else if (decims .eq. -1)then +C number of decmal places must be specified for D, E, or F fields + go to 990 + else if (decims .ge. width)then +C number of decimals must be less than the width + go to 990 + end if + + if (dattyp .eq. 'I')then +C set datatype to SHORT integer if 4 digits or less + if (width .le. 4)dtype=21 + else if (dattyp .eq. 'F')then +C set datatype to DOUBLE if 8 digits or more + if (width .ge. 8)dtype=82 + end if + + return + +990 continue + status=261 + call ftpmsg('Illegal ASCII table TFORMn keyword: '//cform) + end diff --git a/pkg/tbtables/fitsio/ftbdef.f b/pkg/tbtables/fitsio/ftbdef.f new file mode 100644 index 00000000..97c74cf7 --- /dev/null +++ b/pkg/tbtables/fitsio/ftbdef.f @@ -0,0 +1,121 @@ +C-------------------------------------------------------------------------- + subroutine ftbdef(ounit,nfield,tform,pcount,nrows,status) + +C Binary table data DEFinition +C define the structure of the binary table data unit +C +C ounit i Fortran I/O unit number +C nfield i number of fields in the table +C tform C the data format of the column +C nrows i number of rows in the table +C pcount i size in bytes of the special data block following the table +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nfield,nrows,pcount,status + character*(*) tform(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,j,width + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + + if (dtstrt(ibuff) .lt. 0)then +C freeze the header at its current size + call fthdef(ounit,0,status) + if (status .gt. 0)return + end if + + hdutyp(ibuff)=2 + tfield(ibuff)=nfield + + if (nxtfld + nfield .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + return + end if + + tstart(ibuff)=nxtfld + nxtfld=nxtfld+nfield + + if (nfield .eq. 0)then +C no data; the next HDU begins in the next logical block + hdstrt(ibuff,chdu(ibuff)+1)=dtstrt(ibuff) + scount(ibuff)=0 + theap(ibuff)=0 + nxheap(ibuff)=0 + else +C initialize the table column parameters + do 5 i=1,nfield + tscale(i+tstart(ibuff))=1. + tzero(i+tstart(ibuff))=0. +C choose special value to indicate that null value is not defined + tnull(i+tstart(ibuff))=123454321 +C reset character NUL string, in case it has been +C previously defined from an ASCII table extension + cnull(i+tstart(ibuff))=char(0) + +C parse the tform strings to get the data type and repeat count + call ftbnfm(tform(i),tdtype(i+tstart(ibuff)), + & trept(i+tstart(ibuff)),width,status) + if (tdtype(i+tstart(ibuff)) .eq. 1)then +C treat Bit datatype as if it were a Byte datatype + tdtype(i+tstart(ibuff))=11 + trept(i+tstart(ibuff))=(trept(i+tstart(ibuff))+7)/8 + else if (tdtype(i+tstart(ibuff)) .eq. 16)then +C store ASCII unit string length in TNULL parameter + tnull(i+tstart(ibuff))=width + end if + if (status .gt. 0)return +5 continue + +C determine byte offset of the beginning of each field and row length + call ftgtbc(nfield,tdtype(1+tstart(ibuff)),trept(1+ + & tstart(ibuff)),tbcol(1+tstart(ibuff)),rowlen(ibuff), + & status) + +C FITSIO deals with ASCII columns as arrays of strings, not +C arrays of characters, so need to change the repeat count +C to indicate the number of strings in the field, not the +C total number of characters in the field. + do 10 i=1,nfield + if (tdtype(i+tstart(ibuff)) .eq. 16)then + j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff)) + trept(i+tstart(ibuff))=max(j,1) + end if +10 continue + +C initialize the heap offset (=nrows x ncolumns) +C store the size of the special data area, if any + scount(ibuff)=pcount + theap(ibuff)=nrows*rowlen(ibuff) + nxheap(ibuff)=0 + +C calculate the start of the next header unit, based on the +C size of the data unit (table + special data) + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcount+2879)/2880*2880 + end if + end diff --git a/pkg/tbtables/fitsio/ftbini.f b/pkg/tbtables/fitsio/ftbini.f new file mode 100644 index 00000000..5f39e763 --- /dev/null +++ b/pkg/tbtables/fitsio/ftbini.f @@ -0,0 +1,181 @@ +C-------------------------------------------------------------------------- + subroutine ftbini(iunit,status) + +C initialize the parameters defining the structure of a binary table + +C iunit i Fortran I/O unit number +C OUTPUT PARAMETERS: +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer lenrow,nrows,pcnt,tfld,nkey,ibuff,i,j,nblank + character keynam*8,value*70,comm*72,cnaxis*8,clen*8,rec*80 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C store the type of HDU (2 = Binary table extension) + hdutyp(ibuff)=2 + +C temporarily set the location of the end of the header to a huge number + hdend(ibuff)=2000000000 + hdstrt(ibuff,chdu(ibuff)+1)=2000000000 + +C check that this is a valid binary table, and get parameters + call ftgtbn(iunit,rowlen(ibuff),nrows,pcnt,tfld,status) + if (status .gt. 0)go to 900 + + if (tfld .gt. nf)then +C arrays not dimensioned large enough for this many fields + status=111 + call ftpmsg('This Binary table has too many fields '// + & 'to be read with FITSIO (FTBINI).') + go to 900 + end if + +C store the number of fields in the common block + tfield(ibuff)=tfld + + if (nxtfld + tfld .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + return + end if + + tstart(ibuff)=nxtfld + nxtfld=nxtfld+tfld + +C initialize the table field parameters + do 5 i=1,tfld + tscale(i+tstart(ibuff))=1. + tzero(i+tstart(ibuff))=0. + tnull(i+tstart(ibuff))=123454321 + tdtype(i+tstart(ibuff))=-9999 + trept(i+tstart(ibuff))=0 +C reset character NUL string, in case it has been previously +C defined from an ASCII table extension + cnull(i+tstart(ibuff))=char(0) +5 continue + +C initialize the default heap starting address (immediately following +C the table data) and set the next empty heap address +C PCOUNT specifies the amount of special data following the table + scount(ibuff)=pcnt + theap(ibuff)=rowlen(ibuff)*nrows + nxheap(ibuff)=pcnt + +C now read through the rest of the header looking for table column +C definition keywords, and the END keyword. + + nkey=8 +8 nblank=0 +10 nkey=nkey+1 + call ftgrec(iunit,nkey,rec,status) + if (status .eq. 107)then +C if we hit the end of file, then set status = no END card found + status=210 + call ftpmsg('Required END keyword not found in Binary table'// + & ' header (FTBINI).') + go to 900 + else if (status .gt. 0)then + go to 900 + end if + keynam=rec(1:8) + comm=rec(9:80) + + if (keynam(1:1) .eq. 'T')then +C get the binary table parameter (if it is one) + call ftpsvc(rec,value,comm,status) + call ftgbtp(ibuff,keynam,value,status) + else if (keynam .eq. ' ' .and. comm .eq. ' ')then + nblank=nblank+1 + go to 10 + else if (keynam .eq. 'END')then + go to 20 + end if + go to 8 + +20 continue + +C test that all the required keywords were found + do 25 i=1,tfld + if (tdtype(i+tstart(ibuff)) .eq. -9999)then + status=232 + call ftkeyn('TFORM',i,keynam,status) + call ftpmsg('Required '//keynam// + & ' keyword not found (FTAINI).') + return + end if +25 continue + + +C now we know everything about the table; just fill in the parameters: +C the 'END' record begins 80 bytes before the current position, ignoring +C any trailing blank keywords just before the END keyword + hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) + +C the data unit begins at the beginning of the next logical block + dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 + +C reset header pointer to the first keyword + nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) + +C the next HDU begins in the next logical block after the data + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(rowlen(ibuff)*nrows+pcnt+2879)/2880*2880 + +C determine the byte offset of the beginning of each field and row length + if (tfld .gt. 0)then + call ftgtbc(tfld,tdtype(1+tstart(ibuff)), + & trept(1+tstart(ibuff)),tbcol(1+tstart(ibuff)),lenrow,status) + +C FITSIO deals with ASCII columns as arrays of strings, not +C arrays of characters, so need to change the repeat count +C to indicate the number of strings in the field, not the +C total number of characters in the field. + do 30 i=1,tfld + if (tdtype(i+tstart(ibuff)) .eq. 16)then + j=trept(i+tstart(ibuff))/tnull(i+tstart(ibuff)) + trept(i+tstart(ibuff))=max(j,1) + end if +30 continue + if (status .gt. 0)go to 900 + +C check that the sum of the column widths = NAXIS2 value + if (rowlen(ibuff) .ne. lenrow)then + status=241 + write(cnaxis,1001)rowlen(ibuff) + write(clen,1001)lenrow +1001 format(i8) + call ftpmsg('NAXIS1 ='//cnaxis//' not equal'// + & ' to the sum of the column widths ='//clen//' (FTBINI).') + end if + end if + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftbnfm.f b/pkg/tbtables/fitsio/ftbnfm.f new file mode 100644 index 00000000..92c18590 --- /dev/null +++ b/pkg/tbtables/fitsio/ftbnfm.f @@ -0,0 +1,137 @@ +C---------------------------------------------------------------------- + subroutine ftbnfm(form,dtype,rcount,width,status) + +C 'Binary Format' +C parse the binary table column format to determine the data +C type and the repeat count (and string width, if it is an ASCII field) +C +C form c format string +C OUTPUT PARAMETERS: +C dattyp i datatype code +C rcount i repeat count +C width i if ASCII field, this is the width of the unit string +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) form + integer dtype,rcount,width,status,tstat + character dattyp*1,cform*16 + integer point,nc,c1,i,nw + + if (status .gt. 0)return + + cform=form + +C find first non-blank character + nc=len(form) + do 5 i=1,nc + if (form(i:i) .ne. ' ')then + c1=i + go to 10 + end if +5 continue + +C error: TFORM is a blank string + status=261 + call ftpmsg('The TFORM keyword has a blank value.') + return + +10 continue + +C find the size of the field repeat count, if present + nw=0 + do 20 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i) .le. '9')then + nw=nw+1 + else + go to 30 + end if +20 continue +30 continue + if (nw .eq. 0)then +C no explicit repeat count, so assume a value of 1 + rcount=1 + else + call ftc2ii(form(c1:c1+nw-1),rcount,status) + if (status .gt. 0)then + call ftpmsg('Error in FTBNFM evaluating TFORM' + & //' repeat value: '//cform) + return + end if + end if + + c1=c1+nw + +C see if this is a variable length pointer column (e.g., 'rPt'); if so, +C then add 1 to the starting search position in the TFORM string + if (form(c1:c1) .eq. 'P')then + point=-1 + c1=c1+1 + rcount=1 + else + point=1 + end if + +C now the chararcter at position c1 should be the data type code + dattyp=form(c1:c1) + +C set the numeric datatype code + if (dattyp .eq. 'I')then + dtype=21 + else if (dattyp .eq. 'J')then + dtype=41 + else if (dattyp .eq. 'E')then + dtype=42 + else if (dattyp .eq. 'D')then + dtype=82 + else if (dattyp .eq. 'A')then + dtype=16 + else if (dattyp .eq. 'L')then + dtype=14 + else if (dattyp .eq. 'X')then + dtype=1 + else if (dattyp .eq. 'B')then + dtype=11 + else if (dattyp .eq. 'C')then + dtype=83 + else if (dattyp .eq. 'M')then + dtype=163 + else +C unknown tform datatype code + status=262 + call ftpmsg('Unknown Binary table TFORMn keyword '// + & 'datatype: '//cform) + return + end if + +C set dtype negative if this is a variable length field ('P') + dtype=dtype*point + +C if this is an ASCII field, determine its width + if (dtype .eq. 16)then + c1=c1+1 + nw=0 + do 40 i=c1,nc + if (form(i:i) .ge. '0' .and. form(i:i).le.'9')then + nw=nw+1 + else + go to 50 + end if +40 continue +50 continue + if (nw .eq. 0)then +C no explicit width field, so assume that the +C width is the same as the repeat count + width=rcount + else + tstat=status + call ftc2ii(form(c1:c1+nw-1),width,status) + if (status .gt. 0)then +C unrecognized characters following the 'A', so ignore it + width=rcount + status=tstat + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftc2as.f b/pkg/tbtables/fitsio/ftc2as.f new file mode 100644 index 00000000..1658e851 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2as.f @@ -0,0 +1,54 @@ + +C-------------------------------------------------------------------------- + subroutine ftc2as(array,nchar) + +C convert characters from the machines +C native character coding sequence in to ASCII codes + +C array c array of characters to be converted (in place) +C nchar i number of characters to convert + + character*(*) array + integer nchar,i + + integer asci1(128),asci2(128),ascii(256) + equivalence (asci1(1),ascii(1)) + equivalence (asci2(1),ascii(129)) + integer compid + common/ftcpid/compid + +C The following look-up table gives the ASCII character code for +C the corresponding EBCDIC code. The conversion is not universally +C established, so some sites may need to modify this table. +C (The table has been broken into 2 arrays to reduce the number of +C continuation lines in a single statement). + + data asci1/0,1,2,3,156,9,134,127,151,141,142, 11, 12, 13, 14, 15, + & 16, 17, 18, 19,157,133, 8,135, 24, 25,146,143, 28, 29, 30, 31, + & 128,129,130,131,132, 10, 23, 27,136,137,138,139,140, 5, 6, 7, + & 144,145, 22,147,148,149,150, 4,152,153,154,155, 20, 21,158, 26, + & 32,160,161,162,163,164,165,166,167,168, 91, 46, 60, 40, 43, 33, + & 38,169,170,171,172,173,174,175,176,177, 93, 36, 42, 41, 59, 94, + & 45, 47,178,179,180,181,182,183,184,185,124, 44, 37, 95, 62, 63, + & 186,187,188,189,190,191,192,193,194, 96, 58, 35, 64, 39, 61, 34/ + + data asci2/ + & 195, 97, 98, 99,100,101,102,103,104,105,196,197,198,199,200,201, + & 202,106,107,108,109,110,111,112,113,114,203,204,205,206,207,208, + & 209,126,115,116,117,118,119,120,121,122,210,211,212,213,214,215, + & 216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231, + & 123, 65, 66, 67, 68, 69, 70, 71, 72, 73,232,233,234,235,236,237, + & 125, 74, 75, 76, 77, 78, 79, 80, 81, 82,238,239,240,241,242,243, + & 92,159, 83, 84, 85, 86, 87, 88, 89, 90,244,245,246,247,248,249, + & 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,250,251,252,253,254,255/ + +C this conversion is only necessary on IBM mainframes (compid=4) +C This executable statement was originally located before the +C data statements, and it was moved here by PEH on 19 June 1998. + if (compid .ne. 4)return + + do 10 i=1,nchar +C find the ASCII equivalent of the character + array(i:i)=char(ascii(ichar(array(i:i))+1)) +10 continue + end diff --git a/pkg/tbtables/fitsio/ftc2d.f b/pkg/tbtables/fitsio/ftc2d.f new file mode 100644 index 00000000..e8527312 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2d.f @@ -0,0 +1,38 @@ +C---------------------------------------------------------------------- + subroutine ftc2d(cval,dval,status) +C convert a character string to a double precision value +C perform datatype conversion, if required + + character*(*) cval + integer ival,status + character*1 dtype + logical lval + character*16 sval + double precision dval + + +C convert string to its intrinsic data type + call ftc2x(cval,dtype,ival,lval,sval,dval,status) + if (status .gt. 0)return + + if (dtype .eq. 'F')then +C no datatype conversion required, so just return + else if (dtype .eq. 'I')then +C convert from integer to double precision + dval=ival + else if (dtype .eq. 'L')then +C need to convert from logical to double precision + if (lval)then + dval=1. + else + dval=0. + end if + else if (dtype .eq. 'C')then +C can't convert a string to double precision, so return error + dval=0 + status=406 + sval=cval + call ftpmsg('Error in FTC2D evaluating this string '// + & 'as a double value: '//sval) + end if + end diff --git a/pkg/tbtables/fitsio/ftc2dd.f b/pkg/tbtables/fitsio/ftc2dd.f new file mode 100644 index 00000000..dfd7ac68 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2dd.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftc2dd(cval,val,status) + +C convert a character string to double prec. +C (assumes that the input string is left justified) +C cval c input character string to be converted +C val d output value +C status i output error status (0 = OK) + + character*(*) cval + double precision val + integer status,nleng + character iform*8,sval*16 + + if (status .gt. 0)return + +C find length of the input double character string + nleng=index(cval,' ')-1 + if (nleng .eq. -1)nleng=len(cval) + +C construct the format statement to read the character string + if (nleng .le. 9)then + write(iform,1000)nleng +1000 format('(F',I1,'.0)') + else + write(iform,1001)nleng +1001 format('(F',I2,'.0)') + end if + + read(cval,iform,err=900)val + return + +900 status=409 + sval=cval + call ftpmsg('Error in FTC2DD evaluating this string '// + & 'as a double: '//sval) + end diff --git a/pkg/tbtables/fitsio/ftc2i.f b/pkg/tbtables/fitsio/ftc2i.f new file mode 100644 index 00000000..f63493ec --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2i.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftc2i(cval,ival,status) +C convert a character string to an integer +C perform datatype conversion, if required + + integer ival,status + character*(*) cval + character*1 dtype + logical lval + character sval*16 + double precision dval + +C convert string to its intrinsic data type + call ftc2x(cval,dtype,ival,lval,sval,dval,status) + if (status .gt. 0)return + + if (dtype .eq. 'I')then +C no datatype conversion required, so just return + else if (dtype .eq. 'F')then +C need to convert from floating point to integer + ival=dval + else if (dtype .eq. 'L')then +C need to convert from logical to integer + if (lval)then + ival=1 + else + ival=0 + end if + else if (dtype .eq. 'C')then +C can't convert a string to an integer, so return error + ival=0 + status=403 + sval=cval + call ftpmsg('Error in FTC2I evaluating this string as an ' + & //'integer: '//sval) + end if + end diff --git a/pkg/tbtables/fitsio/ftc2ii.f b/pkg/tbtables/fitsio/ftc2ii.f new file mode 100644 index 00000000..350d51ee --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2ii.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftc2ii(cval,ival,status) +C convert a character string to an integer +C (assumes that the input string is left justified) + + integer ival,status,nleng + character*(*) cval + character*8 iform + + if (status .gt. 0)return + + if (cval .eq. ' ')go to 900 + +C find length of the input integer character string + nleng=index(cval,' ')-1 + if (nleng .eq. -1)nleng=len(cval) + +C construct the format statement to read the character string + if (nleng .le. 9)then + write(iform,1000)nleng +1000 format('(I',I1,')') + else + write(iform,1001)nleng +1001 format('(I',I2,')') + end if + + read(cval,iform,err=900)ival + return + +900 continue +C work around for bug in the DEC Alpha VMS compiler + if (cval(1:nleng) .eq. '-2147483648')then + ival=-2147483647 - 1 + else + status=407 + end if + end diff --git a/pkg/tbtables/fitsio/ftc2l.f b/pkg/tbtables/fitsio/ftc2l.f new file mode 100644 index 00000000..8a1e22ef --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2l.f @@ -0,0 +1,26 @@ +C---------------------------------------------------------------------- + subroutine ftc2l(cval,lval,status) + +C convert a character string to a logical value +C perform datatype conversion, if required + + logical lval + integer ival,status + character*(*) cval + character*1 dtype + character sval*16 + double precision dval + + +C convert string to its intrinsic data type + call ftc2x(cval,dtype,ival,lval,sval,dval,status) + if (status .gt. 0)return + + if (dtype .ne. 'L')then +C this is not a logical keyword, so return error + status=404 + sval=cval + call ftpmsg('Error in FTC2L evaluating this string '// + & 'as a logical value: '//sval) + end if + end diff --git a/pkg/tbtables/fitsio/ftc2ll.f b/pkg/tbtables/fitsio/ftc2ll.f new file mode 100644 index 00000000..83bb6d19 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2ll.f @@ -0,0 +1,18 @@ +C---------------------------------------------------------------------- + subroutine ftc2ll(cval,lval,status) +C convert a character string to a logical value +C (assumes that the input string is left justified) + integer status + logical lval + character*(*) cval + + if (status .gt. 0)return + +C convert character string to logical + if (cval(1:1) .eq.'T')then + lval=.true. + else +C any other character is considered false + lval=.false. + end if + end diff --git a/pkg/tbtables/fitsio/ftc2r.f b/pkg/tbtables/fitsio/ftc2r.f new file mode 100644 index 00000000..71909d70 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2r.f @@ -0,0 +1,40 @@ +C---------------------------------------------------------------------- + subroutine ftc2r(cval,rval,status) +C convert a character string to a real value +C perform datatype conversion, if required + + character*(*) cval + real rval + integer ival,status + character*1 dtype + logical lval + character*16 sval + double precision dval + + +C convert string to its intrinsic data type + call ftc2x(cval,dtype,ival,lval,sval,dval,status) + if (status .gt. 0)return + + if (dtype .eq. 'F')then +C convert from double to single precision + rval=dval + else if (dtype .eq. 'I')then +C convert from integer to real + rval=ival + else if (dtype .eq. 'L')then +C need to convert from logical to real + if (lval)then + rval=1. + else + rval=0. + end if + else if (dtype .eq. 'C')then +C can't convert a string to a real, so return error + rval=0 + status=405 + sval=cval + call ftpmsg('Error in FTC2R evaluating this string '// + & 'as a real value: '//sval) + end if + end diff --git a/pkg/tbtables/fitsio/ftc2rr.f b/pkg/tbtables/fitsio/ftc2rr.f new file mode 100644 index 00000000..8f11286e --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2rr.f @@ -0,0 +1,39 @@ +C---------------------------------------------------------------------- + subroutine ftc2rr(cval,val,status) + +C convert a character string to a real value +C (assumes that the input string is left justified) +C cval c input character string to be converted +C val r output value +C status i output error status (0 = OK) + + character*(*) cval + real val + integer status,nleng + character iform*8,sval*16 + + if (status .gt. 0)return + + if (cval .eq. ' ')go to 900 + +C find length of the input real character string + nleng=index(cval,' ')-1 + if (nleng .eq. -1)nleng=len(cval) + +C construct the format statement to read the character string + if (nleng .le. 9)then + write(iform,1000)nleng +1000 format('(F',I1,'.0)') + else + write(iform,1001)nleng +1001 format('(F',I2,'.0)') + end if + + read(cval,iform,err=900)val + return + +900 status=408 + sval=cval + call ftpmsg('Error in FTC2RR evaluating this string '// + & 'as a real: '//sval) + end diff --git a/pkg/tbtables/fitsio/ftc2s.f b/pkg/tbtables/fitsio/ftc2s.f new file mode 100644 index 00000000..460b7d34 --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2s.f @@ -0,0 +1,65 @@ +C---------------------------------------------------------------------- + subroutine ftc2s(in,cval,status) +C convert an input quoted string to an unquoted string +C +C The first character of the input string must be a quote character (') +C and at least one additional quote character must also be present in the +C input string. This routine then simply outputs all the characters +C between the first and last quote characters in the input string. +C +C in c input quoted string +C cval c output unquoted string +C status i output error status (0=ok, 1=first quote missing, +C 2=second quote character missing. + + character*(*) in,cval + integer length,i,j,i2,status + character*1 dtype + +C test for datatype + call ftdtyp(in,dtype,status) + if (status .gt. 0)return + if (dtype .ne. 'C')then +C do no conversion and just return the raw character string + cval=in + else +C convert character string to unquoted string + +C find closing quote character + length=len(in) + i2=length-1 + do 10 i=length,2,-1 + if (in(i:i) .eq. '''')go to 20 + i2=i2-1 +10 continue +20 continue + + if (i2 .eq. 0)then +C there was no closing quote character + status=205 + call ftpmsg('The following keyword value string has no ' + & //'closing quote:') + call ftpmsg(in) + else if (i2 .eq. 1)then +C null string + cval=' ' + else + cval=in(2:i2) + +C test for double single quote characters; if found, +C then delete one of the quotes (FITS uses 2 single +C quote characters to represent a single quote) + i2=i2-2 + do 30 i=1,i2 + if (cval(i:i) .eq. '''')then + if (cval(i+1:i+1) .eq. '''')then + do 40 j=i+1,i2 + cval(j:j)=cval(j+1:j+1) +40 continue + cval(i2:i2)=' ' + end if + end if +30 continue + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftc2x.f b/pkg/tbtables/fitsio/ftc2x.f new file mode 100644 index 00000000..804c251e --- /dev/null +++ b/pkg/tbtables/fitsio/ftc2x.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftc2x(cval,dtype,ival,lval,sval,dval,status) + +C convert a character string into it intrinsic data type + +C cval c input character string to be converted +C dtype c returned intrinsic datatype of the string (I,L,C,F) +C +C one of the following values is returned, corresponding to the +C value of dtype: +C ival i integer value +C lval l logical value +C sval c string value +C dval d double precision value +C statue i returned error status + + character*(*) cval + character*1 dtype + integer ival,status + logical lval + character*(*) sval + double precision dval + +C determine intrinsic datatype + call ftdtyp(cval,dtype,status) + +C convert string into its intrinsic datatype + if (dtype .eq. 'I')then + call ftc2ii(cval,ival,status) + else if (dtype .eq. 'F')then + call ftc2dd(cval,dval,status) + else if (dtype .eq. 'L')then + call ftc2ll(cval,lval,status) + else if (dtype .eq. 'C')then + call ftc2s(cval,sval,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftcdel.f b/pkg/tbtables/fitsio/ftcdel.f new file mode 100644 index 00000000..e228486d --- /dev/null +++ b/pkg/tbtables/fitsio/ftcdel.f @@ -0,0 +1,136 @@ +C-------------------------------------------------------------------------- + subroutine ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) + +C delete a specified column by shifting the rows + +C iunit i Fortran I/O unit number +C naxis1 i width in bytes of existing table +C naxis2 i number of rows in the table +C delbyt i how many bytes to delete in each row +C fstbyt i byte position in the row to delete the bytes (0=row start) +C status i returned error status (0=ok) + + integer iunit,naxis1,naxis2,delbyt,fstbyt,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,i1,i2,irow,newlen,nseg,nbytes,remain + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + + newlen=naxis1-delbyt + + if (newlen .le. 5760)then +C *********************************************************************** +C CASE #1: optimal case where whole new row fits in the work buffer +C *********************************************************************** + i1=fstbyt+1 + i2=i1+delbyt + do 10 irow=1,naxis2-1 +C read the row to be shifted + call ftgtbs(iunit,irow,i2,newlen,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,irow,i1,newlen,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 +10 continue + +C now do the last row + remain=naxis1-(fstbyt+delbyt) + if (remain .gt. 0)then +C read the row to be shifted + call ftgtbs(iunit,naxis2,i2,remain,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,naxis2,i1,remain,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + end if + else +C ************************************************************************ +C CASE #2: whole row doesn't fit in work buffer; move row in pieces +C ************************************************************************ + nseg=(newlen+5759)/5760 + + do 40 irow=1,naxis2-1 + i1=fstbyt+1 + i2=i1+delbyt + nbytes=newlen-(nseg-1)*5760 + + do 30 i=1,nseg +C read the row to be shifted + call ftgtbs(iunit,irow,i2,nbytes,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,irow,i1,nbytes,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + + i1=i1+nbytes + i2=i2+nbytes + nbytes=5760 +30 continue +40 continue + +C now do the last row + remain=naxis1-(fstbyt+delbyt) + if (remain .gt. 0)then + nseg=(remain+5759)/5760 + i1=fstbyt+1 + i2=i1+delbyt + nbytes=remain-(nseg-1)*5760 + + do 50 i=1,nseg +C read the row to be shifted + call ftgtbs(iunit,naxis2,i2,nbytes,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,naxis2,i1,nbytes,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + + i1=i1+nbytes + i2=i2+nbytes + nbytes=5760 +50 continue + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftcdfl.f b/pkg/tbtables/fitsio/ftcdfl.f new file mode 100644 index 00000000..2429eae5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcdfl.f @@ -0,0 +1,80 @@ +C---------------------------------------------------------------------- + subroutine ftcdfl(iunit,status) + +C Check Data Unit Fill values +C Check that the data unit is correctly filled with zeros or blanks +C from the end of the data to the end of the current FITS 2880 byte block + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1994 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nf = 3000) + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 chbuff(2880),chfill,xdummy(2879) + common/ftheap/chbuff,chfill,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,filpos,nfill,i + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check if the data unit is null + if (theap(ibuff) .eq. 0)return + +C move to the beginning of the fill bytes + filpos=dtstrt(ibuff)+theap(ibuff)+scount(ibuff) + call ftmbyt(iunit,filpos,.true.,status) + +C get all the fill bytes + nfill=(filpos+2879)/2880*2880-filpos + if (nfill .eq. 0)return + + call ftgcbf(iunit,0,nfill,chbuff,status) + if (status .gt. 0)then + call ftpmsg('Error reading data unit fill bytes (FTCDFL).') + return + end if + +C set the correct fill value to be checked + if (hdutyp(ibuff) .eq. 1)then +C this is an ASCII table; should be filled with blanks + chfill=char(32) + else + chfill=char(0) + end if + +C check for all zeros or blanks + do 10 i=1,nfill + if (chbuff(i) .ne. chfill)then + status=255 + if (hdutyp(ibuff) .eq. 1)then + call ftpmsg('Warning: remaining bytes following'// + & ' ASCII table data are not filled with blanks.') + else + call ftpmsg('Warning: remaining bytes following'// + & ' data are not filled with zeros.') + end if + return + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftchdu.f b/pkg/tbtables/fitsio/ftchdu.f new file mode 100644 index 00000000..0e125727 --- /dev/null +++ b/pkg/tbtables/fitsio/ftchdu.f @@ -0,0 +1,58 @@ +C---------------------------------------------------------------------- + subroutine ftchdu(iunit,status) + +C Close Header Data Unit +C If we have write access to the file, then close the current HDU by: +C -padding remaining space in the header with blanks +C -writing the END keyword in the CHU +C -check the data fill values, and rewrite them if not correct +C -flushing the current buffer to disk +C -recover common block space containing column descriptors + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + +C ignore input status and close HDU regardless of input status value + + ibuff=bufnum(iunit) + +C see if we have write access to this file + if (wrmode(ibuff))then +C rewrite the header END card and the following blank fill, and +C insure that the internal data structure matches the keywords + call ftrdef(iunit,status) + +C write the correct data fill values, if they are not already correct + call ftpdfl(iunit,status) + end if + +C set current column name buffer as undefined + call ftrsnm + +C flush the buffers holding data for this HDU + call ftflsh(ibuff,status) + +C recover common block space containing column descriptors for this HDU + call ftfrcl(iunit,status) + + if (status .gt. 0)then + call ftpmsg('Error while closing current HDU (FTCHDU).') + end if + end diff --git a/pkg/tbtables/fitsio/ftchfl.f b/pkg/tbtables/fitsio/ftchfl.f new file mode 100644 index 00000000..9da24278 --- /dev/null +++ b/pkg/tbtables/fitsio/ftchfl.f @@ -0,0 +1,72 @@ +C---------------------------------------------------------------------- + subroutine ftchfl(iunit,status) + +C Check Header Fill values +C Check that the header unit is correctly filled with blanks from the +C END card to the end of the current FITS 2880-byte block + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1994 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,nblank,i,endpos + character*80 rec + logical gotend + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C calculate the number of blank keyword slots in the header + endpos=hdend(ibuff) + nblank=(dtstrt(ibuff)-endpos)/80 +C move the i/o pointer to the end of the header keywords + call ftmbyt(iunit,endpos,.true.,status) +C find the END card (there may be blank keywords perceeding it) + + gotend=.false. + do 10 i=1,nblank + call ftgcbf(iunit,1,80,rec,status) + if (rec(1:8) .eq. 'END ')then + if (gotend)then +C there is a duplicate END record + status=254 + call ftpmsg('Warning: Header fill area contains '// + & 'duplicate END card:') + end if + gotend=.true. + if (rec(9:80) .ne. ' ')then +C END keyword has extra characters + status=253 + call ftpmsg('Warning: END keyword contains '// + & 'extraneous non-blank characters:') + end if + else if (gotend)then + if (rec .ne. ' ')then +C The fill area contains extraneous characters + status=254 + call ftpmsg('Warning: Header fill area contains '// + & 'extraneous non-blank characters:') + end if + end if + + if (status .gt. 0)then + call ftpmsg(rec) + return + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftcins.f b/pkg/tbtables/fitsio/ftcins.f new file mode 100644 index 00000000..08485ce3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcins.f @@ -0,0 +1,173 @@ +C-------------------------------------------------------------------------- + subroutine ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) + +C insert DELBYT bytes after byte fstbyt in every row of the table + +C iunit i Fortran I/O unit number +C naxis1 i width in bytes of existing table +C naxis2 i number of rows in the table +C delbyt i how many bytes to insert in each row +C fstbyt i byte position in the row to insert the bytes (0=row start) +C status i returned error status (0=ok) + + integer iunit,naxis1,naxis2,delbyt,fstbyt,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,i1,irow,newlen,fbyte,nseg,nbytes + character cfill*1 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C select appropriate fill value + if (hdutyp(ibuff) .eq. 1)then +C fill header or ASCII table with space + cfill=char(32) + else +C fill image or bintable data area with Null (0) + cfill=char(0) + end if + + newlen=naxis1+delbyt + + if (newlen .le. 5760)then +C *********************************************************************** +C CASE #1: optimal case where whole new row fits in the work buffer +C *********************************************************************** +C write the correct fill value into the buffer + do 10 i=1,delbyt + buff(i)=cfill +10 continue + i1=delbyt+1 + +C first move the trailing bytes (if any) in the last row + fbyte=fstbyt+1 + nbytes=naxis1-fstbyt + call ftgtbs(iunit,naxis2,fbyte,nbytes,buff(i1),status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row (with leading fill bytes) in the new place + nbytes=nbytes+delbyt + call ftptbs(iunit,naxis2,fbyte,nbytes,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + +C now move the rest of the rows + do 20 irow=naxis2-1,1,-1 +C read the row to be shifted (work backwards through the table) + call ftgtbs(iunit,irow,fbyte,naxis1,buff(i1),status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row (with the leading fill bytes) in the new place + call ftptbs(iunit,irow,fbyte,newlen,buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 +20 continue + + else +C ************************************************************************ +C CASE #2: whole row doesn't fit in work buffer; move row in pieces +C ************************************************************************ +C first copy the data, then go back and write fill into the new column +C start by copying the trailing bytes (if any) in the last row + + nbytes=naxis1-fstbyt + nseg=(nbytes+5759)/5760 + fbyte=(nseg-1)*5760+fstbyt+1 + nbytes=naxis1-fbyte+1 + + do 25 i=1,nseg + call ftgtbs(iunit,naxis2,fbyte,nbytes,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,naxis2,fbyte+delbyt,nbytes, + & buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + + fbyte=fbyte-5760 + nbytes=5760 +25 continue + +C now move the rest of the rows + nseg=(naxis1+5759)/5760 + + do 40 irow=naxis2-1,1,-1 + fbyte=(nseg-1)*5760+fstbyt+1 + nbytes=naxis1-(nseg-1)*5760 + do 30 i=1,nseg +C read the row to be shifted (work backwards thru the table) + call ftgtbs(iunit,irow,fbyte,nbytes,buff,status) + +C set row length to its new value + rowlen(ibuff)=newlen + +C write the row in the new place + call ftptbs(iunit,irow,fbyte+delbyt,nbytes, + & buff,status) + +C reset row length to its original value + rowlen(ibuff)=naxis1 + + fbyte=fbyte-5760 + nbytes=5760 +30 continue +40 continue + +C now write the fill values into the new column + nbytes=min(delbyt,5760) + do 50 i=1,nbytes + buff(i)=cfill +50 continue + + nseg=(delbyt+5759)/5760 + +C set row length to its new value + rowlen(ibuff)=newlen + + do 70 irow=1,naxis2 + fbyte=fstbyt+1 + nbytes=delbyt-((nseg-1)*5760) + do 60 i=1,nseg +C write the fill + call ftptbs(iunit,irow,fbyte,nbytes,buff,status) + fbyte=fbyte+nbytes + nbytes=5760 +60 continue +70 continue + +C reset the rowlength + rowlen(ibuff)=naxis1 + end if + end diff --git a/pkg/tbtables/fitsio/ftclos.f b/pkg/tbtables/fitsio/ftclos.f new file mode 100644 index 00000000..d5a1eb75 --- /dev/null +++ b/pkg/tbtables/fitsio/ftclos.f @@ -0,0 +1,21 @@ +C-------------------------------------------------------------------------- + subroutine ftclos(iunit,status) + +C close a FITS file that was previously opened with ftopen or ftinit +C +C iunit i Fortran I/O unit number +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,status + + logical keep + +C close the current HDU and pad the header with blanks + call ftchdu(iunit,status) + +C close the file + keep=.true. + call ftclsx(iunit,keep,status) + end diff --git a/pkg/tbtables/fitsio/ftcmps.f b/pkg/tbtables/fitsio/ftcmps.f new file mode 100644 index 00000000..3ba41e38 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcmps.f @@ -0,0 +1,104 @@ +C-------------------------------------------------------------------------- + subroutine ftcmps(templt,string,casesn,match,exact) + +C compare the template to the string and test if they match. +C The strings are limited to 68 characters or less (the max. length +C of a FITS string keyword value. This routine reports whether +C the two strings match and whether the match is exact or +C involves wildcards. + +C this algorithm is very similar to the way unix filename wildcards +C work except that this first treats a wild card as a literal character +C when looking for a match. If there is no literal match, then +C it interpretes it as a wild card. So the template 'AB*DE' +C is considered to be an exact rather than a wild card match to +C the string 'AB*DE'. + +C templt C input template (may includ % or * wild cards) +C string C input string to be compared to template +C casesn L should comparison be case sensitive? +C match L (output) does the template match the string? +C exact L (output) are the strings an exact match (true) or +C is it a wildcard match (false) + +C written by Wm Pence, HEASARC/GSFC, December 1994 + + character*(*) templt,string + logical casesn,match,exact + character*68 temp,str + integer tlen,slen,t1,s1 + + tlen=len(templt) + slen=len(string) + tlen=min(tlen,68) + slen=min(tlen,68) + + match=.false. + exact=.true. + temp=templt + str=string + if (.not. casesn)then + call ftupch(temp) + call ftupch(str) + end if + +C check for exact match + if (temp .eq. str)then + match=.true. + return + else +C the strings are not identical, any match cannot be exact + exact=.false. + end if + + t1=1 + s1=1 +10 continue + if (t1 .gt. tlen .or. s1 .gt. slen)then +C completely scanned one or both strings, so it must be a match + match=.true. + return + end if + +C see if the characters in the 2 strings are an exact match + if (temp(t1:t1) .eq. str(s1:s1))then + s1=s1+1 + t1=t1+1 + else + exact=.false. + if (temp(t1:t1) .eq. '?')then +C The '?' wild card matches anything + s1=s1+1 + t1=t1+1 + else if (temp(t1:t1) .eq. '*')then +C get next character from template and look for it in the string + t1=t1+1 + if (t1 .le. tlen)then + if (temp(t1:t1) .eq. ' ')then +C * is followed by a space, so a match is guaranteed + t1=tlen+1 + else +20 continue + if (temp(t1:t1) .eq. str(s1:s1))then +C found a matching character + t1=t1+1 + s1=s1+1 + else +C increment the string pointer and try again + s1=s1+1 + if (s1 .le. slen)then + go to 20 + else +C hit end of string and failed to find a match + return + end if + end if + end if + end if + else +C match failed + return + end if + end if + go to 10 + end diff --git a/pkg/tbtables/fitsio/ftcmsg.f b/pkg/tbtables/fitsio/ftcmsg.f new file mode 100644 index 00000000..daae979a --- /dev/null +++ b/pkg/tbtables/fitsio/ftcmsg.f @@ -0,0 +1,6 @@ +C------------------------------------------------------------------------------ + subroutine ftcmsg + +C clear the error message stack + call ftxmsg(0,'dummy') + end diff --git a/pkg/tbtables/fitsio/ftcopy.f b/pkg/tbtables/fitsio/ftcopy.f new file mode 100644 index 00000000..439a5314 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcopy.f @@ -0,0 +1,84 @@ +C---------------------------------------------------------------------- + subroutine ftcopy(iunit,ounit,moreky,status) + +C copies the CHDU from IUNIT to the CHDU of OUNIT. +C This will also reserve space in the header for MOREKY keywords +C if MOREKY > 0. + +C iunit i fortran unit number of the input file to be copied +C ounit i fortran unit number of the output file to be copied to +C moreky i create space in header for this many more keywords +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Jan, 1992 + + integer iunit,ounit,moreky,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,obuff,i,nkeys,nadd + integer bitpix,naxis,naxes(99),pcount,gcount + character hrec*80 + logical simple,extend + + if (status .gt. 0)return + + if (iunit .eq. ounit)then + status=101 + return + end if + + ibuff=bufnum(iunit) + obuff=bufnum(ounit) + +C find out the number of keywords which exist in the input CHDU + call ftghsp(iunit,nkeys,nadd,status) + +C copy the keywords one at a time to the output CHDU + if ( (chdu(ibuff) .eq. 1 .and. chdu(obuff) .ne. 1) .or. + & (chdu(ibuff) .ne. 1 .and. chdu(obuff) .eq. 1) )then +C copy primary array to image extension, or vise versa + +C copy the required keywords: + simple=.true. + extend=.true. + call ftghpr(iunit,99,simple,bitpix,naxis, + & naxes,pcount,gcount,extend,status) + if (status .gt. 0)return + call ftphpr(ounit,simple,bitpix,naxis, + & naxes,pcount,gcount,extend,status) + if (status .gt. 0)return + +C copy remaining keywords, excluding pcount, gcount and extend + do 10 i=naxis+4,nkeys + call ftgrec(iunit,i,hrec,status) + if (hrec(1:8) .ne. 'PCOUNT ' .and. + & hrec(1:8) .ne. 'GCOUNT ' .and. + & hrec(1:8) .ne. 'EXTEND ')then + call ftprec(ounit,hrec,status) + end if +10 continue + else +C just copy all the keys exactly from the input file to the output + do 20 i=1,nkeys + call ftgrec(iunit,i,hrec,status) + call ftprec(ounit,hrec,status) +20 continue + end if + +C reserve space for more keywords (if moreky > 0) + call fthdef(ounit,moreky,status) + +C now ccopy the data from the input CHDU to the output CHDU + call ftcpdt(iunit,ounit,status) + + end diff --git a/pkg/tbtables/fitsio/ftcpdt.f b/pkg/tbtables/fitsio/ftcpdt.f new file mode 100644 index 00000000..eac1c8fe --- /dev/null +++ b/pkg/tbtables/fitsio/ftcpdt.f @@ -0,0 +1,58 @@ +C---------------------------------------------------------------------- + subroutine ftcpdt(iunit,ounit,status) + +C copies the data from the IUNIT CHDU to the data of the OUNIT CHDU. +C This will overwrite any data already in the OUNIT CHDU. + +C iunit i fortran unit number of the input file to be copied +C ounit i fortran unit number of the output file to be copied to +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Aug 1993 + + integer iunit,ounit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 cbuff(2880), xdummy(2880) + common/ftheap/cbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,obuff,nblock,i + + if (status .gt. 0)return + + if (iunit .eq. ounit)then + status=101 + return + end if + + ibuff=bufnum(iunit) + obuff=bufnum(ounit) + +C determine HDU structure as defined by keywords in output file + call ftrdef(ounit,status) + +C Calculate the number of bytes to be copied. By definition there +C will be an integral number of 2880-byte logical blocks to be copied + nblock=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 + + if (nblock .gt. 0)then +C move to the beginning of the data in the input and output files + call ftmbyt(iunit,dtstrt(ibuff),.false.,status) + call ftmbyt(ounit,dtstrt(obuff),.true.,status) + +C now copy the data one block at a time + do 30 i=1,nblock + call ftgcbf(iunit,0,2880,cbuff,status) + call ftpcbf(ounit,0,2880,cbuff,status) +30 continue + end if + end diff --git a/pkg/tbtables/fitsio/ftcrep.f b/pkg/tbtables/fitsio/ftcrep.f new file mode 100644 index 00000000..088f2c07 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcrep.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftcrep(comm,comm1,repeat) + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + +C comm c input comment string +C OUTPUT PARAMETERS: +C comm1 c output comment string, = COMM minus the last '&' character +C repeat l true if the last character of COMM was the '&" character +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) comm,comm1 + logical repeat + integer i,j + + repeat=.false. + j=len(comm) + do 10 i=j,1,-1 + if (comm(i:i) .ne. ' ')then + if (comm(i:i) .eq. '&')then + comm1=comm(1:i-1) + repeat=.true. + end if + return + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftcrhd.f b/pkg/tbtables/fitsio/ftcrhd.f new file mode 100644 index 00000000..7b64b1bf --- /dev/null +++ b/pkg/tbtables/fitsio/ftcrhd.f @@ -0,0 +1,53 @@ +C---------------------------------------------------------------------- + subroutine ftcrhd(iunit,status) + +C 'CReate Header Data unit' +C create, initialize, and move the i/o pointer to a new extension at +C the end of the FITS file. + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + +C close the current HDU + call ftchdu(iunit,status) + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check that we haven't exceeded the maximum allowed number of extensions + if (maxhdu(ibuff)+1 .ge. ne)then + status=301 + return + end if + +C move to the end of the highest known extension + call ftmbyt(iunit,hdstrt(ibuff,maxhdu(ibuff)+1),.true.,status) + +C initialize various parameters about the CHDU + maxhdu(ibuff)=maxhdu(ibuff)+1 + chdu(ibuff)=maxhdu(ibuff) + nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff)) +C the logical location of the END record at the start of the header + hdend(ibuff)=nxthdr(ibuff) +C the data start location is undefined + dtstrt(ibuff)=-2000000000 + end diff --git a/pkg/tbtables/fitsio/ftcsum.f b/pkg/tbtables/fitsio/ftcsum.f new file mode 100644 index 00000000..0e056af9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftcsum.f @@ -0,0 +1,52 @@ +C-------------------------------------------------------------------------- + subroutine ftcsum(iunit,nrec,sum,status) + +C Calculate a 32-bit 1's complement checksum of the FITS 2880-byte blocks. +C This Fortran algorithm is based on the C algorithm developed by Rob +C Seaman at NOAO that was presented at the 1994 ADASS conference, to be +C published in the Astronomical Society of the Pacific Conference Series. + +C This uses a 32-bit 1's complement checksum in which the overflow bits +C are permuted back into the sum and therefore all bit positions are +C sampled evenly. In this Fortran version of the original C algorithm, +C a double precision value (which has at least 48 bits of precision) +C is used to accumulate the checksum because standard Fortran does not +C support an unsigned integer datatype. + +C iunit i fortran unit number +C nrec i number of FITS 2880-byte blocks to be summed +C sum d check sum value (initialize to zero before first call) +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Sept, 1994 + + integer iunit,nrec,status,i,j,hibits,i4vals(720) + double precision sum,word32 + parameter (word32=4.294967296D+09) +C word32 is equal to 2**32 + + if (status .gt. 0)return + +C Sum the specified number of FITS 2880-byte records. This assumes that +C the FITSIO file pointer points to the start of the records to be summed. + do 30 j=1,nrec + +C read the record as 720 pixel I*4 vector (do byte swapping if needed) + call ftgi4b(iunit,720,0,i4vals,status) + do 10 i=1,720 + if (i4vals(i) .ge. 0)then + sum=sum+i4vals(i) + else +C sign bit is set, so add the equalvalent unsigned value + sum=sum+(word32+i4vals(i)) + end if +10 continue + +C fold any overflow bits beyond 32 back into the word +20 hibits=sum/word32 + if (hibits .gt. 0)then + sum=sum-(hibits*word32)+hibits + go to 20 + end if +30 continue + end diff --git a/pkg/tbtables/fitsio/ftd2e.f b/pkg/tbtables/fitsio/ftd2e.f new file mode 100644 index 00000000..71cbb7bc --- /dev/null +++ b/pkg/tbtables/fitsio/ftd2e.f @@ -0,0 +1,43 @@ +C---------------------------------------------------------------------- + subroutine ftd2e(val,dec,cval,vlen,status) + +C convert a double precision value to an E format character string +C If it will fit, the value field will be 20 characters wide; +C otherwise it will be expanded to up to 35 characters, left +C justified. +C +C val d input value to be converted +C dec i number of decimal places to display in output string +C cval c output character string +C vlen i length of output string +C status i output error status (0 = OK) + + double precision val + integer dec,vlen,status + character*35 cval,form*10 + + if (status .gt. 0)return + + if (dec .ge. 1 .and. dec .le. 9)then + vlen=20 + write(form,2000)dec +2000 format('(1pe20.',i1,')') + else if (dec .ge. 10 .and. dec .le. 28)then + vlen=max(20,dec+7) + write(form,2001)vlen,dec +2001 format('(1pe',i2,'.',i2,')') + else +C illegal number of decimal places were specified + status=411 + call ftpmsg('Error in FTR2E: number of decimal places ' + & //'is less than 1 or greater than 28.') + return + endif + + write(cval,form,err=900)val + if (cval(1:1) .eq. '*')go to 900 + return + +900 status=402 + call ftpmsg('Error in FTD2E converting double to En.m string.') + end diff --git a/pkg/tbtables/fitsio/ftd2f.f b/pkg/tbtables/fitsio/ftd2f.f new file mode 100644 index 00000000..2a8de134 --- /dev/null +++ b/pkg/tbtables/fitsio/ftd2f.f @@ -0,0 +1,36 @@ +C---------------------------------------------------------------------- + subroutine ftd2f(val,dec,cval,status) + +C convert double precision value to F20.* format character string +C NOTE: some precision may be lost +C val d input value to be converted +C dec i number of decimal places to display in output string +C cval c output character string +C status i output error status (0 = OK) + + double precision val + integer dec,status + character*20 cval,form*8 + + if (status .gt. 0)return + + if (dec .ge. 0 .and. dec .le. 9)then + write(form,2000)dec +2000 format('(f20.',i1,')') + else if (dec .ge. 10 .and. dec .lt.18)then + write(form,2001)dec +2001 format('(f20.',i2,')') + else +C illegal number of decimal places were specified + status=411 + call ftpmsg('Error in FTD2F: number of decimal places ' + & //'is less than 0 or greater than 18.') + return + endif + + write(cval,form,err=900)val + if (cval(1:1) .eq. '*')go to 900 + return +900 status=402 + call ftpmsg('Error in FTD2F converting double to F20. string.') + end diff --git a/pkg/tbtables/fitsio/ftdblk.f b/pkg/tbtables/fitsio/ftdblk.f new file mode 100644 index 00000000..2fd56c04 --- /dev/null +++ b/pkg/tbtables/fitsio/ftdblk.f @@ -0,0 +1,98 @@ +C-------------------------------------------------------------------------- + subroutine ftdblk(ounit,nblock,hdrdat,status) + +C delete 2880-byte FITS blocks at the end of the current header or data + +C ounit i fortran output unit number +C nblock i number of 2880-byte blocks to be deleted +C hdrdat i delete space at end of header (0) or data (1) +C status i returned error status (0=ok) + + integer ounit,nblock,hdrdat,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,jpoint,i,tstat + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + +C get address of first block to be deleted/overwritten + if (hdrdat .eq. 0)then + jpoint=dtstrt(ibuff)-2880*nblock + else + jpoint=hdstrt(ibuff,chdu(ibuff)+1)-2880*nblock + end if + +C move each block up, until we reach the end of file +10 continue +C move to the read start position + tstat=status + call ftmbyt(ounit,jpoint+nblock*2880,.false.,status) + +C read one 2880-byte FITS logical record + call ftgcbf(ounit,0,2880,buff,status) + +C check for end of file + if (status .eq. 107)then + status=tstat + go to 20 + end if + +C move back to the write start postion + call ftmbyt(ounit,jpoint,.false.,status) + +C write the 2880-byte FITS logical record + call ftpcbf(ounit,0,2880,buff,status) + +C check for error + if (status .gt. 0)then + call ftpmsg('Error deleting FITS blocks (FTDBLK)') + return + end if + +C increment pointer to next block and loop back + jpoint=jpoint+2880 + go to 10 +20 continue + +C now fill the last nblock blocks with zeros; initialize the buffer + do 30 i=1,2880 + buff(i)=char(0) +30 continue + +C move back to the write start postion + call ftmbyt(ounit,jpoint,.false.,status) + +C write the 2880-byte block NBLOCK times. + do 40 i=1,nblock + call ftpcbf(ounit,0,2880,buff,status) +40 continue + + if (hdrdat .eq. 0)then +C recalculate the starting location of the current data unit, if moved + dtstrt(ibuff)=dtstrt(ibuff)-2880*nblock + end if + +C recalculate the starting location of all subsequent HDUs + do 50 i=chdu(ibuff)+1,maxhdu(ibuff)+1 + hdstrt(ibuff,i)=hdstrt(ibuff,i)-2880*nblock +50 continue + + if (status .gt. 0)then + call ftpmsg('Error deleting FITS block(s) (FTDBLK)') + end if + end diff --git a/pkg/tbtables/fitsio/ftdcol.f b/pkg/tbtables/fitsio/ftdcol.f new file mode 100644 index 00000000..8e9b11d7 --- /dev/null +++ b/pkg/tbtables/fitsio/ftdcol.f @@ -0,0 +1,132 @@ +C-------------------------------------------------------------------------- + subroutine ftdcol(iunit,colnum,status) + +C delete a column from a table + +C iunit i Fortran I/O unit number +C colnum i number of of the column to be deleted +C status i returned error status (0=ok) + + integer iunit,colnum,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,typhdu,delbyt,fstbyt,sp,tflds,i + integer naxis1,naxis2,size,freesp,nblock,tbc + character comm*70,keynam*8 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C test that the CHDU is an ASCII table or BINTABLE + typhdu=hdutyp(ibuff) + if (typhdu .ne. 1 .and. typhdu .ne. 2)then + status=235 + call ftpmsg('Can only delete column from TABLE '// + & 'or BINTABLE extension (FTDCOL)') + return + end if + +C check if column number exists in the table + tflds=tfield(ibuff) + if (colnum .lt. 1 .or. colnum .gt. tflds)then + status=302 + return + end if + +C get the starting byte position of the column (=zero for first column) + fstbyt=tbcol(colnum+tstart(ibuff)) + +C find the width of the column + if (typhdu .eq. 1)then +C tnull is used to store the width of the ASCII column field +C NOTE: ASCII columns may not be in physical order, or may overlap. + + delbyt=tnull(colnum+tstart(ibuff)) + +C delete the space(s) between the columns, if there are any. + if (colnum .lt. tflds)then +C check for spaces between following column + sp=tbcol(colnum+1+tstart(ibuff))-tbcol(colnum+ + & tstart(ibuff))-delbyt + if (sp .gt. 0)then + delbyt=delbyt+1 + end if + else if (colnum .gt. 1)then +C check for space between the last and next to last columns + sp=tbcol(colnum+tstart(ibuff))-tbcol(colnum-1+ + & tstart(ibuff))-tnull(colnum-1+tstart(ibuff)) + if (sp .gt. 0)then + delbyt=delbyt+1 + fstbyt=fstbyt-1 + end if + end if + else + if (colnum .lt. tflds)then + delbyt=tbcol(colnum+1+tstart(ibuff))- + & tbcol(colnum+tstart(ibuff)) + else + delbyt=rowlen(ibuff)-tbcol(colnum+tstart(ibuff)) + end if + end if + +C get current size of the table + naxis1=rowlen(ibuff) + call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) + +C Calculate how many FITS blocks (2880 bytes) need to be deleted + size=theap(ibuff)+scount(ibuff) + freesp=(delbyt*naxis2) + ((size+2879)/2880)*2880 - size + nblock=freesp/2880 + +C shift each row up, deleting the desired column + call ftcdel(iunit,naxis1,naxis2,delbyt,fstbyt,status) + +C shift the heap up and update pointer to start of heap + size=delbyt*naxis2 + call fthpup(iunit,size,status) + +C delete the needed number of new FITS blocks at the end of the HDU + if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status) + + if (typhdu .eq. 1)then +C adjust the TBCOL values of the remaining columns + do 10 i=1,tflds + call ftkeyn('TBCOL',i,keynam,status) + call ftgkyj(iunit,keynam,tbc,comm,status) + if (tbc .gt. fstbyt)then + tbc=tbc-delbyt + call ftmkyj(iunit,keynam,tbc,'&',status) + end if +10 continue + end if + +C update the mandatory keywords + call ftmkyj(iunit,'TFIELDS',tflds-1,'&',status) + call ftmkyj(iunit,'NAXIS1',naxis1-delbyt,'&',status) + +C delete the index keywords starting with 'T' associated with the +C deleted column and subtract 1 from index of all higher keywords + call ftkshf(iunit,colnum,tflds,-1,status) + +C parse the header to initialize the new table structure + call ftrdef(iunit,status) + end diff --git a/pkg/tbtables/fitsio/ftddef.f b/pkg/tbtables/fitsio/ftddef.f new file mode 100644 index 00000000..ad82819d --- /dev/null +++ b/pkg/tbtables/fitsio/ftddef.f @@ -0,0 +1,54 @@ +C-------------------------------------------------------------------------- + subroutine ftddef(ounit,bytlen,status) + +C Data DEFinition +C re-define the length of the data unit +C this simply redefines the start of the next HDU +C +C ounit i Fortran I/O unit number +C bytlen i new length of the data unit, in bytes +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,bytlen,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nf = 3000) + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + + if (dtstrt(ibuff) .lt. 0)then +C freeze the header at its current size + call fthdef(ounit,0,status) + end if + + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+(bytlen+2879)/2880*2880 + +C initialize the fictitious heap starting address (immediately following +C the array data) and a zero length heap. This is used to find the +C end of the data when checking the fill values in the last block. + scount(ibuff)=0 + theap(ibuff)=bytlen + nxheap(ibuff)=0 + end diff --git a/pkg/tbtables/fitsio/ftdelt.f b/pkg/tbtables/fitsio/ftdelt.f new file mode 100644 index 00000000..16e5e46e --- /dev/null +++ b/pkg/tbtables/fitsio/ftdelt.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftdelt(iunit,status) + +C delete a FITS file that was previously opened with ftopen or ftinit +C +C iunit i Fortran I/O unit number +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, July 1994 + + integer iunit,status,ibuff + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + +C ignore input status, and delete file regardless of status value + + ibuff=bufnum(iunit) + +C set current column name buffer as undefined + call ftrsnm + +C flush the buffers holding data for this HDU + call ftflsh(ibuff,status) + +C recover common block space containing column descriptors for this HDU + call ftfrcl(iunit,status) + +C delete the file + call ftclsx(iunit,.false.,status) + end diff --git a/pkg/tbtables/fitsio/ftdhdu.f b/pkg/tbtables/fitsio/ftdhdu.f new file mode 100644 index 00000000..6f39a37c --- /dev/null +++ b/pkg/tbtables/fitsio/ftdhdu.f @@ -0,0 +1,58 @@ +C-------------------------------------------------------------------------- + subroutine ftdhdu(ounit,typhdu,status) + +C delete the current HDU (as long as it is not the primary array) + +C ounit i fortran output unit number +C typhdu i type of the new CHDU, after deleting the old CHDU +C status i returned error status (0=ok) + + integer ounit,typhdu,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,nhdu,nblock + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + nhdu=chdu(ibuff) + if (nhdu .eq. 1)then +C cannot delete the primary array + status=301 + return + end if + +C close the CHDU first, to flush buffers and free memory + call ftchdu(ounit,status) + +C how many blocks to delete? + nblock=(hdstrt(ibuff,nhdu+1)-hdstrt(ibuff,nhdu))/2880 + if (nblock .lt. 1)return + +C delete the blocks + call ftdblk(ounit,nblock,1,status) + if (status .gt. 0)return + +C try reinitializing the CHDU, if there is one + call ftrhdu(ounit,typhdu,status) + if (status .gt. 0)then +C there is no HDU after the one we just deleted so move back one HDU + status=0 + call ftcmsg + call ftgext(ounit,nhdu-1,typhdu,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftdkey.f b/pkg/tbtables/fitsio/ftdkey.f new file mode 100644 index 00000000..0701e190 --- /dev/null +++ b/pkg/tbtables/fitsio/ftdkey.f @@ -0,0 +1,55 @@ +C-------------------------------------------------------------------------- + subroutine ftdkey(iunit,keynam,status) + +C delete a header keyword +C +C iunit i fortran output unit number +C keynam c keyword name ( 8 characters, cols. 1- 8) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + character*(*) keynam + integer iunit,status,i,lenval,nkeys,keypos + character keybuf*80,strval*70,comm*8,value*70,bslash*1,kname*8 + + if (status .gt. 0)return + +C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape + bslash='\\' + +C find the keyword to be deleted + call ftgcrd(iunit,keynam,keybuf,status) + if (status .eq. 202)then + kname=keynam + call ftpmsg('FTDKEY could not find the '//kname// + & ' keyword to be deleted.') + return + end if + +C get the position of the keyword in the header + call ftghps(iunit,nkeys,keypos,status) + keypos=keypos-1 + +C get position of last character in value string to see if it is a \ or & + call ftpsvc(keybuf,strval,comm,status) + call ftc2s(strval,value,status) + do 10 i=70,1,-1 + if (value(i:i) .ne. ' ')then + lenval=i + go to 20 + end if +10 continue + +C now delete this keyword +20 call ftdrec(iunit,keypos,status) + if (status .gt. 0)return + +C test if this keyword was also continued + if (value(lenval:lenval) .eq. bslash .or. + & value(lenval:lenval) .eq. '&')then + call ftgnst(iunit,value,lenval,comm,status) + if (lenval .gt. 0)go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftdrec.f b/pkg/tbtables/fitsio/ftdrec.f new file mode 100644 index 00000000..5265aafc --- /dev/null +++ b/pkg/tbtables/fitsio/ftdrec.f @@ -0,0 +1,64 @@ +C-------------------------------------------------------------------------- + subroutine ftdrec(ounit,pos,status) + +C delete keyword record at position POS from header +C +C ounit i fortran output unit number +C pos i position of keyword to be deleted (1 = first keyword) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Jan 1995 + + integer ounit,pos,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + character*80 keybuf,keytmp + integer ibuff,i,j,nshift + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + if (pos .lt. 1 .or. pos .gt. + & (hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80)then + status=203 + return + end if + + nxthdr(ibuff)=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80 + +C calculate number of header records following the deleted record + nshift=(hdend(ibuff)-nxthdr(ibuff))/80 + +C go through header shifting each 80 byte record up one place to +C fill in the gap created by the deleted keyword + j=hdend(ibuff) + keybuf=' ' + do 10 i=1,nshift + j=j-80 +C read current record contents + call ftmbyt(ounit,j,.false.,status) + call ftgcbf(ounit,0,80,keytmp,status) +C overwrite with new contents + call ftmbyt(ounit,j,.false.,status) + call ftpcbf(ounit,0,80,keybuf,status) + keybuf=keytmp +10 continue + +C update end-of-header pointer + hdend(ibuff)=hdend(ibuff)-80 + +100 continue + end diff --git a/pkg/tbtables/fitsio/ftdrow.f b/pkg/tbtables/fitsio/ftdrow.f new file mode 100644 index 00000000..22c0bfdd --- /dev/null +++ b/pkg/tbtables/fitsio/ftdrow.f @@ -0,0 +1,94 @@ +C-------------------------------------------------------------------------- + subroutine ftdrow(iunit,frow,nrows,status) + +C delete NROWS rows from a table, beginning with row FROW + +C iunit i Fortran I/O unit number +C frow i row number after which the new rows will be inserted. +C Specify 0 to add rows to the beginning of the table. +C nrows i number of rows to add to the table (must be greater than 0) +C status i returned error status (0=ok) + + integer iunit,frow,nrows,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,naxis1,naxis2,size,freesp,nblock,row + character comm*8 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C test that the CHDU is an ASCII table or BINTABLE + if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then + status=235 + call ftpmsg('Can only delete rows from TABLE or '// + & 'BINTABLE extension (FTDROW)') + return + end if + +C get current size of the table + call ftgkyj(iunit,'NAXIS1',naxis1,comm,status) + call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) + + if (nrows .lt. 0)then + status=306 + call ftpmsg('Cannot delete negative number of ' // + & 'rows in the table (FTDROW)') + return + else if (frow+nrows-1 .gt. naxis2)then + status=307 + call ftpmsg('Specified number of rows to delete ' + & //'exceeds number of rows in table (FTDROW)') + return + else if (nrows .eq. 0)then + return + else if (frow .gt. naxis2)then + status=307 + call ftpmsg('First row to delete is greater'// + & ' than the number of rows in the table (FTDROW)') + return + else if (frow .le. 0)then + status=307 + call ftpmsg('Delete starting row number is less ' + & //'than 1 (FTDROW)') + return + end if + +C Calculate how many FITS blocks (2880 bytes) need to be deleted + size=theap(ibuff)+scount(ibuff) + freesp=((size+2879)/2880)*2880 - size + naxis1*nrows + nblock=freesp/2880 + +C shift the rows up + row=frow+nrows + call ftrwup(iunit,row,naxis2,nrows,status) + +C shift the heap up + size=naxis1*nrows + call fthpup(iunit,size,status) + + if (nblock .gt. 0)call ftdblk(iunit,nblock,1,status) + +C update the NAXIS2 keyword + naxis2=naxis2-nrows + call ftmkyj(iunit,'NAXIS2',naxis2,'&',status) + end diff --git a/pkg/tbtables/fitsio/ftdsum.f b/pkg/tbtables/fitsio/ftdsum.f new file mode 100644 index 00000000..77a3cdf4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftdsum.f @@ -0,0 +1,68 @@ +C-------------------------------------------------------------------------- + subroutine ftdsum(string,complm,sum) + +C decode the 32 bit checksum + +C If complm=.true., then the complement of the sum will be decoded. + +C This Fortran algorithm is based on the C algorithm developed by Rob +C Seaman at NOAO that was presented at the 1994 ADASS conference, to be +C published in the Astronomical Society of the Pacific Conference Series. +C +C sum d checksum value +C complm l encode the complement of the sum? +C string c output ASCII encoded check sum +C sum d checksum value +C +C written by Wm Pence, HEASARC/GSFC, May, 1995 + + double precision sum,all32,word32,factor(4) + character*16 string,tmpstr + integer offset,i,j,k,temp,hibits + logical complm + +C all32 equals a 32 bit unsigned integer with all bits set +C word32 is equal to 2**32 + parameter (all32=4.294967295D+09) + parameter (word32=4.294967296D+09) + +C ASCII 0 is the offset value + parameter (offset=48) + + data factor/16777216.,65536.,256.,1./ + + sum=0 + +C shift the characters 1 place to the left, since the FITS character +C string value starts in column 12, which is not word aligned + tmpstr(1:15)=string(2:16) + tmpstr(16:16)=string(1:1) + +C convert characters from machine's native character coding sequence +C to ASCII codes. This only affects IBM mainframe computers +C that do not use ASCII for the internal character representation. + call ftc2as(tmpstr,16) + +C substract the offset from each byte and interpret each 4 character +C string as a 4-byte unsigned integer; sum the 4 integers + k=0 + do 10 i=1,4 + do 20 j=1,4 + k=k+1 + temp=ichar(tmpstr(k:k))-offset + sum=sum+temp*factor(j) +20 continue +10 continue + +C fold any overflow bits beyond 32 back into the word +30 hibits=sum/word32 + if (hibits .gt. 0)then + sum=sum-(hibits*word32)+hibits + go to 30 + end if + + if (complm)then +C complement the 32-bit unsigned integer equivalent (flip every bit) + sum=all32-sum + end if + end diff --git a/pkg/tbtables/fitsio/ftdtyp.f b/pkg/tbtables/fitsio/ftdtyp.f new file mode 100644 index 00000000..c42410b3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftdtyp.f @@ -0,0 +1,35 @@ +C---------------------------------------------------------------------- + subroutine ftdtyp(value,dtype,status) + +C determine datatype of a FITS value field +C This assumes value field conforms to FITS standards and may not +C detect all invalid formats. +C value c input value field from FITS header record only, +C (usually the value field is in columns 11-30 of record) +C The value string is left justified. +C dtype c output type (C,L,I,F) for Character string, Logical, +C Integer, Floating point, respectively +C +C written by Wm Pence, HEASARC/GSFC, February 1991 + + character*(*)value,dtype + integer status + + if (status .gt. 0)return + + dtype=' ' + + if (value(1:1) .eq. '''')then +C character string + dtype='C' + else if (value(1:1).eq.'T' .or. value(1:1).eq.'F')then +C logical + dtype='L' + else if (index(value,'.') .gt. 0)then +C floating point + dtype='F' + else +C assume it must be an integer, since it isn't anything else + dtype='I' + end if + end diff --git a/pkg/tbtables/fitsio/ftesum.f b/pkg/tbtables/fitsio/ftesum.f new file mode 100644 index 00000000..fe087605 --- /dev/null +++ b/pkg/tbtables/fitsio/ftesum.f @@ -0,0 +1,94 @@ +C-------------------------------------------------------------------------- + subroutine ftesum(sum,complm,string) + +C encode the 32 bit checksum by converting every +C 2 bits of each byte into an ASCII character (32 bit word encoded +C as 16 character string). Only ASCII letters and digits are used +C to encode the values (no ASCII punctuation characters). + +C If complm=.true., then the complement of the sum will be encoded. + +C This Fortran algorithm is based on the C algorithm developed by Rob +C Seaman at NOAO that was presented at the 1994 ADASS conference, to be +C published in the Astronomical Society of the Pacific Conference Series. +C +C sum d checksum value +C complm l encode the complement of the sum? +C string c output ASCII encoded check sum +C +C written by Wm Pence, HEASARC/GSFC, Sept, 1994 + + double precision sum,tmpsum,all32 + character*16 string,tmpstr + integer offset,exclud(13),nbyte(4),ch(4),i,j,k + integer quot,remain,check,nc + logical complm + +C all32 equals a 32 bit unsigned integer with all bits set + parameter (all32=4.294967295D+09) + +C ASCII 0 is the offset value + parameter (offset=48) + +C this is the list of ASCII punctutation characters to be excluded + data exclud/58,59,60,61,62,63,64,91,92,93,94,95,96/ + + if (complm)then +C complement the 32-bit unsigned integer equivalent (flip every bit) + tmpsum=all32-sum + else + tmpsum=sum + end if + +C separate each 8-bit byte into separate integers + nbyte(1)=tmpsum/16777216. + tmpsum=tmpsum-nbyte(1)*16777216. + nbyte(2)=tmpsum/65536. + tmpsum=tmpsum-nbyte(2)*65536. + nbyte(3)=tmpsum/256. + nbyte(4)=tmpsum-nbyte(3)*256. + +C encode each 8-bit integer as 4-characters + do 100 i=1,4 + quot=nbyte(i)/4+offset + remain=nbyte(i) - (nbyte(i)/4*4) + ch(1)=quot+remain + ch(2)=quot + ch(3)=quot + ch(4)=quot + +C avoid ASCII punctuation characters by incrementing and +C decrementing adjacent characters thus preserving checksum value +10 check=0 + do 30 k=1,13 + do 20 j=1,4,2 + if (ch(j) .eq. exclud(k) .or. + & ch(j+1) .eq. exclud(k))then + ch(j)=ch(j)+1 + ch(j+1)=ch(j+1)-1 + check=1 + end if +20 continue +30 continue + +C keep repeating, until all punctuation character are removed + if (check .ne. 0)go to 10 + +C convert the byte values to the equivalent ASCII characters + do 40 j=0,3 + nc=4*j+i + tmpstr(nc:nc)=char(ch(j+1)) +40 continue +100 continue + +C shift the characters 1 place to the right, since the FITS character +C string value starts in column 12, which is not word aligned + string(2:16)=tmpstr(1:15) + string(1:1)=tmpstr(16:16) + +C convert characters from ASCII codes to machine's native character +C coding sequence. (The string gets converted back to ASCII when it +C is written to the FITS file). This only affects IBM mainframe computers +C that do not use ASCII for the internal character representation. + call ftas2c(string,16) + end diff --git a/pkg/tbtables/fitsio/ftfiou.f b/pkg/tbtables/fitsio/ftfiou.f new file mode 100644 index 00000000..ba90c788 --- /dev/null +++ b/pkg/tbtables/fitsio/ftfiou.f @@ -0,0 +1,11 @@ +C------------------------------------------------------------------------------ + subroutine ftfiou(iounit,status) + +C free specified logical unit number; if iounit=-1, then free all units + + integer iounit,status + + if (status .gt. 0)return + + call ftxiou(iounit,status) + end diff --git a/pkg/tbtables/fitsio/ftfrcl.f b/pkg/tbtables/fitsio/ftfrcl.f new file mode 100644 index 00000000..cfbbc017 --- /dev/null +++ b/pkg/tbtables/fitsio/ftfrcl.f @@ -0,0 +1,91 @@ +C---------------------------------------------------------------------- + subroutine ftfrcl(iunit,status) + +C free up space in the common blocks that contain descriptors to +C the columns in the HDU that is being closed. The various parameters +C describing each table column (e.g., starting byte address, datatype, +C tscale, tzero, etc.) are stored in 1-D arrays, and the tstart +C parameter gives the starting element number in the arrays +C for each unit number. If a table is closed, then all the +C descriptors for that table columns must be overwritten by +C shifting any descriptors that follow it in the 1-D arrays to the left. + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC,May, 1995 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,n2shft,i,j1,j2 + +C ignore input status and flush columns regardless of input status value + + ibuff=bufnum(iunit) + + if (status .eq. -999)then +C just initialize the descriptors as undefined + tstart(ibuff)=-1 + else if (tstart(ibuff) .lt. 0)then +C descriptors are already undefined; just return + else if (tfield(ibuff) .eq. 0)then +C table had no columns so just reset pointers as undefined + tstart(ibuff)=-1 + dtstrt(ibuff)=-2000000000 + else +C calc number of descriptors to be shifted over the recovered space + n2shft=nxtfld-(tstart(ibuff)+tfield(ibuff)) + + if (n2shft .gt. 0)then + j1=tstart(ibuff) + j2=j1+tfield(ibuff) + do 10 i=1,n2shft +C shift the descriptors + j1=j1+1 + j2=j2+1 + tbcol(j1)=tbcol(j2) + tdtype(j1)=tdtype(j2) + trept(j1)=trept(j2) + tscale(j1)=tscale(j2) + tzero(j1)=tzero(j2) + tnull(j1)=tnull(j2) + cnull(j1)=cnull(j2) + cform(j1)=cform(j2) +10 continue + end if + +C update pointer to next vacant column discriptor location + nxtfld=nxtfld-tfield(ibuff) + +C update starting pointer for other opened files + do 20 i=1,nb + if (tstart(i) .gt. tstart(ibuff))then + tstart(i)=tstart(i)-tfield(ibuff) + end if +20 continue + +C set pointers for this unit as undefined + tstart(ibuff)=-1 + dtstrt(ibuff)=-2000000000 + end if + end diff --git a/pkg/tbtables/fitsio/ftg2db.f b/pkg/tbtables/fitsio/ftg2db.f new file mode 100644 index 00000000..1210e98e --- /dev/null +++ b/pkg/tbtables/fitsio/ftg2db.f @@ -0,0 +1,36 @@ +C-------------------------------------------------------------------------- + subroutine ftg2db(ounit,group,nulval,dim1,nx,ny, + & array,anyflg,status) + +C Read a 2-d image of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval c*1 undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array c*1 the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + character*1 array(dim1,*),nulval + logical anyflg,ltemp + integer fpixel,row + + anyflg=.false. + fpixel=1 + do 10 row = 1,ny + call ftgpvb(ounit,group,fpixel,nx,nulval, + & array(1,row),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftg2dd.f b/pkg/tbtables/fitsio/ftg2dd.f new file mode 100644 index 00000000..c6eae3fe --- /dev/null +++ b/pkg/tbtables/fitsio/ftg2dd.f @@ -0,0 +1,36 @@ +C-------------------------------------------------------------------------- + subroutine ftg2dd(ounit,group,nulval,dim1,nx,ny, + & array,anyflg,status) + +C Read a 2-d image of r*8 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval d undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array d the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + double precision array(dim1,*),nulval + logical anyflg,ltemp + integer fpixel,row + + anyflg=.false. + fpixel=1 + do 10 row = 1,ny + call ftgpvd(ounit,group,fpixel,nx,nulval, + & array(1,row),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftg2de.f b/pkg/tbtables/fitsio/ftg2de.f new file mode 100644 index 00000000..cd4684b6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftg2de.f @@ -0,0 +1,36 @@ +C-------------------------------------------------------------------------- + subroutine ftg2de(ounit,group,nulval,dim1,nx,ny, + & array,anyflg,status) + +C Read a 2-d image of real values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval r undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array r the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + real array(dim1,*),nulval + logical anyflg,ltemp + integer fpixel,row + + anyflg=.false. + fpixel=1 + do 10 row = 1,ny + call ftgpve(ounit,group,fpixel,nx,nulval, + & array(1,row),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftg2di.f b/pkg/tbtables/fitsio/ftg2di.f new file mode 100644 index 00000000..d847057d --- /dev/null +++ b/pkg/tbtables/fitsio/ftg2di.f @@ -0,0 +1,36 @@ +C-------------------------------------------------------------------------- + subroutine ftg2di(ounit,group,nulval,dim1,nx,ny, + & array,anyflg,status) + +C Read a 2-d image of i*2 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval i*2 undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array i*2 the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + integer*2 array(dim1,*),nulval + logical anyflg,ltemp + integer fpixel,row + + anyflg=.false. + fpixel=1 + do 10 row = 1,ny + call ftgpvi(ounit,group,fpixel,nx,nulval, + & array(1,row),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftg2dj.f b/pkg/tbtables/fitsio/ftg2dj.f new file mode 100644 index 00000000..21c839c0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftg2dj.f @@ -0,0 +1,36 @@ +C-------------------------------------------------------------------------- + subroutine ftg2dj(ounit,group,nulval,dim1,nx,ny, + & array,anyflg,status) + +C Read a 2-d image of i*4 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval i undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array i the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + integer array(dim1,*),nulval + logical anyflg,ltemp + integer fpixel,row + + anyflg=.false. + fpixel=1 + do 10 row = 1,ny + call ftgpvj(ounit,group,fpixel,nx,nulval, + & array(1,row),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftg3db.f b/pkg/tbtables/fitsio/ftg3db.f new file mode 100644 index 00000000..be3b48a6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftg3db.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftg3db(ounit,group,nulval,dim1,dim2,nx,ny,nz, + & array,anyflg,status) + +C Read a 3-d cube of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval c*1 undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array c*1 the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + character*1 array(dim1,dim2,*),nulval + logical anyflg,ltemp + integer fpixel,row,band + + anyflg=.false. + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftgpvb(ounit,group,fpixel,nx,nulval, + & array(1,row,band),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue +20 continue + end diff --git a/pkg/tbtables/fitsio/ftg3dd.f b/pkg/tbtables/fitsio/ftg3dd.f new file mode 100644 index 00000000..695f1cbf --- /dev/null +++ b/pkg/tbtables/fitsio/ftg3dd.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftg3dd(ounit,group,nulval,dim1,dim2,nx,ny,nz, + & array,anyflg,status) + +C Read a 3-d cube of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval d undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array d the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + double precision array(dim1,dim2,*),nulval + logical anyflg,ltemp + integer fpixel,row,band + + anyflg=.false. + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftgpvd(ounit,group,fpixel,nx,nulval, + & array(1,row,band),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue +20 continue + end diff --git a/pkg/tbtables/fitsio/ftg3de.f b/pkg/tbtables/fitsio/ftg3de.f new file mode 100644 index 00000000..1889640b --- /dev/null +++ b/pkg/tbtables/fitsio/ftg3de.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftg3de(ounit,group,nulval,dim1,dim2,nx,ny,nz, + & array,anyflg,status) + +C Read a 3-d cube of real values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval r undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array r the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + real array(dim1,dim2,*),nulval + logical anyflg,ltemp + integer fpixel,row,band + + anyflg=.false. + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftgpve(ounit,group,fpixel,nx,nulval, + & array(1,row,band),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue +20 continue + end diff --git a/pkg/tbtables/fitsio/ftg3di.f b/pkg/tbtables/fitsio/ftg3di.f new file mode 100644 index 00000000..eb0f76d1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftg3di.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftg3di(ounit,group,nulval,dim1,dim2,nx,ny,nz, + & array,anyflg,status) + +C Read a 3-d cube of i*2 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval i*2 undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array i*2 the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + integer*2 array(dim1,dim2,*),nulval + logical anyflg,ltemp + integer fpixel,row,band + + anyflg=.false. + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftgpvi(ounit,group,fpixel,nx,nulval, + & array(1,row,band),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue +20 continue + end diff --git a/pkg/tbtables/fitsio/ftg3dj.f b/pkg/tbtables/fitsio/ftg3dj.f new file mode 100644 index 00000000..1a26d929 --- /dev/null +++ b/pkg/tbtables/fitsio/ftg3dj.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftg3dj(ounit,group,nulval,dim1,dim2,nx,ny,nz, + & array,anyflg,status) + +C Read a 3-d cube of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C nulval i undefined pixels will be set to this value (unless = 0) +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array i the array of values to be read +C anyflg l set to true if any of the image pixels were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + integer array(dim1,dim2,*),nulval + logical anyflg,ltemp + integer fpixel,row,band + + anyflg=.false. + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftgpvj(ounit,group,fpixel,nx,nulval, + & array(1,row,band),ltemp,status) + if (ltemp)anyflg=.true. + fpixel=fpixel+nx +10 continue +20 continue + end diff --git a/pkg/tbtables/fitsio/ftgabc.f b/pkg/tbtables/fitsio/ftgabc.f new file mode 100644 index 00000000..541f6b56 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgabc.f @@ -0,0 +1,49 @@ +C---------------------------------------------------------------------- + subroutine ftgabc(nfield,tform,space, rowlen,tbcol,status) + +C Get ASCII table Beginning Columns +C determine the byte offset of the beginning of each field of a +C ASCII table, and the total width of the table + +C nfield i number of fields in the binary table +C tform c array of FITS datatype codes of each column. +C must be left justified in the string variable +C space i number of blank spaces to insert between each column +C OUTPUT PARAMETERS: +C rowlen i total width of the table, in bytes +C tbcol i beginning position of each column (first column begins at 1) +C status i returned error status +C +C written by Wm Pence, HEASARC/GSFC, June 1992 + + integer nfield,space,rowlen,tbcol(*),status + character*(*) tform(*) + integer i,j,ival + + if (status .gt. 0)return + + rowlen=0 + do 100 i=1,nfield + if (tform(i)(2:2) .eq. ' ')then +C no explicit width; assume width=1 + ival=1 + else +C find the field width characters + j=2 +10 j=j+1 + if (tform(i)(j:j) .eq. ' ' .or. + & tform(i)(j:j) .eq. '.')then +C read the width + call ftc2ii(tform(i)(2:j-1),ival,status) + else +C keep looking for the end of the width field + go to 10 + end if + tbcol(i)=rowlen+1 + rowlen=rowlen+ival+space + end if +100 continue + +C don't add space after the last field + rowlen=rowlen-space + end diff --git a/pkg/tbtables/fitsio/ftgacl.f b/pkg/tbtables/fitsio/ftgacl.f new file mode 100644 index 00000000..06387b3e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgacl.f @@ -0,0 +1,70 @@ +C-------------------------------------------------------------------------- + subroutine ftgacl(iunit,colnum,xtype,xbcol,xunit,xform, + & xscal,xzero,xnull,xdisp,status) + +C Get information about an Ascii CoLumn +C returns the parameters which define the column + +C iunit i Fortran i/o unit number +C colnum i number of the column (first column = 1) +C xtype c name of the column +C xbcol i starting character in the row of the column +C xunit c physical units of the column +C xform c Fortran-77 format of the column +C xscal d scaling factor for the column values +C xzero d scaling zero point for the column values +C xnull c value used to represent undefined values in the column +C xdisp c display format for the column (if different from xform +C status i returned error status + + integer iunit,colnum,xbcol,status + double precision xscal,xzero + character*(*) xtype,xunit,xform,xnull,xdisp + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS------------------------------------ + + integer ibuff,nfound + + if (status .gt. 0)return + + if (colnum .lt. 1 .or. colnum .gt. 999)then +C illegal column number + status=302 + return + end if + + ibuff=bufnum(iunit) + +C get the parameters which are stored in the common block + xbcol=tbcol(colnum+tstart(ibuff))+1 + xform=cform(colnum+tstart(ibuff)) + xscal=tscale(colnum+tstart(ibuff)) + xzero=tzero(colnum+tstart(ibuff)) + xnull=cnull(colnum+tstart(ibuff)) + +C read remaining values from the header keywords + xtype=' ' + call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status) + xunit=' ' + call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status) + xdisp=' ' + call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status) + end diff --git a/pkg/tbtables/fitsio/ftgatp.f b/pkg/tbtables/fitsio/ftgatp.f new file mode 100644 index 00000000..1556915e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgatp.f @@ -0,0 +1,169 @@ +C-------------------------------------------------------------------------- + subroutine ftgatp(ibuff,keynam,value,status) + +C Get ASCII Table Parameter +C test if the keyword is one of the table column definition keywords +C of an ASCII table. If so, decode it and update the value in the common +C block + +C ibuff i sequence number of the data buffer +C keynam c name of the keyword +C value c value of the keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ibuff,status + character keynam*8,value*70 + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- +C nb = number of file buffers = max. number of FITS file opened at once +C nf = maximum number of fields allowed in a table + integer nf,nb + parameter (nb = 20) + parameter (nf = 3000) + +C tfield = number of fields in the table +C tbcol = byte offset in the row of the beginning of the column +C rowlen = length of one row of the table, in bytes +C tdtype = integer code representing the datatype of the column +C trept = the repeat count = number of data values/element in the column +C tnull = the value used to represent an undefined value in the column +C tscale = the scale factor for the column +C tzero = the scaling zero point for the column +C scount = the total size of the binary table heap (+ gap if any) +C theap = the starting byte offset for the binary table heap, relative +C to the start of the binary table data +C nxheap = the next empty heap location + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + +C cnull = character string representing nulls in character columns +C cform = the Fortran format of the column + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer nfield,i,c2,bcol,tstat + character tform*16 + + if (status .gt. 0)return + tstat=status + + if (keynam(1:5) .eq. 'TFORM')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TFORMn keyword + status=tstat + else +C get the TFORM character string, without quotes + call ftc2s(value,tform,status) + if (status .gt. 0)return + if (tform(1:1) .ne. 'A' .and. tform(1:1) .ne. 'I' + & .and. tform(1:1) .ne. 'F' .and. tform(1:1) .ne. 'E' + & .and. tform(1:1) .ne. 'D')then + status=311 + call ftpmsg('Illegal '//keynam//' format code: ' + & //tform) + return + end if + + cform(nfield+tstart(ibuff))=tform +C set numeric data type code to indicate an ASCII table field + tdtype(nfield+tstart(ibuff))=16 +C set the repeat count to 1 + trept(nfield+tstart(ibuff))=1 +C set the TNULL parameter to the width of the field: + c2=0 + do 10 i=2,8 + if (tform(i:i) .ge. '0' .and. tform(i:i) + & .le. '9')then + c2=i + else + go to 20 + end if +10 continue +20 continue + + if (status .gt. 0)return + if (c2 .eq. 0)then +C no explicit field width, so assume width=1 character + tnull(nfield+tstart(ibuff))=1 + else + call ftc2ii(tform(2:c2),tnull(nfield+ + & tstart(ibuff)),status) + if (status .gt. 0)then +C error parsing the TFORM value string + status=261 + call ftpmsg('Error parsing '//keynam//' field width: ' + & //tform) + end if + end if + end if + else if (keynam(1:5) .eq. 'TBCOL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TBCOLn keyword + status=tstat + else +C get the beginning column number + call ftc2ii(value,bcol,status) + if (status .gt. 0)then + call ftpmsg('Error reading value of '//keynam + & //' as an integer: '//value) + else + tbcol(nfield+tstart(ibuff))=bcol-1 + end if + end if + else if (keynam(1:5) .eq. 'TSCAL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TSCALn keyword + status=tstat + else +C get the scale factor + call ftc2dd(value,tscale(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TZERO')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TZEROn keyword + status=tstat + else +C get the scaling zero point + call ftc2dd(value,tzero(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TNULL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TNULLn keyword + status=tstat + else +C get the Null value flag (character) + call ftc2s(value,cnull(nfield+tstart(ibuff)),status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a character string: '//value) + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftgbcl.f b/pkg/tbtables/fitsio/ftgbcl.f new file mode 100644 index 00000000..c7ca1244 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgbcl.f @@ -0,0 +1,119 @@ +C-------------------------------------------------------------------------- + subroutine ftgbcl(iunit,colnum,xtype,xunit,dtype,rcount, + & xscal,xzero,xnull,xdisp,status) + +C Get information about a Binary table CoLumn +C returns the parameters which define the column + +C iunit i Fortran i/o unit number +C colnum i number of the column (first column = 1) +C xtype c name of the column +C xunit c physical units of the column +C dtype c datatype of the column +C rcount i repeat count of the column +C xscal d scaling factor for the column values +C xzero d scaling zero point for the column values +C xnull i value used to represent undefined values in integer column +C xdisp c display format for the column +C status i returned error status + + integer iunit,colnum,rcount,xnull,status + double precision xscal,xzero + character*(*) xtype,xunit,dtype,xdisp + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS------------------------------------ + + integer ibuff,nfound,tcode + logical descrp + character ctemp*2,fwide*4 + + if (status .gt. 0)return + + if (colnum .lt. 1 .or. colnum .gt. 999)then +C illegal column number + status=302 + return + end if + + ibuff=bufnum(iunit) + +C get the parameters which are stored in the common block + rcount=trept(colnum+tstart(ibuff)) + xscal=tscale(colnum+tstart(ibuff)) + xzero=tzero(colnum+tstart(ibuff)) + xnull=tnull(colnum+tstart(ibuff)) + +C translate the numeric data type code + dtype=' ' + tcode=tdtype(colnum+tstart(ibuff)) + if (tcode .lt. 0)then + descrp=.true. + tcode=-tcode + else + descrp=.false. + end if + + if (tcode .eq. 21)then + dtype='I' + else if (tcode .eq. 41)then + dtype='J' + else if (tcode .eq. 42)then + dtype='E' + else if (tcode .eq. 82)then + dtype='D' + else if (tcode .eq. 16)then +C this is an ASCII field; width of field is stored in TNULL + write(fwide,1000)tnull(colnum+tstart(ibuff)) +1000 format(i4) + if (tnull(colnum+tstart(ibuff)) .gt. 999)then + dtype='A'//fwide + else if (tnull(colnum+tstart(ibuff)) .gt. 99)then + dtype='A'//fwide(2:4) + else if (tnull(colnum+tstart(ibuff)) .gt. 9)then + dtype='A'//fwide(3:4) + else if (tnull(colnum+tstart(ibuff)) .gt. 0)then + dtype='A'//fwide(4:4) + else + dtype='A' + end if + else if (tcode .eq. 14)then + dtype='L' + else if (tcode .eq. 1)then + dtype='X' + else if (tcode .eq. 11)then + dtype='B' + else if (tcode .eq. 83)then + dtype='C' + else if (tcode .eq. 163)then + dtype='M' + end if + + if (descrp)then + ctemp='P'//dtype(1:1) + dtype=ctemp + end if + +C read remaining values from the header keywords + xtype=' ' + call ftgkns(iunit,'TTYPE',colnum,1,xtype,nfound,status) + xunit=' ' + call ftgkns(iunit,'TUNIT',colnum,1,xunit,nfound,status) + xdisp=' ' + call ftgkns(iunit,'TDISP',colnum,1,xdisp,nfound,status) + end diff --git a/pkg/tbtables/fitsio/ftgbit.f b/pkg/tbtables/fitsio/ftgbit.f new file mode 100644 index 00000000..08dc9e29 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgbit.f @@ -0,0 +1,68 @@ +C---------------------------------------------------------------------- + subroutine ftgbit(buffer,log8) + +C decode the individual bits within the byte into an array of +C logical values. The corresponding logical value is set to +C true if the bit is set to 1. + +C buffer i input integer containing the byte to be decoded +C log8 l output array of logical data values corresponding +C to the bits in the input buffer +C +C written by Wm Pence, HEASARC/GSFC, May 1992 + + integer buffer,tbuff + logical log8(8) + + log8(1)=.false. + log8(2)=.false. + log8(3)=.false. + log8(4)=.false. + log8(5)=.false. + log8(6)=.false. + log8(7)=.false. + log8(8)=.false. + +C test for special case: no bits are set + if (buffer .eq. 0)return + +C This algorithm tests to see if each bit is set by testing +C the numerical value of the byte, starting with the most significant +C bit. If the bit is set, then it is reset to zero before testing +C the next most significant bit, and so on. + + tbuff=buffer + +C now decode the least significant byte + if (tbuff .gt. 127)then + log8(1)=.true. + tbuff=tbuff-128 + end if + if (tbuff .gt. 63)then + log8(2)=.true. + tbuff=tbuff-64 + end if + if (tbuff .gt. 31)then + log8(3)=.true. + tbuff=tbuff-32 + end if + if (tbuff .gt. 15)then + log8(4)=.true. + tbuff=tbuff-16 + end if + if (tbuff .gt. 7)then + log8(5)=.true. + tbuff=tbuff-8 + end if + if (tbuff .gt. 3)then + log8(6)=.true. + tbuff=tbuff-4 + end if + if (tbuff .gt. 1)then + log8(7)=.true. + tbuff=tbuff-2 + end if + if (tbuff .eq. 1)then + log8(8)=.true. + end if + end diff --git a/pkg/tbtables/fitsio/ftgbnh.f b/pkg/tbtables/fitsio/ftgbnh.f new file mode 100644 index 00000000..894bffdf --- /dev/null +++ b/pkg/tbtables/fitsio/ftgbnh.f @@ -0,0 +1,12 @@ +C---------------------------------------------------------------------- + subroutine ftgbnh(iunit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + +C OBSOLETE routine: should call ftghbn instead + + integer iunit,nrows,nfield,pcount,status + character*(*) ttype(*),tform(*),tunit(*),extnam + + call ftghbn(iunit,-1,nrows,nfield,ttype,tform, + & tunit,extnam,pcount,status) + end diff --git a/pkg/tbtables/fitsio/ftgbtp.f b/pkg/tbtables/fitsio/ftgbtp.f new file mode 100644 index 00000000..91af6d81 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgbtp.f @@ -0,0 +1,119 @@ +C-------------------------------------------------------------------------- + subroutine ftgbtp(ibuff,keynam,value,status) + +C Get Binary Table Parameter +C test if the keyword is one of the table column definition keywords +C of a binary table. If so, decode it and update the values in the common +C block + +C ibuff i sequence number of the data buffer +C OUTPUT PARAMETERS: +C keynam c name of the keyword +C value c value of the keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ibuff,status,width + character keynam*8,value*70 + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- +C nb = number of file buffers = max. number of FITS file opened at once +C nf = maximum number of fields allowed in a table + integer nf,nb + parameter (nb = 20) + parameter (nf = 3000) + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer nfield,tstat + character tform*16 + + if (status .gt. 0)return + tstat=status + + if (keynam(1:5) .eq. 'TFORM')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TFORMn keyword + status=tstat + else +C get the TFORM character string, without quotes + call ftc2s(value,tform,status) +C get the datatype code and repeat count + call ftbnfm(tform,tdtype(nfield+tstart(ibuff)), + & trept(nfield+tstart(ibuff)),width,status) + if (tdtype(nfield+tstart(ibuff)) .eq. 1)then +C treat Bit datatype as if it were a Byte datatype + tdtype(nfield+tstart(ibuff))=11 + trept(nfield+tstart(ibuff))=(trept(nfield+ + & tstart(ibuff))+7)/8 + else if (tdtype(nfield+tstart(ibuff)) .eq. 16)then +C store the width of the ASCII field in the TNULL parameter + tnull(nfield+tstart(ibuff))=width + end if + end if + else if (keynam(1:5) .eq. 'TSCAL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TSCALn keyword + status=tstat + else +C get the scale factor + call ftc2dd(value,tscale(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TZERO')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TZEROn keyword + status=tstat + else +C get the scaling zero point + call ftc2dd(value,tzero(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of'//keynam + & //' as a Double: '//value) + end if + end if + else if (keynam(1:5) .eq. 'TNULL')then +C get the field number + call ftc2ii(keynam(6:8),nfield,status) + if (status .gt. 0)then +C this must not have been a TNULLn keyword + status=tstat + else +C make sure this is not an ASCII column (the tnull +C variable is use to store the ASCII column width) + if (tdtype(nfield+tstart(ibuff)) .ne. 16)then +C get the Null value flag (Integer) + call ftc2ii(value,tnull(nfield+tstart(ibuff)), + & status) + if (status .gt. 0)then + call ftpmsg('Error reading value of '// + & keynam//' as an integer: '//value) + end if + end if + end if + else if (keynam(1:8) .eq. 'THEAP ')then +C get the heap offset value + call ftc2ii(value,theap(ibuff),status) + if (status .gt. 0)then + call ftpmsg('Error reading value of '//keynam + & //' as an integer: '//value) + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftgcfb.f b/pkg/tbtables/fitsio/ftgcfb.f new file mode 100644 index 00000000..5c480f1d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfb.f @@ -0,0 +1,33 @@ +C---------------------------------------------------------------------- + subroutine ftgcfb(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of byte values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array b returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + character*1 array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgclb(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfc.f b/pkg/tbtables/fitsio/ftgcfc.f new file mode 100644 index 00000000..a1598b9a --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfc.f @@ -0,0 +1,33 @@ +C---------------------------------------------------------------------- + subroutine ftgcfc(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of complex values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array cmp returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + real array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgclc(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfd.f b/pkg/tbtables/fitsio/ftgcfd.f new file mode 100644 index 00000000..546a9e41 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfd.f @@ -0,0 +1,33 @@ +C---------------------------------------------------------------------- + subroutine ftgcfd(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of r*8 values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array d returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + double precision array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgcld(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfe.f b/pkg/tbtables/fitsio/ftgcfe.f new file mode 100644 index 00000000..8944d0b4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfe.f @@ -0,0 +1,33 @@ +C---------------------------------------------------------------------- + subroutine ftgcfe(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of R*4 values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array r returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + real array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgcle(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfi.f b/pkg/tbtables/fitsio/ftgcfi.f new file mode 100644 index 00000000..63a44d66 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfi.f @@ -0,0 +1,33 @@ +C---------------------------------------------------------------------- + subroutine ftgcfi(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of I*2 values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array i*2 returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + integer*2 array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgcli(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfj.f b/pkg/tbtables/fitsio/ftgcfj.f new file mode 100644 index 00000000..ff21759e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfj.f @@ -0,0 +1,32 @@ +C---------------------------------------------------------------------- + subroutine ftgcfj(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of I*4 values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array i returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + integer array(*),dummy,i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgclj(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfl.f b/pkg/tbtables/fitsio/ftgcfl.f new file mode 100644 index 00000000..5bb9d2d4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfl.f @@ -0,0 +1,150 @@ +C---------------------------------------------------------------------- + subroutine ftgcfl(iunit,colnum,frow,felem,nelem,lray, + & flgval,anynul,status) + +C read an array of logical values from a specified column of the table. +C The binary table column being read from must have datatype 'L' +C and no datatype conversion will be perform if it is not. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C lray l returned array of data values that is read +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical lray(*),flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,maxpix,tcode,offset + integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart + character*1 buffer(80) + logical descrp + + if (status .gt. 0)return + + ibuff=bufnum(iunit) +C check for zero length array + if (nelem .le. 0)then + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + else if (felem .lt. 1)then +C illegal element number + status=308 + end if + + if (status .gt. 0)return + +C initialize the null flag array + do 5 i=1,nelem + flgval(i)=.false. +5 continue + anynul=.false. + + i1=0 + ntodo=nelem + rstart=frow-1 + estart=felem-1 + maxpix=80 + tcode=tdtype(colnum+tstart(ibuff)) + + if (tcode .eq. 14)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + return + end if + descrp=.false. + else if (tcode .eq. -14)then +C this is a variable length descriptor column + descrp=.true. +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+ntodo .gt. repeat)then +C error: trying to read beyond end of record + status=319 + return + end if +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+offset+ + & theap(ibuff)+estart + call ftmbyt(iunit,bstart,.true.,status) + else +C column must be logical data type + status=312 + return + end if + +C process as many contiguous pixels as possible +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + call ftmbyt(iunit,bstart,.false.,status) + end if + +C get the array of logical bytes + call ftgcbf(iunit,1,itodo,buffer,status) + if (status .gt. 0)return + +C decode the 'T' and 'F' characters, and look for nulls (0) + do 10 i=1,itodo + if (buffer(i) .eq. 'T')then + lray(i1+i)=.true. + else if (buffer(i) .eq. 'F')then + lray(i1+i)=.false. + else if (ichar(buffer(i)) .eq. 0)then + flgval(i1+i)=.true. + anynul=.true. + else + status=316 + return + end if +10 continue + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftgcfm.f b/pkg/tbtables/fitsio/ftgcfm.f new file mode 100644 index 00000000..a76c9724 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfm.f @@ -0,0 +1,34 @@ +C---------------------------------------------------------------------- + subroutine ftgcfm(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of double precision complex values from a specified +C column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C array dcmp returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + double precision array(*),dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgclm(iunit,colnum,frow,felem,nelem,1,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcfs.f b/pkg/tbtables/fitsio/ftgcfs.f new file mode 100644 index 00000000..a2625149 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcfs.f @@ -0,0 +1,34 @@ +C---------------------------------------------------------------------- + subroutine ftgcfs(iunit,colnum,frow,felem,nelem,array, + & flgval,anynul,status) + +C read an array of string values from a specified column of the table. +C Any undefined pixels will be have the corresponding value of FLGVAL +C set equal to .true., and ANYNUL will be set equal to .true. if +C any pixels are undefined. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element in the row to read +C nelem i number of elements to read +C array c returned array of data values that was read from FITS file +C flgval l set .true. if corresponding element undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval(*),anynul + character*(*) array(*) + character*8 dummy + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + + call ftgcls(iunit,colnum,frow,felem,nelem,2,dummy, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcks.f b/pkg/tbtables/fitsio/ftgcks.f new file mode 100644 index 00000000..ac712f08 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcks.f @@ -0,0 +1,54 @@ +C---------------------------------------------------------------------- + subroutine ftgcks(iunit,datsum,chksum,status) + +C calculate and encode the checksums of the data unit and the total HDU + +C iunit i fortran unit number +C datsum d output checksum for the data +C chksum d output checksum for the entire HDU +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Sept, 1994 + + integer iunit,status + double precision datsum,chksum + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,nrec + + if (status .gt. 0)return + +C calculate number of data records + ibuff=bufnum(iunit) + nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 + + datsum=0. + if (nrec .gt. 0)then + +C move to the start of the data + call ftmbyt(iunit,dtstrt(ibuff),.true.,status) + +C accumulate the 32-bit 1's complement checksum + call ftcsum(iunit,nrec,datsum,status) + end if + +C move to the start of the header + call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) + +C calculate number of FITS blocks in the header + nrec=(dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 + +C accumulate the header into the checksum + chksum=datsum + call ftcsum(iunit,nrec,chksum,status) + end diff --git a/pkg/tbtables/fitsio/ftgcl.f b/pkg/tbtables/fitsio/ftgcl.f new file mode 100644 index 00000000..4331aa93 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcl.f @@ -0,0 +1,184 @@ +C---------------------------------------------------------------------- + subroutine ftgcl(iunit,colnum,frow,felem,nelem,lray,status) + +C read an array of logical values from a specified column of the table. +C The binary table column being read from must have datatype 'L' +C and no datatype conversion will be perform if it is not. +C This routine ignores any undefined values in the logical array. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C lray l returned array of data values that is read +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical lray(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,maxpix,offset,tcode + integer ibuff,i,i1,ntodo,itodo,repeat,rstart,estart + character*1 buffer(80) + logical descrp + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + tcode=tdtype(colnum+tstart(ibuff)) + +C check for zero length array + if (nelem .le. 0)then + return + else if (frow .lt. 1)then +C error: illegal first row number + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCL).') + status=307 + return + else if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCL).') + return + end if + + i1=0 + ntodo=nelem + rstart=frow-1 + estart=felem-1 + maxpix=80 + + if (tcode .eq. 14)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCL).') + return + end if + descrp=.false. + else if (tcode .eq. -14)then +C this is a variable length descriptor column + descrp=.true. +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+ntodo .gt. repeat)then +C error: trying to read beyond end of record + status=319 + return + end if +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+offset+ + & theap(ibuff)+estart + call ftmbyt(iunit,bstart,.true.,status) + else +C column must be logical data type + status=312 + return + end if + +C process as many contiguous pixels as possible +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + call ftmbyt(iunit,bstart,.false.,status) + end if + +C get the array of logical bytes + call ftgcbf(iunit,1,itodo,buffer,status) + +C decode the 'T' and 'F' characters, + do 10 i=1,itodo + if (buffer(i) .eq. 'T')then + lray(i1+i)=.true. + else if (buffer(i) .eq. 'F')then + lray(i1+i)=.false. + else if (ichar(buffer(i)) .eq. 0)then +C ignore null values; leave input logical value unchanged + else +C illegal logical value + status=316 + return + end if +10 continue + + if (status .gt. 0)then + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLB.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLB).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLB).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftgclb.f b/pkg/tbtables/fitsio/ftgclb.f new file mode 100644 index 00000000..c3f7a7e0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgclb.f @@ -0,0 +1,380 @@ +C---------------------------------------------------------------------- + subroutine ftgclb(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of byte data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval b value that undefined pixels will be set to (if nultyp=1) +C array b array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + character*1 array(*),nulval + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,i4null,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + integer offset,rskip,dstart,begcol,lenrow + integer*2 i2null + character*1 i1null + real rval + double precision scale,zero,dval + character sval*40,sform*13,snull*16 + logical tofits,descrp,trans + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLB).') + return + end if + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) +C the data are being scaled from FITS to internal format + tofits=.false. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) +C check for important special case: no datatype conversion required + if (abs(tcode) .eq. 11)then + maxpix=nelem + else + maxpix=bufdim/bytpix*4 + end if + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + if (tcode .eq. 16)then +C this is an ASCII table; each element will be read one at a time + repeat=1 + estart=0 +C construct the read format, and get the null value string +C Microsoft Fortran 5.0 can't handle: +C sform='(BN,'//cform(colnum+tstart(ibuff))//')' + sform='(BN, )' + sform(5:12)=cform(colnum+tstart(ibuff)) + snull=cnull(colnum+tstart(ibuff)) + sval=' ' + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLB).') + return + end if + estart=felem-1 + + if (tcode .gt. 0)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLB).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=maxpix*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) + % then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + end if + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. ichar(nulval) .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values +C see if the null value has been defined for this column + nulchk=0 + if (tcode .eq. 11)then +C check if byte datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i1null=char(tnull(colnum+tstart(ibuff))) + nulchk=nultyp + end if + else if (tcode .eq. 21)then +C check if I*2 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i2null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 41)then +C check if I*4 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i4null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 42 .or. tcode .eq. 82)then +C have to check floating point data for NaN values + nulchk=nultyp + end if + end if + + if (nulchk .eq. 0 .and. scale .eq. 1. .and. zero .eq. 0.)then + trans=.false. + else + trans=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data from FITS file, doing datatype conversion and scaling + if (tcode .eq. 21)then +C column data type is I (I*2) +C read the data and do any machine dependent data conversion + call ftgi2b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti2i1(buffer,itodo,scale,zero,tofits, + & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 41)then +C column data type is J (I*4) +C read the data and do any machine dependent data conversion + call ftgi4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti4i1(buffer,itodo,scale,zero,tofits, + & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 42)then +C column data type is E (R*4) +C read the data and do any machine dependent data conversion + call ftgr4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr4i1(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 82)then +C column data type is D (R*8) +C read the data and do any machine dependent data conversion + call ftgr8b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr8i1(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 11)then +C column data type is B (byte) +C read the data and do any machine dependent data conversion +C note that we can use the input array directly + call ftgi1b(iunit,itodo,incre,array(i1),status) +C check for null values, and do scaling and datatype conversion + if (trans)then + call fti1i1(array(i1),itodo,scale,zero,tofits,nulchk, + & i1null,nulval,flgval(i1),anynul,array(i1),status) + end if + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column; get the character string + call ftgcbf(iunit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + if (status .gt. 0)return + +C check for null + if (sval(1:16) .eq. snull)then + anynul=.true. + if (nultyp .eq. 1)then + array(i1)=nulval + else + flgval(i1)=.true. + end if + go to 30 + end if + +C now read the value, then do scaling and datatype conversion + if (sform(5:5) .eq. 'I')then + read(sval,sform,err=900)ival + call fti4i1(ival,itodo,scale,zero,tofits,0, + & i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5).eq.'F'.or. sform(5:5).eq.'E')then + read(sval,sform,err=900)rval + call ftr4i1(rval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5) .eq. 'D')then + read(sval,sform,err=900)dval + call ftr8i1(dval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot read byte (I*1) values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLB).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot read byte (I*1) values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLB).') + return + end if + +C find number of pixels left to do, and quit if none left +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading pixels'//cp1//' to'//cp2 + & // ' of the FITS image array (FTGCLB).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while reading group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLB.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLB).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLB).') + end if + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred reading '// + & 'Byte data from FITS file.') + end if + return + +900 continue +C error reading formatted data value from ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error reading colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to read "'//sval(1:20)// + & '" with format '//sform//' (FTGCLB).') + status=315 + end diff --git a/pkg/tbtables/fitsio/ftgclc.f b/pkg/tbtables/fitsio/ftgclc.f new file mode 100644 index 00000000..f90ff05c --- /dev/null +++ b/pkg/tbtables/fitsio/ftgclc.f @@ -0,0 +1,238 @@ +C---------------------------------------------------------------------- + subroutine ftgclc(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of complex data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. +C The binary table column being read to must have datatype 'C' +C and no datatype conversion will be perform if it is not. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of (pairs) elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval r value that undefined pixels will be set to (if nultyp=1) +C array r array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + real array(*),nulval(2) + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bytpix,bstart,tcode,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart + integer offset,rskip,dstart,begcol,lenrow,i,j + logical scaled,descrp + double precision scale,zero + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLC).') + return + end if + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLC).') + return + end if + + i1=1 + ntodo=nelem + estart=felem-1 + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + bytpix=8 + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + + if (tcode .eq. 83)then + descrp=.false. + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLC).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=nelem*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else if (tcode .eq. -83)then +C this is a variable length descriptor column +C read the number of elements and the starting offset: + descrp=.true. + call ftgdes(iunit,colnum,frow,repeat,offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + else +C column must be complex data type + status=312 + call ftpmsg('Column'//ccol//' does not have '// + & 'Complex (C) data type (FTGCLC).') + return + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval(1) .eq. 0 .and. + & nulval(2) .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values + nulchk=nultyp + end if + +C check if scaling is required + if (scale .eq. 1.0 .and. zero .eq. 0.)then + scaled=.false. + else + scaled=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data + if (incre .eq. 8)then +C the data values are contiguous in the FITS file +C multiply itodo*2 because we are getting pairs of values + call ftgr4b(iunit,itodo*2,4,array(i1),status) + else +C have to read each complex pair one by one + j=i1 + call ftgr4b(iunit,2,4,array(j),status) + j=j+2 + do 25 i=2,itodo + call ftmoff(iunit,incre-8,.false.,status) + call ftgr4b(iunit,2,4,array(j),status) + j=j+2 +25 continue + end if + +C find number of pixels left to do, and process them +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLC.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLC).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLC).') + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo*2 + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for null values and/or scale the values + if (nulchk .ne. 0 .or. scaled)then + call ftnulc(array,nelem,nulchk,nulval,flgval,anynul, + & scaled,scale,zero) + end if + end diff --git a/pkg/tbtables/fitsio/ftgcld.f b/pkg/tbtables/fitsio/ftgcld.f new file mode 100644 index 00000000..46b2d92e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcld.f @@ -0,0 +1,382 @@ +C---------------------------------------------------------------------- + subroutine ftgcld(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of real*8 data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval d value that undefined pixels will be set to (if nultyp=1) +C array d array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + double precision array(*),nulval + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,i4null,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + integer offset,rskip,dstart,begcol,lenrow + integer*2 i2null + character*1 i1null + real rval + double precision scale,zero,dval + character sval*40,sform*13,snull*16 + character crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,descrp,trans + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLD).') + return + end if + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) +C the data are being scaled from FITS to internal format + tofits=.false. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) +C check for important special case: no datatype conversion required + if (abs(tcode) .eq. 82)then + maxpix=nelem + else + maxpix=bufdim/bytpix*4 + end if + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + if (tcode .eq. 16)then +C this is an ASCII table; each element will be read one at a time + repeat=1 + estart=0 +C construct the read format, and get the null value string +C Microsoft Fortran 5.0 bug can't handle: +C sform='(BN,'//cform(colnum+tstart(ibuff))//')' + sform='(BN, )' + sform(5:12)=cform(colnum+tstart(ibuff)) + snull=cnull(colnum+tstart(ibuff)) + sval=' ' + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLD).') + return + end if + estart=felem-1 + + if (tcode .gt. 0)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLD).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=maxpix*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) + % then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + end if + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values +C see if the null value has been defined for this column + nulchk=0 + if (tcode .eq. 11)then +C check if byte datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i1null=char(tnull(colnum+tstart(ibuff))) + nulchk=nultyp + end if + else if (tcode .eq. 21)then +C check if I*2 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i2null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 41)then +C check if I*4 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i4null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 42 .or. tcode .eq. 82)then +C have to check floating point data for NaN values + nulchk=nultyp + end if + end if + + if (nulchk .eq. 0 .and. scale .eq. 1. .and. zero .eq. 0.)then + trans=.false. + else + trans=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data from FITS file, doing datatype conversion and scaling + if (tcode .eq. 21)then +C column data type is I (I*2) +C read the data and do any machine dependent data conversion + call ftgi2b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti2r8(buffer,itodo,scale,zero,tofits, + & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 41)then +C column data type is J (I*4) +C read the data and do any machine dependent data conversion + call ftgi4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti4r8(buffer,itodo,scale,zero,tofits, + & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 42)then +C column data type is E (R*4) +C read the data and do any machine dependent data conversion + call ftgr4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr4r8(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 82)then +C column data type is D (R*8) +C read the data and do any machine dependent data conversion +C note that we can use the input array directly + call ftgr8b(iunit,itodo,incre,array(i1),status) +C check for null values, and do scaling and datatype conversion + if (trans)then + call ftr8r8(array(i1),itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + end if + else if (tcode .eq. 11)then +C column data type is B (byte) +C read the data and do any machine dependent data conversion + call ftgi1b(iunit,itodo,incre,chbuff,status) +C check for null values, and do scaling and datatype conversion + call fti1r8(chbuff,itodo,scale,zero,tofits, + & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column; get the character string + call ftgcbf(iunit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + if (status .gt. 0)return + +C check for null + if (sval(1:16) .eq. snull)then + anynul=.true. + if (nultyp .eq. 1)then + array(i1)=nulval + else + flgval(i1)=.true. + end if + go to 30 + end if + +C now read the value, then do scaling and datatype conversion + if (sform(5:5) .eq. 'I')then + read(sval,sform,err=900)ival + call fti4r8(ival,itodo,scale,zero,tofits, + & 0,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5).eq.'F'.or. sform(5:5).eq.'E')then + read(sval,sform,err=900)rval + call ftr4r8(rval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5) .eq. 'D')then + read(sval,sform,err=900)dval + call ftr8r8(dval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot read double values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLD).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot read double values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLD).') + return + end if + +C find number of pixels left to do, and quit if none left +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading pixels'//cp1//' to'//cp2 + & // ' of the FITS image array (FTGCLD).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while reading group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLD.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLD).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLD).') + end if + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred reading '// + & 'Real*8 data from FITS file.') + end if + return + +900 continue +C error reading formatted data value from ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error reading colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to read "'//sval(1:20)// + & '" with format '//sform//' (FTGCLD).') + status=315 + end diff --git a/pkg/tbtables/fitsio/ftgcle.f b/pkg/tbtables/fitsio/ftgcle.f new file mode 100644 index 00000000..375db9f9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcle.f @@ -0,0 +1,382 @@ +C---------------------------------------------------------------------- + subroutine ftgcle(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of real*4 data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval r value that undefined pixels will be set to (if nultyp=1) +C array r array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + real array(*),nulval + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,i4null,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + integer offset,rskip,dstart,begcol,lenrow + integer*2 i2null + character*1 i1null + real rval + double precision scale,zero,dval + character sval*40,sform*13,snull*16 + character crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,descrp,trans + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLE).') + return + end if + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) +C the data are being scaled from FITS to internal format + tofits=.false. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) +C check for important special case: no datatype conversion required + if (abs(tcode) .eq. 42)then + maxpix=nelem + else + maxpix=bufdim/bytpix*4 + end if + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + if (tcode .eq. 16)then +C this is an ASCII table; each element will be read one at a time + repeat=1 + estart=0 +C construct the read format, and get the null value string +C Microsoft Fortran 5.0 bug can't handle: +C sform='(BN,'//cform(colnum+tstart(ibuff))//')' + sform='(BN, )' + sform(5:12)=cform(colnum+tstart(ibuff)) + snull=cnull(colnum+tstart(ibuff)) + sval=' ' + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLE).') + return + end if + estart=felem-1 + + if (tcode .gt. 0)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLE).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=maxpix*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) + % then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + end if + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values +C see if the null value has been defined for this column + nulchk=0 + if (tcode .eq. 11)then +C check if byte datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i1null=char(tnull(colnum+tstart(ibuff))) + nulchk=nultyp + end if + else if (tcode .eq. 21)then +C check if I*2 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i2null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 41)then +C check if I*4 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i4null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 42 .or. tcode .eq. 82)then +C have to check floating point data for NaN values + nulchk=nultyp + end if + end if + + if (nulchk .eq. 0 .and. scale .eq. 1. .and. zero .eq. 0.)then + trans=.false. + else + trans=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data from FITS file, doing datatype conversion and scaling + if (tcode .eq. 21)then +C column data type is I (I*2) +C read the data and do any machine dependent data conversion + call ftgi2b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti2r4(buffer,itodo,scale,zero,tofits, + & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 41)then +C column data type is J (I*4) +C read the data and do any machine dependent data conversion + call ftgi4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti4r4(buffer,itodo,scale,zero,tofits, + & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 42)then +C column data type is E (R*4) +C read the data and do any machine dependent data conversion +C note that we can use the input array directly + call ftgr4b(iunit,itodo,incre,array(i1),status) +C check for null values, and do scaling and datatype conversion + if (trans)then + call ftr4r4(array(i1),itodo,scale,zero,tofits,nulchk, + & nulval,flgval(i1),anynul,array(i1),status) + end if + else if (tcode .eq. 82)then +C column data type is D (R*8) +C read the data and do any machine dependent data conversion + call ftgr8b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr8r4(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 11)then +C column data type is B (byte) +C read the data and do any machine dependent data conversion + call ftgi1b(iunit,itodo,incre,chbuff,status) +C check for null values, and do scaling and datatype conversion + call fti1r4(chbuff,itodo,scale,zero,tofits, + & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column; get the character string + call ftgcbf(iunit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + if (status .gt. 0)return + +C check for null + if (sval(1:16) .eq. snull)then + anynul=.true. + if (nultyp .eq. 1)then + array(i1)=nulval + else + flgval(i1)=.true. + end if + go to 30 + end if + +C now read the value, then do scaling and datatype conversion + if (sform(5:5) .eq. 'I')then + read(sval,sform,err=900)ival + call fti4r4(ival,itodo,scale,zero,tofits, + & 0,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5).eq.'F'.or. sform(5:5).eq.'E')then + read(sval,sform,err=900)rval + call ftr4r4(rval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5) .eq. 'D')then + read(sval,sform,err=900)dval + call ftr8r4(dval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot read real values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLE).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot read real values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLE).') + return + end if + +C find number of pixels left to do, and quit if none left +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading pixels'//cp1//' to'//cp2 + & // ' of the FITS image array (FTGCLE).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while reading group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLE.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLE).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLE).') + end if + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred reading '// + & 'Real*4 data from FITS file.') + end if + return + +900 continue +C error reading formatted data value from ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error reading colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to read "'//sval(1:20)// + & '" with format '//sform//' (FTGCLE).') + status=315 + end diff --git a/pkg/tbtables/fitsio/ftgcli.f b/pkg/tbtables/fitsio/ftgcli.f new file mode 100644 index 00000000..1ef258c4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcli.f @@ -0,0 +1,382 @@ +C---------------------------------------------------------------------- + subroutine ftgcli(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of integer*2 data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval i*2 value that undefined pixels will be set to (if nultyp=1) +C array i*2 array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + integer*2 array(*),nulval + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,i4null,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + integer offset,rskip,dstart,begcol,lenrow + integer*2 i2null + character*1 i1null + real rval + double precision scale,zero,dval + character sval*40,sform*13,snull*16 + character crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,descrp,trans + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLI).') + return + end if + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) +C the data are being scaled from FITS to internal format + tofits=.false. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) +C check for important special case: no datatype conversion required + if (abs(tcode) .eq. 21)then + maxpix=nelem + else + maxpix=bufdim/bytpix*4 + end if + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + if (tcode .eq. 16)then +C this is an ASCII table; each element will be read one at a time + repeat=1 + estart=0 +C construct the read format, and get the null value string +C Microsoft Fortran 5.0 bug can't handle: +C sform='(BN,'//cform(colnum+tstart(ibuff))//')' + sform='(BN, )' + sform(5:12)=cform(colnum+tstart(ibuff)) + snull=cnull(colnum+tstart(ibuff)) + sval=' ' + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLI).') + return + end if + estart=felem-1 + + if (tcode .gt. 0)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLI).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=maxpix*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) + % then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + end if + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values +C see if the null value has been defined for this column + nulchk=0 + if (tcode .eq. 11)then +C check if byte datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i1null=char(tnull(colnum+tstart(ibuff))) + nulchk=nultyp + end if + else if (tcode .eq. 21)then +C check if I*2 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i2null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 41)then +C check if I*4 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i4null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 42 .or. tcode .eq. 82)then +C have to check floating point data for NaN values + nulchk=nultyp + end if + end if + + if (nulchk .eq. 0 .and. scale .eq. 1. .and. zero .eq. 0.)then + trans=.false. + else + trans=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data from FITS file, doing datatype conversion and scaling + if (tcode .eq. 21)then +C column data type is I (I*2) +C read the data and do any machine dependent data conversion +C note that we can use the input array directly + call ftgi2b(iunit,itodo,incre,array(i1),status) +C check for null values, and do scaling and datatype conversion + if (trans)then + call fti2i2(array(i1),itodo,scale,zero,tofits,nulchk, + & i2null,nulval,flgval(i1),anynul,array(i1),status) + end if + else if (tcode .eq. 41)then +C column data type is J (I*4) +C read the data and do any machine dependent data conversion + call ftgi4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti4i2(buffer,itodo,scale,zero,tofits, + & nulchk,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 42)then +C column data type is E (R*4) +C read the data and do any machine dependent data conversion + call ftgr4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr4i2(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 82)then +C column data type is D (R*8) +C read the data and do any machine dependent data conversion + call ftgr8b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr8i2(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 11)then +C column data type is B (byte) +C read the data and do any machine dependent data conversion + call ftgi1b(iunit,itodo,incre,chbuff,status) +C check for null values, and do scaling and datatype conversion + call fti1i2(chbuff,itodo,scale,zero,tofits, + & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column; get the character string + call ftgcbf(iunit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + if (status .gt. 0)return + +C check for null + if (sval(1:16) .eq. snull)then + anynul=.true. + if (nultyp .eq. 1)then + array(i1)=nulval + else + flgval(i1)=.true. + end if + go to 30 + end if + +C now read the value, then do scaling and datatype conversion + if (sform(5:5) .eq. 'I')then + read(sval,sform,err=900)ival + call fti4i2(ival,itodo,scale,zero,tofits, + & 0,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5).eq.'F'.or. sform(5:5).eq.'E')then + read(sval,sform,err=900)rval + call ftr4i2(rval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5) .eq. 'D')then + read(sval,sform,err=900)dval + call ftr8i2(dval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot read integer*2 values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLI).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot read integer*2 values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLI).') + return + end if + +C find number of pixels left to do, and quit if none left +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading pixels'//cp1//' to'//cp2 + & // ' of the FITS image array (FTGCLI).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while reading group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLI.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLI).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLI).') + end if + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred reading '// + & 'Integer*4 data from FITS file.') + end if + return + +900 continue +C error reading formatted data value from ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error reading colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to read "'//sval(1:20)// + & '" with format '//sform//' (FTGCLI).') + status=315 + end diff --git a/pkg/tbtables/fitsio/ftgclj.f b/pkg/tbtables/fitsio/ftgclj.f new file mode 100644 index 00000000..c0309ed6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgclj.f @@ -0,0 +1,384 @@ +C---------------------------------------------------------------------- + subroutine ftgclj(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of integer*4 data values from the specified column of +C the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval i value that undefined pixels will be set to (if nultyp=1) +C array i array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + integer array(*),nulval + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,i4null,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + integer offset,rskip,dstart,begcol,lenrow + integer*2 i2null + character*1 i1null + real rval + double precision scale,zero,dval,align + character sval*40,sform*13,snull*16 + character crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,descrp,trans +C the following equivalence is required for the HP/UX PA-RISC complier +C to force the buffer to be double word aligned. + equivalence (align,buffer(1)) + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLJ).') + return + end if + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) +C the data are being scaled from FITS to internal format + tofits=.false. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) +C check for important special case: no datatype conversion required + if (abs(tcode) .eq. 41)then + maxpix=nelem + else + maxpix=bufdim/bytpix*4 + end if + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + if (tcode .eq. 16)then +C this is an ASCII table; each element will be read one at a time + repeat=1 + estart=0 +C construct the read format, and get the null value string +C Microsoft Fortran 5.0 bug can't handle: +C sform='(BN,'//cform(colnum+tstart(ibuff))//')' + sform='(BN, )' + sform(5:12)=cform(colnum+tstart(ibuff)) + snull=cnull(colnum+tstart(ibuff)) + sval=' ' + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLJ).') + return + end if + estart=felem-1 + + if (tcode .gt. 0)then + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLJ).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=maxpix*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) + % then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + end if + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values +C see if the null value has been defined for this column + nulchk=0 + if (tcode .eq. 11)then +C check if byte datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i1null=char(tnull(colnum+tstart(ibuff))) + nulchk=nultyp + end if + else if (tcode .eq. 21)then +C check if I*2 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i2null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 41)then +C check if I*4 datatype null value is defined, + if (tnull(colnum+tstart(ibuff)).ne.123454321)then + i4null=tnull(colnum+tstart(ibuff)) + nulchk=nultyp + end if + else if (tcode .eq. 42 .or. tcode .eq. 82)then +C have to check floating point data for NaN values + nulchk=nultyp + end if + end if + + if (nulchk .eq. 0 .and. scale .eq. 1. .and. zero .eq. 0.)then + trans=.false. + else + trans=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1,maxpix) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data from FITS file, doing datatype conversion and scaling + if (tcode .eq. 21)then +C column data type is I (I*2) +C read the data and do any machine dependent data conversion + call ftgi2b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call fti2i4(buffer,itodo,scale,zero,tofits, + & nulchk,i2null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 41)then +C column data type is J (I*4) +C read the data and do any machine dependent data conversion +C note that we can use the input array directly + call ftgi4b(iunit,itodo,incre,array(i1),status) +C check for null values, and do scaling and datatype conversion + if (trans)then + call fti4i4(array(i1),itodo,scale,zero,tofits,nulchk, + & i4null,nulval,flgval(i1),anynul,array(i1),status) + end if + else if (tcode .eq. 42)then +C column data type is E (R*4) +C read the data and do any machine dependent data conversion + call ftgr4b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr4i4(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 82)then +C column data type is D (R*8) +C read the data and do any machine dependent data conversion + call ftgr8b(iunit,itodo,incre,buffer,status) +C check for null values, and do scaling and datatype conversion + call ftr8i4(buffer,itodo,scale,zero,tofits, + & nulchk,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 11)then +C column data type is B (byte) +C read the data and do any machine dependent data conversion + call ftgi1b(iunit,itodo,incre,chbuff,status) +C check for null values, and do scaling and datatype conversion + call fti1i4(chbuff,itodo,scale,zero,tofits, + & nulchk,i1null,nulval,flgval(i1),anynul,array(i1),status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column; get the character string + call ftgcbf(iunit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + if (status .gt. 0)return + +C check for null + if (sval(1:16) .eq. snull)then + anynul=.true. + if (nultyp .eq. 1)then + array(i1)=nulval + else + flgval(i1)=.true. + end if + go to 30 + end if +C now read the value, then do scaling and datatype conversion + if (sform(5:5) .eq. 'I')then + read(sval,sform,err=900)ival + call fti4i4(ival,itodo,scale,zero,tofits, + & 0,i4null,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5).eq.'F'.or. sform(5:5).eq.'E')then + read(sval,sform,err=900)rval + call ftr4i4(rval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else if (sform(5:5) .eq. 'D')then + read(sval,sform,err=900)dval + call ftr8i4(dval,itodo,scale,zero,tofits, + & 0,nulval,flgval(i1),anynul,array(i1),status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot read integer*4 values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLJ).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot read integer*4 values from column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTGCLJ).') + return + end if + +C find number of pixels left to do, and quit if none left +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading pixels'//cp1//' to'//cp2 + & // ' of the FITS image array (FTGCLJ).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while reading group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLJ.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLJ).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLJ).') + end if + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred reading '// + & 'Integer*4 data from FITS file.') + end if + return + +900 continue +C error reading formatted data value from ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error reading colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to read "'//sval(1:20)// + & '" with format '//sform//' (FTGCLJ).') + status=315 + end diff --git a/pkg/tbtables/fitsio/ftgclm.f b/pkg/tbtables/fitsio/ftgclm.f new file mode 100644 index 00000000..b299d10b --- /dev/null +++ b/pkg/tbtables/fitsio/ftgclm.f @@ -0,0 +1,239 @@ +C-------------------------------------------------------------------------- + subroutine ftgclm(iunit,colnum,frow,felem,nelem,eincr, + & nultyp,nulval,array,flgval,anynul,status) + +C read an array of double complex data values from the specified +C column of the table. +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. +C The binary table column being read to must have datatype 'M' +C and no datatype conversion will be perform if it is not. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within the row to read +C nelem i number of (pairs) elements to read +C eincr i element increment +C nultyp i input code indicating how to handle undefined values +C nulval d value that undefined pixels will be set to (if nultyp=1) +C array d array of data values that are read from the FITS file +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,eincr,nultyp,status + double precision array(*),nulval(2) + logical flgval(*),anynul + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bytpix,bstart,tcode,nulchk,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart + integer offset,rskip,dstart,begcol,lenrow,i,j + logical scaled,descrp + double precision scale,zero + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLM).') + return + end if + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLM).') + return + end if + + i1=1 + ntodo=nelem + estart=felem-1 + rstart=frow-1 + anynul=.false. + ibuff=bufnum(iunit) + dstart=dtstrt(ibuff) + lenrow=rowlen(ibuff) + begcol=tbcol(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + bytpix=16 + +C determine the repeat count and the first element position +C incre is the byte offset between consecutive pixels + incre=bytpix*eincr + + if (tcode .eq. 163)then + descrp=.false. + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLM).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C read multiple rows of data at one time by +C fooling it into thinking that this is a vector +C column with a large value of bytes per pixel + dstart=dstart+rstart*lenrow + rstart=0 + estart=0 + repeat=nelem*eincr + incre=lenrow*eincr + lenrow=lenrow*repeat + end if + else if (tcode .eq. -163)then +C this is a variable length descriptor column +C read the number of elements and the starting offset: + descrp=.true. + call ftgdes(iunit,colnum,frow,repeat,offset,status) + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if (estart+(nelem-1)*eincr+1 .gt. repeat) then +C error: trying to read beyond end of record + status=319 + return + end if +C define the starting point of the row + dstart=dstart+offset+theap(ibuff) + rstart=0 + begcol=0 + else +C column must be double complex data type + status=312 + write(ccol,2001)colnum + call ftpmsg('Column'//ccol//' does not have '// + & 'Double Precision Complex (M) data type (FTGCLM).') + return + end if + +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval(1) .eq. 0 .and. + & nulval(2) .eq. 0)then +C user doesn't want to check for nulls + nulchk=0 + else +C user does want to check for null values + nulchk=nultyp + end if + +C check if scaling is required + if (scale .eq. 1.0 .and. zero .eq. 0.)then + scaled=.false. + else + scaled=.true. + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,(repeat-estart-1)/eincr+1) + +C move the i/o pointer to the start of the sequence of pixels + bstart=dstart+rstart*lenrow+begcol+estart*bytpix + call ftmbyt(iunit,bstart,.false.,status) + +C read the data + if (incre .eq. 16)then +C the data values are contiguous in the FITS file +C multiply itodo*2 because we are getting pairs of values + call ftgr8b(iunit,itodo*2,8,array(i1),status) + else +C have to read each complex double pair one by one + j=i1 + call ftgr8b(iunit,2,8,array(j),status) + j=j+2 + do 25 i=2,itodo + call ftmoff(iunit,incre-16,.false.,status) + call ftgr8b(iunit,2,8,array(j),status) + j=j+2 +25 continue + end if + +C find number of pixels left to do, and process them +30 ntodo=ntodo-itodo + + if (status .gt. 0)then + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error reading elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTGCLM.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error reading rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTGCLM).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error reading'//cp2//' elements from' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTGCLM).') + end if + return + end if + + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo*2 + estart=estart+itodo*eincr + rskip=estart/repeat + rstart=rstart+rskip + estart=estart-rskip*repeat + go to 20 + end if + +C check for null values and/or scale the values + if (nulchk .ne. 0 .or. scaled)then + call ftnulm(array,nelem,nulchk,nulval,flgval,anynul, + & scaled,scale,zero) + end if + end diff --git a/pkg/tbtables/fitsio/ftgcls.f b/pkg/tbtables/fitsio/ftgcls.f new file mode 100644 index 00000000..6457726e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcls.f @@ -0,0 +1,207 @@ +C---------------------------------------------------------------------- + subroutine ftgcls(iunit,colnum,frow,felem,nelem,nultyp,nulval, + & sray,flgval,anynul,status) + +C read an array of character string values from the specified column of +C the table. +C The binary or ASCII table column being read must have datatype 'A' +C This general purpose routine will handle null values in one +C of two ways: if nultyp=1, then undefined array elements will be +C set equal to the input value of NULVAL. Else if nultyp=2, then +C undefined array elements will have the corresponding FLGVAL element +C set equal to .TRUE. If NULTYP=1 and NULVAL=0, then no checks for +C undefined values will be made, for maximum efficiency. + +C iunit i fortran unit number +C colnum i number of the column to read from +C frow i first row to read +C felem i first element within row to read +C nelem i number of elements to read +C nultyp i input code indicating how to handle undefined values +C nulval c value that undefined pixels will be set to (if nultyp=1) +C sray c array of data values to be read +C flgval l set .true. if corresponding element undefined (if nultyp=2) +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,nultyp,status + logical flgval(*),anynul + character*(*) sray(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,nulchk,twidth,tread,tcode,offset,repeat + integer ibuff,i1,ntodo,rstart,estart,lennul,strlen,nulfil + character snull*16, crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table read '// + & 'request is out of range:'//crow//' (FTGCLS).') + return + else if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLS).') + return + end if + + anynul=.false. + ibuff=bufnum(iunit) + i1=1 + +C column must be character string data type + + tcode=tdtype(colnum+tstart(ibuff)) + if (tcode .eq. 16)then +C for ASCII columns, TNULL actually stores the field width + twidth=tnull(colnum+tstart(ibuff)) + ntodo=nelem + rstart=frow-1 + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for read '// + & 'request is out of range:'//crow//' (FTGCLS).') + return + end if + estart=felem-1 + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*twidth + else if (tcode .eq. -16)then +C this is a variable length descriptor field + ntodo=1 +C read the string length and the starting offset: + call ftgdes(iunit,colnum,frow,twidth,offset,status) +C calc the i/o pointer position for the start of the string + bstart=dtstrt(ibuff)+offset+theap(ibuff) + else +C error: not a character string column + status=309 + call ftpmsg('Cannot to read character string'// + & ' from a non-character column of a table (FTGCLS).') + return + end if + +C define the max. number of charcters to be read: either +C the length of the variable length field, or the length +C of the character string variable, which ever is smaller + strlen=len(sray(1)) + tread=min(twidth,strlen) + +C move the i/o pointer to the start of the sequence of pixels + call ftmbyt(iunit,bstart,.false.,status) + + if (status .gt. 0)then + call ftpmsg('Failed to move to starting position '// + & 'to read character string(s) (FTGCLS).') + return + end if + + lennul=0 +C determine if we have to check for null values + if (nultyp .eq. 1 .and. nulval .eq. ' ')then +C user doesn't want to check for nulls + nulchk=0 + else + nulchk=nultyp + snull=cnull(colnum+tstart(ibuff)) +C lennul = length of the string to check for null values + lennul=min(len(sray(1)),8) + end if + +C process one string at a time +20 continue +C get the string of characters + sray(i1)=' ' + call ftgcbf(iunit,1,tread,sray(i1),status) + if (status .gt. 0)return + +C check for null value, if required + if (nulchk .ne. 0)then + if (ichar(sray(i1)(1:1)) .eq. 0 .or. + & sray(i1)(1:lennul) .eq. snull(1:lennul))then + if (nulchk .eq. 1)then + sray(i1)=nulval + anynul=.true. + else + flgval(i1)=.true. + anynul=.true. + end if + end if + end if + +C check for null terminated string; pad out with blanks if found + nulfil=index(sray(i1),char(0)) + if (nulfil .gt. 1)then + sray(i1)(nulfil:len(sray(1)))=' ' + end if + + if (status .gt. 0)then + write(cp1,2000)i1 + write(ccol,2001)colnum +2001 format(i4) + write(cp1,2000)rstart+1 + write(cp2,2000)estart+1 + if (felem .eq. 1)then + call ftpmsg('Error while reading ASCII string from '// + & 'column'//ccol//', row'//cp1//' (FTGCLS).') + else + call ftpmsg('Error reading string from '// + & 'column'//ccol//', row'//cp1 + & //', element'//cp2//' (FTGCLS).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-1 + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+1 + estart=estart+1 + if (estart .eq. repeat)then + rstart=rstart+1 + estart=0 + end if +C move to the start of the next string; need to do +C this every time in case we didn't read all the characters +C from the previous string. + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*twidth +C move the i/o pointer + call ftmbyt(iunit,bstart,.false.,status) + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftgcnn.f b/pkg/tbtables/fitsio/ftgcnn.f new file mode 100644 index 00000000..d8348147 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcnn.f @@ -0,0 +1,140 @@ +C-------------------------------------------------------------------------- + subroutine ftgcnn(iunit,casesn,templt,colnam,colnum,status) + +C determine the column name and number corresponding to an input +C column name template string. The template may contain the * and ? +C wildcards. Status = 237 is returned if match is not unique. +C One may call this routine again with input status=237 to +C get the next match. + +C iunit i Fortran i/o unit number +C casesn l true if an exact case match of the names is required +C templt c templt for column name +C colnam c name of (first) column that matchs the template +C colnum i number of the column (first column = 1) +C (a value of 0 is returned if the column is not found) +C status i returned error status + +C written by Wm Pence, HEASARC/GSFC, December 1994 + + integer iunit,colnum,status + character*(*) templt,colnam + logical casesn + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + integer colpnt,untpnt + common/ftname/colpnt,untpnt +C END OF COMMON BLOCK DEFINITIONS------------------------------------ + + integer ibuff,i,nfound,tstat,ival + logical match,exact,founde,foundw,unique + character*80 errmsg + character*68 tname(999) + save tname + + ibuff=bufnum(iunit) + +C load the common block with names, if not already defined + if (colpnt .eq. -999 .or. iunit .ne. untpnt)then + do 10 i=1,tfield(ibuff) + tname(i)=' ' +10 continue + call ftgkns(iunit,'TTYPE',1,nf,tname,nfound,status) + if (status .gt. 0)return + untpnt=iunit + colpnt=1 + end if + + if (status .le. 0)then + tstat=0 + colpnt=1 + else if (status .eq. 237)then +C search for next non-unique match, starting from the previous match + tstat=237 + status=0 + else + return + end if + + colnam=' ' + colnum=0 + + +C set the 'found exact' and 'found wildcard' flags to false + founde=.false. + foundw=.false. + + do 100 i=colpnt,tfield(ibuff) +C test for match between template and column name + call ftcmps(templt,tname(i),casesn,match,exact) + + if (match)then + if (founde .and. exact)then +C warning: this is the second exact match we've found +C reset pointer to first match so next search starts there + colpnt=colnum+1 + status=237 + return + else if (founde)then +C already found exact match so ignore this non-exact match + else if (exact)then +C this is the first exact match we have found, so save it. + colnam=tname(i) + colnum=i + founde=.true. + else if (foundw)then +C we have already found a wild card match, so not unique +C continue searching for other matches + unique=.false. + else +C this is the first wild card match we've found. save it + colnam=tname(i) + colnum=i + foundw=.true. + unique=.true. + end if + end if +100 continue + +C OK, we've checked all the names now see if we got any matches + if (founde)then +C we did find 1 exact match + if (tstat .eq. 237)status=237 + else if (foundw)then +C we found one or more wildcard matches +C report error if not unique + if (.not. unique .or. tstat .eq. 237)status=237 + else +C didn't find a match; check if template is a simple positive integer + call ftc2ii(templt,ival,tstat) + if (tstat .eq. 0 .and. ival .le. tfield(ibuff) + & .and. ival .gt. 0)then + colnum=ival + colnam=tname(ival) + else + status=219 + if (tstat .ne. 237)then + errmsg='FTGCNN: Could not find column: '//templt + call ftpmsg(errmsg) + end if + end if + end if + +C reset pointer so next search starts here if input status=237 + colpnt=colnum+1 + end diff --git a/pkg/tbtables/fitsio/ftgcno.f b/pkg/tbtables/fitsio/ftgcno.f new file mode 100644 index 00000000..d5c9ca03 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcno.f @@ -0,0 +1,22 @@ +C-------------------------------------------------------------------------- + subroutine ftgcno(iunit,casesn,templt,colnum,status) + +C determine the column number corresponding to an input column name. +C This supports the * and ? wild cards in the input template. + +C iunit i Fortran i/o unit number +C casesn l true if an exact case match of the names is required +C templt c name of column as specified in a TTYPE keyword +C colnum i number of the column (first column = 1) +C (a value of 0 is returned if the column is not found) +C status i returned error status + +C modified by Wm Pence, HEASARC/GSFC, December 1994 + + integer iunit,colnum,status + character*(*) templt + logical casesn + character*8 dummy + + call ftgcnn(iunit,casesn,templt,dummy,colnum,status) + end diff --git a/pkg/tbtables/fitsio/ftgcrd.f b/pkg/tbtables/fitsio/ftgcrd.f new file mode 100644 index 00000000..7332a066 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcrd.f @@ -0,0 +1,76 @@ +C-------------------------------------------------------------------------- + subroutine ftgcrd(iunit,keynam,card,status) + +C Read the 80 character card image of a specified header keyword record + +C iunit i Fortran I/O unit number +C keynam c name of keyword to be read +C OUTPUT PARAMETERS: +C card c 80 character card image that was read +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + character*(*) keynam + integer iunit,status,i,j,ibuff,maxkey,start + character*(*) card + character kname*8 + character*80 keybuf + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + card=' ' + if (status .gt. 0)go to 100 + +C get the number of the data buffer used for this unit + ibuff=bufnum(iunit) + +C make sure keyword name is in uppercase + kname=keynam + call ftupch(kname) + +C Start by searching for keyword from current pointer position to the end. +C Calculate the maximum number of keywords to be searched: + start=nxthdr(ibuff) + maxkey=(hdend(ibuff)-start)/80 + + do 20 j=1,2 +C position I/O pointer to the next header keyword + if (maxkey .gt. 0)then + call ftmbyt(iunit,start,.false.,status) + end if + + do 10 i=1,maxkey + call ftgcbf(iunit,1,80,keybuf,status) + if (status .gt. 0)go to 100 + if (keybuf(1:8) .eq. kname)then +C setheader pointer to the following keyword + nxthdr(ibuff)=start+i*80 + card=keybuf + return + end if +10 continue + +C didn't find keyword yet, so now search from top down to starting pt. +C calculate max number of keywords to be searched and reset nxthdr + maxkey=(start-hdstrt(ibuff,chdu(ibuff)))/80 + start=hdstrt(ibuff,chdu(ibuff)) +20 continue + +C keyword was not found + status=202 + +C don't write to error stack because this innoculous error happens a lot +C call ftpmsg('Could not find the '//kname//' keyword to read.') + +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgcvb.f b/pkg/tbtables/fitsio/ftgcvb.f new file mode 100644 index 00000000..2376861a --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvb.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftgcvb(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of byte values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval b value that undefined pixels will be set to +C array b returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + + character*1 array(*),nulval + + call ftgclb(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvc.f b/pkg/tbtables/fitsio/ftgcvc.f new file mode 100644 index 00000000..de0a3e97 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvc.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftgcvc(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of complex values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval cmp value that undefined pixels will be set to +C array cmp returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + real array(*),nulval(2) + + call ftgclc(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvd.f b/pkg/tbtables/fitsio/ftgcvd.f new file mode 100644 index 00000000..0c90d404 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvd.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftgcvd(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of r*8 values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval d value that undefined pixels will be set to +C array d returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + double precision array(*),nulval + + call ftgcld(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + + end diff --git a/pkg/tbtables/fitsio/ftgcve.f b/pkg/tbtables/fitsio/ftgcve.f new file mode 100644 index 00000000..694cf8e0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcve.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftgcve(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of R*4 values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval r value that undefined pixels will be set to +C array r returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + real array(*),nulval + + call ftgcle(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvi.f b/pkg/tbtables/fitsio/ftgcvi.f new file mode 100644 index 00000000..2e032552 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvi.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftgcvi(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of I*2 values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval i*2 value that undefined pixels will be set to +C array i*2 returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + integer*2 array(*),nulval + + call ftgcli(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvj.f b/pkg/tbtables/fitsio/ftgcvj.f new file mode 100644 index 00000000..de6340cc --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvj.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftgcvj(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of I*4 values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval i value that undefined pixels will be set to +C array i returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + integer array(*),nulval + + call ftgclj(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvm.f b/pkg/tbtables/fitsio/ftgcvm.f new file mode 100644 index 00000000..c719850d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvm.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftgcvm(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of double precision complex values from a specified +C column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=0, in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element within the row to read +C nelem i number of elements to read +C nulval dcmp value that undefined pixels will be set to +C array dcmp returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + double precision array(*),nulval(2) + + call ftgclm(iunit,colnum,frow,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcvs.f b/pkg/tbtables/fitsio/ftgcvs.f new file mode 100644 index 00000000..dbd92809 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcvs.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftgcvs(iunit,colnum,frow,felem,nelem,nulval,array, + & anynul,status) + +C read an array of string values from a specified column of the table. +C Any undefined pixels will be set equal to the value of NULVAL, +C unless NULVAL=' ', in which case no checks for undefined pixels +C will be made. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C felem i first element in the row to read +C nelem i number of elements to read +C nulval c value that undefined pixels will be set to +C array c returned array of data values that was read from FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,colnum,frow,felem,nelem,status + logical flgval,anynul + character*(*) array(*),nulval + + call ftgcls(iunit,colnum,frow,felem,nelem,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgcx.f b/pkg/tbtables/fitsio/ftgcx.f new file mode 100644 index 00000000..b4d9c65f --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcx.f @@ -0,0 +1,140 @@ +C---------------------------------------------------------------------- + subroutine ftgcx(iunit,colnum,frow,fbit,nbit,lray,status) + +C read an array of logical values from a specified bit or byte +C column of the binary table. A logical .true. value is returned +C if the corresponding bit is 1, and a logical .false. value is +C returned if the bit is 0. +C The binary table column being read from must have datatype 'B' +C or 'X'. This routine ignores any undefined values in the 'B' array. + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C fbit i first bit within the row to read +C nbit i number of bits to read +C lray l returned array of logical data values that is read +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Mar 1992 + + integer iunit,colnum,frow,fbit,nbit,status + logical lray(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,offset,tcode,fbyte,bitloc,ndone + integer ibuff,i,ntodo,repeat,rstart,estart,buffer + logical descrp,log8(8) + character*1 cbuff + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + tcode=tdtype(colnum+tstart(ibuff)) + +C check input parameters + if (nbit .le. 0)then + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + return + else if (fbit .lt. 1)then +C illegal element number + status=308 + return + end if + + fbyte=(fbit+7)/8 + bitloc=fbit-(fbit-1)/8*8 + ndone=0 + ntodo=nbit + rstart=frow-1 + estart=fbyte-1 + + if (tcode .eq. 11)then + repeat=trept(colnum+tstart(ibuff)) + if (fbyte .gt. repeat)then +C illegal element number + status=308 + return + end if + descrp=.false. +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + else if (tcode .eq. -11)then +C this is a variable length descriptor column + descrp=.true. +C read the number of elements and the starting offset: + call ftgdes(iunit,colnum,frow,repeat, + & offset,status) + repeat=(repeat+7)/8 + if (repeat .eq. 0)then +C error: null length vector + status=318 + return + else if ((fbit+nbit+6)/8 .gt. repeat)then +C error: trying to read beyond end of record + status=319 + return + end if + bstart=dtstrt(ibuff)+offset+ + & theap(ibuff)+estart + else +C column must be byte or bit data type + status=312 + return + end if + +C move the i/o pointer to the start of the pixel sequence + call ftmbyt(iunit,bstart,.false.,status) + +C get the next byte +20 call ftgcbf(iunit,0,1,cbuff,status) + buffer=ichar(cbuff) + if (buffer .lt. 0)buffer=buffer+256 + +C decode the bits within the byte into an array of logical values + call ftgbit(buffer,log8) + + do 10 i=bitloc,8 + ndone=ndone+1 + lray(ndone)=log8(i) + if (ndone .eq. ntodo)go to 100 +10 continue + +C not done, so get the next byte + if (.not. descrp)then + estart=estart+1 + if (estart .eq. repeat)then +C move the i/o pointer to the next row of pixels + estart=0 + rstart=rstart+1 + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + call ftmbyt(iunit,bstart,.false.,status) + end if + end if + bitloc=1 + go to 20 + +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgcxd.f b/pkg/tbtables/fitsio/ftgcxd.f new file mode 100644 index 00000000..9befb70d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcxd.f @@ -0,0 +1,78 @@ +C---------------------------------------------------------------------- + subroutine ftgcxd(iunit,colnum,frow,nrow,fbit,nbit, + & dvalue,status) + +C read any consecutive bits from an 'X' or 'B' column as an unsigned +C n-bit integer + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C nrow i number of rows to read +C fbit i first bit within the row to read +C nbit i number of bits to read +C dvalue d returned value(s) +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Nov 1994 + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer iunit,colnum,fbit,nbit,frow,nrow,status + integer i,k,istart,itodo,ntodo,row,ibuff + double precision dvalue(*),power,dval + logical lray(64) + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then + call ftpmsg('Asked to read more bits than exist in'// + & ' the column (ftgcxd)') + status=308 + return + end if + + row=frow-1 + do 30 k=1,nrow + row=row+1 + dval=0. + power=1.0D+00 + istart=fbit+nbit + ntodo=nbit + +10 itodo=min(ntodo,64) + istart=istart-itodo + +C read up to 64 bits at a time +C get the individual bits + call ftgcx(iunit,colnum,row,istart,itodo,lray,status) + if (status .gt. 0)return + +C reconstruct the positive integer value + do 20 i=itodo,1,-1 + if (lray(i))dval=dval+power + power=power*2.0D+00 +20 continue + + ntodo=ntodo-itodo + if (itodo .gt. 0)go to 10 + dvalue(k)=dval +30 continue + end diff --git a/pkg/tbtables/fitsio/ftgcxi.f b/pkg/tbtables/fitsio/ftgcxi.f new file mode 100644 index 00000000..d545a372 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcxi.f @@ -0,0 +1,86 @@ +C---------------------------------------------------------------------- + subroutine ftgcxi(iunit,colnum,frow,nrow,fbit,nbit, + & ivalue,status) + +C read any consecutive bits from an 'X' or 'B' column as an unsigned +C n-bit integer, unless nbits=16 in which case the 16 bits +C are interpreted as a 16-bit signed 2s complement word + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C nrow i number of rows to read +C fbit i first bit within the row to read +C nbit i number of bits to read +C ivalue i*2 returned integer value(s) +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Nov 1994 + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,ibuff + integer*2 ivalue(*),ival,power2(16) + logical lray(16) + save power2 + data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192, + & 16384,0/ + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + + if (nbit .gt. 16)then + call ftpmsg('Cannot read more than 16 bits (ftgcxi)') + status=308 + return + else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then + call ftpmsg('Asked to read more bits than exist in'// + & ' the column (ftgcxi)') + status=308 + return + end if + + + row=frow-1 + do 30 k=1,nrow + row=row+1 +C get the individual bits + call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) + if (status .gt. 0)return + ival=0 + j=0 + if (nbit .eq. 16 .and. lray(1))then +C interprete this as a 16 bit negative integer + do 10 i=16,2,-1 + j=j+1 + if (.not. lray(i))ival=ival+power2(j) +10 continue +C make 2's complement + ivalue(k)=-ival-1 + else +C reconstruct the positive integer value + do 20 i=nbit,1,-1 + j=j+1 + if (lray(i))ival=ival+power2(j) +20 continue + ivalue(k)=ival + end if +30 continue + end diff --git a/pkg/tbtables/fitsio/ftgcxj.f b/pkg/tbtables/fitsio/ftgcxj.f new file mode 100644 index 00000000..6e2c7ad8 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgcxj.f @@ -0,0 +1,88 @@ +C---------------------------------------------------------------------- + subroutine ftgcxj(iunit,colnum,frow,nrow,fbit,nbit, + & jvalue,status) + +C read any consecutive bits from an 'X' or 'B' column as an unsigned +C n-bit integer, unless nbits=32 in which case the 32 bits +C are interpreted as a 32-bit signed 2s complement word + +C iunit i fortran unit number +C colnum i number of the column to read +C frow i first row to read +C nrow i number of rows to read +C fbit i first bit within the row to read +C nbit i number of bits to read +C jvalue i returned integer value(s) +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Nov 1994 + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer iunit,colnum,fbit,nbit,frow,nrow,status,i,j,k,row,jval + integer jvalue(*),power2(32),ibuff + logical lray(32) + save power2 + data power2/1,2,4,8,16,32,64,128,256,512,1024,2048,4096,8192, + & 16384,32768,65536,131072,262144,524288,1048576,2097152,4194304, + & 8388608,16777216,33554432,67108864,134217728,268435456,536870912 + & ,1073741824,0/ + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + + if (nbit .gt. 32)then + call ftpmsg('Cannot read more than 32 bits (ftgcxj)') + status=308 + return + else if ((fbit+nbit+6)/8 .gt. trept(colnum+tstart(ibuff)))then + call ftpmsg('Asked to read more bits than exist in'// + & ' the column (ftgcxj)') + status=308 + return + end if + + row=frow-1 + do 30 k=1,nrow + row=row+1 +C get the individual bits + call ftgcx(iunit,colnum,row,fbit,nbit,lray,status) + if (status .gt. 0)return + + jval=0 + j=0 + if (nbit .eq. 32 .and. lray(1))then +C interprete this as a 32 bit negative integer + do 10 i=32,2,-1 + j=j+1 + if (.not. lray(i))jval=jval+power2(j) +10 continue +C make 2's complement + jvalue(k)=-jval-1 + else +C reconstruct the positive integer value + do 20 i=nbit,1,-1 + j=j+1 + if (lray(i))jval=jval+power2(j) +20 continue + jvalue(k)=jval + end if +30 continue + end diff --git a/pkg/tbtables/fitsio/ftgdes.f b/pkg/tbtables/fitsio/ftgdes.f new file mode 100644 index 00000000..6cf28f12 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgdes.f @@ -0,0 +1,63 @@ +C---------------------------------------------------------------------- + subroutine ftgdes(iunit,colnum,rownum,nelem,offset,status) + +C read the descriptor values from a binary table. This is only +C used for column which have TFORMn = 'P', i.e., for variable +C length arrays. + +C iunit i fortran unit number +C colnum i number of the column to read +C rownum i number of the row to read +C nelem i output number of elements +C offset i output byte offset of the first element +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Nov 1991 + + integer iunit,colnum,rownum,nelem,offset,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart,iray(2) + + if (status .gt. 0)return + if (rownum .lt. 1)then +C error: illegal row number + status=307 + return + end if + + ibuff=bufnum(iunit) + +C check that this is really a 'P' type column + if (tdtype(colnum+tstart(ibuff)) .ge. 0)then + status=317 + return + end if + +C move to the specified column and row: + bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff)) + call ftmbyt(iunit,bstart,.true.,status) + +C now read the number of elements and the offset to the table: + call ftgi4b(iunit,2,0,iray,status) + nelem=iray(1) + offset=iray(2) + end diff --git a/pkg/tbtables/fitsio/ftgerr.f b/pkg/tbtables/fitsio/ftgerr.f new file mode 100644 index 00000000..2e15a772 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgerr.f @@ -0,0 +1,173 @@ +C------------------------------------------------------------------------------ + subroutine ftgerr(errnum,text) + +C Return a descriptive error message corresponding to the error number + +C errnum i input symbolic error code presumably returned by another +C FITSIO subroutine +C text C*30 Descriptive error message + + integer errnum + character*(*) text + +C nerror specifies the maxinum number of different error messages + integer nerror + parameter (nerror=100) + character*30 errors(nerror) + character*30 er1(10),er2(10),er3(10),er4(10),er5(10),er6(10) + character*30 er7(10),er8(10),er9(10),er10(10) + integer i,errcod(nerror) + save errors + +C we equivalence the big array to several smaller ones, so that +C the DATA statements will not have too many continuation lines. + equivalence (errors(1), er1(1)) + equivalence (errors(11),er2(1)) + equivalence (errors(21),er3(1)) + equivalence (errors(31),er4(1)) + equivalence (errors(41),er5(1)) + equivalence (errors(51),er6(1)) + equivalence (errors(61),er7(1)) + equivalence (errors(71),er8(1)) + equivalence (errors(81),er9(1)) + equivalence (errors(91),er10(1)) + + data errcod/0,101,102,103,104,105,106,107,108,109,110,111, + & 201,202,203,204,205,206,207,208,209,211,212,213,214,215,216, + & 217,218,221,222,223,224,225,226,227,228,229,230,231,232, + & 241,251,252,261,262, + & 302,303,304,305,306,307,308,309,310,311,312,313,314,315,316, + & 317,318,319, 401,402,403,404,405,406,407,408,409,411,112, + & 210,233,220,219,301,320,321,322,263,323,113,114,234,253,254, + & 255,412,235,236,501,502,503,504,505,237/ + + data er1/ + & 'OK, no error', + & 'Bad logical unit number', + & 'Too many FITS files opened', + & 'File not found; not opened', + & 'Error opening existing file', + & 'Error creating new FITS file', + & 'Error writing to FITS file', + & 'EOF while reading FITS file', + & 'Error reading FITS file', + & 'Bad blocking factor (1-28800)'/ + + data er2/ + & 'Error closing FITS file', + & 'Too many columns in table', + & 'No room in header for keyword', + & 'Specified keyword not found', + & 'Bad keyword record number', + & 'Keyword value field is blank', + & 'Missing quote in string value', + & 'Could not construct NAMEnnn', + & 'Bad character in header record', + & 'Keywords out of order?'/ + + data er3/ + & 'Bad nnn value in NAMEnnn', + & 'Illegal BITPIX keyword value', + & 'Illegal NAXIS keyword value', + & 'Illegal NAXISnnn keyword value', + & 'Illegal PCOUNT keyword value', + & 'Illegal GCOUNT keyword value', + & 'Illegal TFIELDS keyword value', + & 'Illegal NAXIS1 keyword value', + & 'Illegal NAXIS2 keyword value', + & 'SIMPLE keyword not found'/ + + data er4/ + & 'BITPIX keyword not found', + & 'NAXIS keyword not found', + & 'NAXISnnn keyword(s) not found', + & 'XTENSION keyword not found', + & 'CHDU is not an ASCII table', + & 'CHDU is not a binary table', + & 'PCOUNT keyword not found', + & 'GCOUNT keyword not found', + & 'TFIELDS keyword not found', + & 'TBCOLnnn keywords not found'/ + + data er5/ + & 'TFORMnnn keywords not found', + & 'Row width not = field widths', + & 'Unknown extension type', + & 'Unknown FITS record type', + & 'Cannot parse TFORM keyword', + & 'Unknown TFORM datatype code', + & 'Column number out of range', + & 'Data structure not defined', + & 'Negative file record number', + & 'HDU start location is unknown'/ + + data er6/ + & 'Requested no. of bytes < 0', + & 'Illegal first row number', + & 'Illegal first element number', + & 'Bad TFORM for Character I/O', + & 'Bad TFORM for Logical I/O', + & 'Invalid ASCII table TFORM code', + & 'Invalid BINTABLE TFORM code', + & 'Error making formated string', + & 'Null value is undefined', + & 'Internal read error of string'/ + + data er7/ + & 'Illegal logical column value', + & 'Bad TFORM for descriptor I/O', + & 'Variable array has 0 length', + & 'End-of-rec in var. len. array', + & 'Int to Char conversion error', + & 'Real to Char conversion error', + & 'Illegal Char to Int conversion', + & 'Illegal Logical keyword value', + & 'Illegal Char to R*4 conversion', + & 'Illegal Char to R*8 conversion'/ + + data er8/ + & 'Char to Int conversion error', + & 'Char to Real conversion error', + & 'Char to R*8 conversion error', + & 'Illegal no. of decimal places', + & 'Cannot modify a READONLY file', + & 'END header keyword not found', + & 'CHDU is not an IMAGE extension', + & 'Illegal SIMPLE keyword value', + & 'Column name (TTYPE) not found', + & 'Out of bounds HDU number'/ + + data er9/ + & 'Bad no. of array dimensions', + & 'Max pixel less than min pixel', + & 'Illegal BSCALE or TSCALn = 0', + & 'Could not parse TDIMn keyword', + & 'Axis length less than 1', + & 'Incompatible FITSIO version', + & 'All LUNs have been allocated', + & 'TBCOLn value out of range', + & 'END keyword value not blank ', + & 'Header fill area not blank'/ + + data er10/ + & 'Data fill area invalid', + & 'Data type conversion overflow', + & 'CHDU must be a table/bintable', + & 'Column is too wide for table', + & 'celestial angle too large', + & 'bad celestial coordinate', + & 'error in celestial coord calc', + & 'unsupported projection', + & 'missing celestial coord keywrd', + & 'column name not unique'/ + +C find the matching error code number + do 10 i=1,nerror + if (errnum .eq. errcod(i))then + text=errors(i) + return + end if +10 continue + + text='Unknown FITSIO status code' + end diff --git a/pkg/tbtables/fitsio/ftgext.f b/pkg/tbtables/fitsio/ftgext.f new file mode 100644 index 00000000..66094d2f --- /dev/null +++ b/pkg/tbtables/fitsio/ftgext.f @@ -0,0 +1,62 @@ +C---------------------------------------------------------------------- + subroutine ftgext(iunit,extno,xtend,status) + +C 'Get Extension' +C move i/o pointer to another extension (or the primary HDU) and +C initialize all the common block parameters which describe the +C extension + +C iunit i fortran unit number +C extno i number of the extension to point to. +C xtend i type of extension: 0 = the primary HDU +C 1 = an ASCII table +C 2 = a binary table +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,extno,xtend,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,xchdu,xhdend,xmaxhd + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C move to the beginning of the desired extension + call ftmbyt(iunit,hdstrt(ibuff,extno),.false.,status) + if (status .le. 0)then + +C temporarily save parameters + xchdu=chdu(ibuff) + xmaxhd=maxhdu(ibuff) + xhdend=hdend(ibuff) + +C initialize various parameters about the CHDU + chdu(ibuff)=extno + maxhdu(ibuff)=max(extno,maxhdu(ibuff)) +C the location of the END record is currently unknown, so +C temporarily just set it to a very large number + hdend(ibuff)=2000000000 + +C determine the structure of the CHDU + call ftrhdu(iunit,xtend,status) + if (status .gt. 0)then +C couldn't read the extension so restore previous state + chdu(ibuff)= xchdu + maxhdu(ibuff)=xmaxhd + hdend(ibuff)= xhdend + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftggpb.f b/pkg/tbtables/fitsio/ftggpb.f new file mode 100644 index 00000000..a3fc10b1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftggpb.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftggpb(iunit,group,fparm,nparm,array,status) + +C Read an array of group parameter values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran unit number +C group i number of the data group, if any +C fparm i the first group parameter be read (starting with 1) +C nparm i number of group parameters to be read +C array b returned array of values that were read +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,fparm,nparm,status,row + character*1 nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself +C set nulval to blank to inhibit checking for undefined values + nulval=' ' + row=max(1,group) + call ftgclb(iunit,1,row,fparm,nparm,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftggpd.f b/pkg/tbtables/fitsio/ftggpd.f new file mode 100644 index 00000000..6857de98 --- /dev/null +++ b/pkg/tbtables/fitsio/ftggpd.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftggpd(iunit,group,fparm,nparm,array,status) + +C Read an array of group parameter values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran unit number +C group i number of the data group, if any +C fparm i the first group parameter be read (starting with 1) +C nparm i number of group parameters to be read +C array d returned array of values that were read +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,fparm,nparm,status,row + double precision nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself +C set nulval to blank to inhibit checking for undefined values + nulval=0 + row=max(1,group) + call ftgcld(iunit,1,row,fparm,nparm,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftggpe.f b/pkg/tbtables/fitsio/ftggpe.f new file mode 100644 index 00000000..db0e0656 --- /dev/null +++ b/pkg/tbtables/fitsio/ftggpe.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftggpe(iunit,group,fparm,nparm,array,status) + +C Read an array of group parameter values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran unit number +C group i number of the data group, if any +C fparm i the first group parameter be read (starting with 1) +C nparm i number of group parameters to be read +C array r returned array of values that were read +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,fparm,nparm,status,row + real nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself +C set nulval to blank to inhibit checking for undefined values + nulval=0 + row=max(1,group) + call ftgcle(iunit,1,row,fparm,nparm,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftggpi.f b/pkg/tbtables/fitsio/ftggpi.f new file mode 100644 index 00000000..7035b6d9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftggpi.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftggpi(iunit,group,fparm,nparm,array,status) + +C Read an array of group parameter values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran unit number +C group i number of the data group, if any +C fparm i the first group parameter be read (starting with 1) +C nparm i number of group parameters to be read +C array i*2 returned array of values that were read +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,fparm,nparm,status,row + integer*2 nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself +C set nulval to blank to inhibit checking for undefined values + nulval=0 + row=max(1,group) + call ftgcli(iunit,1,row,fparm,nparm,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftggpj.f b/pkg/tbtables/fitsio/ftggpj.f new file mode 100644 index 00000000..ce00a051 --- /dev/null +++ b/pkg/tbtables/fitsio/ftggpj.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftggpj(iunit,group,fparm,nparm,array,status) + +C Read an array of group parameter values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran unit number +C group i number of the data group, if any +C fparm i the first group parameter be read (starting with 1) +C nparm i number of group parameters to be read +C array i returned array of values that were read +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,fparm,nparm,status,row + integer nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself +C set nulval to blank to inhibit checking for undefined values + nulval=0 + row=max(1,group) + call ftgclj(iunit,1,row,fparm,nparm,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftghad.f b/pkg/tbtables/fitsio/ftghad.f new file mode 100644 index 00000000..5c64d01a --- /dev/null +++ b/pkg/tbtables/fitsio/ftghad.f @@ -0,0 +1,30 @@ +C---------------------------------------------------------------------- + subroutine ftghad(iunit,curhdu,nxthdu) + +C return the starting byte address of the CHDU and the next HDU. + +C curhdu i starting address of the CHDU +C nxthdu i starting address of the next HDU + +C written by Wm Pence, HEASARC/GSFC, May, 1995 + + integer iunit,curhdu,nxthdu + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,hdunum + + ibuff=bufnum(iunit) + hdunum=chdu(ibuff) + curhdu=hdstrt(ibuff,hdunum) + nxthdu=hdstrt(ibuff,hdunum+1) + end diff --git a/pkg/tbtables/fitsio/ftghbn.f b/pkg/tbtables/fitsio/ftghbn.f new file mode 100644 index 00000000..782a51f4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftghbn.f @@ -0,0 +1,59 @@ +C---------------------------------------------------------------------- + subroutine ftghbn(iunit,maxfld,nrows,nfield,ttype,tform, + & tunit,extnam,pcount,status) + +C read required standard header keywords from a binary table extension +C +C iunit i Fortran i/o unit number +C maxfld i maximum no. of fields to read; size of ttype array +C OUTPUT PARAMETERS: +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) +C tform c format of each field (array) +C tunit c units of each field (array) +C extnam c name of table (optional) +C pcount i size of special data area following the table (usually = 0) +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,maxfld,ncols,nrows,nfield,pcount,status,tstat + integer maxf,i,nfind + character*(*) ttype(*),tform(*),tunit(*),extnam + character comm*72 + +C check that this is a valid binary table and get parameters + call ftgtbn(iunit,ncols,nrows,pcount,nfield,status) + if (status .gt. 0)return + + if (maxfld .lt. 0)then + maxf=nfield + else if (maxfld .eq. 0)then + go to 20 + else + maxf=min(maxfld,nfield) + end if +C initialize optional keywords + do 10 i=1,maxf + ttype(i)=' ' + tunit(i)=' ' +10 continue + + call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status) + call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status) + + if (status .gt. 0)return + + call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status) + if (status .gt. 0 .or. nfind .ne. maxf)then + status=232 + return + end if + +20 extnam=' ' + tstat=status + call ftgkys(iunit,'EXTNAME',extnam,comm,status) +C this keyword is not required, so ignore status + if (status .eq. 202)status =tstat + end diff --git a/pkg/tbtables/fitsio/ftghdn.f b/pkg/tbtables/fitsio/ftghdn.f new file mode 100644 index 00000000..a93a4588 --- /dev/null +++ b/pkg/tbtables/fitsio/ftghdn.f @@ -0,0 +1,26 @@ +C---------------------------------------------------------------------- + subroutine ftghdn(iunit,hdunum) + +C return the number of the current header data unit. The +C first HDU (the primary array) is number 1. + +C iunit i fortran unit number +C hdunum i returned number of the current HDU +C +C written by Wm Pence, HEASARC/GSFC, March, 1993 + + integer iunit,hdunum + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + hdunum=chdu(bufnum(iunit)) + end diff --git a/pkg/tbtables/fitsio/ftghpr.f b/pkg/tbtables/fitsio/ftghpr.f new file mode 100644 index 00000000..e0360a19 --- /dev/null +++ b/pkg/tbtables/fitsio/ftghpr.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftghpr(iunit,maxdim,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + +C get the required primary header or image extension keywords +C +C iunit i fortran unit number to use for reading +C maxdim i maximum no. of dimensions to read; dimension of naxes +C OUTPUT PARAMETERS: +C simple l does file conform to FITS standard? +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C pcount i number of group parameters (usually 0) +C gcount i number of random groups (usually 1 or 0) +C extend l may extensions be present in the FITS file? +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status + integer maxdim,nblank + logical simple,extend + double precision fill + + call ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,fill,fill,blank,nblank,status) + end diff --git a/pkg/tbtables/fitsio/ftghps.f b/pkg/tbtables/fitsio/ftghps.f new file mode 100644 index 00000000..6d92a1e2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftghps.f @@ -0,0 +1,35 @@ +C-------------------------------------------------------------------------- + subroutine ftghps(iunit,nkeys,pos,status) + +C Get Header Position +C get the number of keywords in the header and the current position +C in the header, i.e., the number of the next keyword record that +C would be read. +C +C iunit i Fortran I/O unit number +C pos i current position in header (1 = beginning of header) +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Jan 1995 + + integer iunit,nkeys,pos,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + nkeys=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 + pos=(nxthdr(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80+1 + end diff --git a/pkg/tbtables/fitsio/ftghsp.f b/pkg/tbtables/fitsio/ftghsp.f new file mode 100644 index 00000000..0b9161fd --- /dev/null +++ b/pkg/tbtables/fitsio/ftghsp.f @@ -0,0 +1,40 @@ +C-------------------------------------------------------------------------- + subroutine ftghsp(ounit,nexist,nmore,status) + +C Get Header SPace +C return the number of additional keywords that will fit in the header +C +C ounit i Fortran I/O unit number +C nexist i number of keywords already present in the CHU +C nmore i number of additional keywords that will fit in header +C -1 indicates that there is no limit to the number of keywords +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nexist,nmore,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + if (status .gt. 0)return + ibuff=bufnum(ounit) + + nexist=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 + if (dtstrt(ibuff) .lt. 0)then +C the max size of the header has not been defined, so there +C is no limit to the number of keywords which may be written. + nmore=-1 + else + nmore=(dtstrt(ibuff)-hdend(ibuff))/80-1 + end if + end diff --git a/pkg/tbtables/fitsio/ftghtb.f b/pkg/tbtables/fitsio/ftghtb.f new file mode 100644 index 00000000..7f3aea90 --- /dev/null +++ b/pkg/tbtables/fitsio/ftghtb.f @@ -0,0 +1,70 @@ +C---------------------------------------------------------------------- + subroutine ftghtb(iunit,maxfld,ncols,nrows,nfield,ttype, + & tbcol,tform,tunit,extnam,status) + +C read required standard header keywords from an ASCII table extension +C +C iunit i Fortran i/o unit number +C maxfld i maximum no. of fields to read; dimension of ttype +C OUTPUT PARAMETERS: +C ncols i number of columns in the table +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) +C tbcol i beginning column of each field (array) +C tform c Fortran-77 format of each field (array) +C tunit c units of each field (array) +C extnam c name of table (optional) +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,maxfld,ncols,nrows,nfield,status,tbcol(*) + integer i,nfind,maxf,tstat + character*(*) ttype(*),tform(*),tunit(*),extnam + character comm*72 + + call ftgttb(iunit,ncols,nrows,nfield,status) + if (status .gt. 0)return + + if (maxfld .le. 0)then + maxf=nfield + else + maxf=min(maxfld,nfield) + end if + +C initialize optional keywords + do 10 i=1,maxf + ttype(i)=' ' + tunit(i)=' ' +10 continue + + call ftgkns(iunit,'TTYPE',1,maxf,ttype,nfind,status) + call ftgkns(iunit,'TUNIT',1,maxf,tunit,nfind,status) + + if (status .gt. 0)return + + call ftgknj(iunit,'TBCOL',1,maxf,tbcol,nfind,status) + if (status .gt. 0 .or. nfind .ne. maxf)then +C couldn't find the required TBCOL keywords + status=231 + call ftpmsg('Required TBCOL keyword(s) not found in ASCII'// + & ' table header (FTGHTB).') + return + end if + + call ftgkns(iunit,'TFORM',1,maxf,tform,nfind,status) + if (status .gt. 0 .or. nfind .ne. maxf)then +C couldn't find the required TFORM keywords + status=232 + call ftpmsg('Required TFORM keyword(s) not found in ASCII'// + & ' table header (FTGHTB).') + return + end if + + extnam=' ' + tstat=status + call ftgkys(iunit,'EXTNAME',extnam,comm,status) +C this keyword is not required, so ignore 'keyword not found' status + if (status .eq. 202)status=tstat + end diff --git a/pkg/tbtables/fitsio/ftgi1b.f b/pkg/tbtables/fitsio/ftgi1b.f new file mode 100644 index 00000000..c0d1e587 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgi1b.f @@ -0,0 +1,26 @@ +C---------------------------------------------------------------------- + subroutine ftgi1b(ounit,nvals,incre,chbuff,status) + +C Read an array of Integer*1 bytes from the input FITS file. + + integer nvals,incre,ounit,status,i,offset + character*1 chbuff(nvals) + +C ounit i fortran unit number +C nvals i number of pixels in the i2vals array +C incre i byte increment between values +C chbuff c*1 array of input byte values +C status i output error status + + if (incre .le. 1)then + call ftgcbf(ounit,0,nvals,chbuff,status) + else +C offset is the number of bytes to move between each value + offset=incre-1 + call ftgcbf(ounit,0,1,chbuff,status) + do 10 i=2,nvals + call ftmoff(ounit,offset,.false.,status) + call ftgcbf(ounit,0,1,chbuff(i),status) +10 continue + end if + end diff --git a/pkg/tbtables/fitsio/ftgics.f b/pkg/tbtables/fitsio/ftgics.f new file mode 100644 index 00000000..fc41266e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgics.f @@ -0,0 +1,47 @@ +C------------------------------------------------------------------------------ + subroutine ftgics(iunit,xrval,yrval,xrpix,yrpix,xinc,yinc,rot, + & type,status) + +C read the values of the celestial coordinate system keywords. +C These values may be used as input to the subroutines that +C calculate celestial coordinates. (FTXYPX, FTWLDP) + +C This routine assumes that the CHDU contains an image +C with the RA type coordinate running along the first axis +C and the DEC type coordinate running along the 2nd axis. + + double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot + integer iunit,status,tstat + character*(*) type + character comm*20,ctype*8 + + if (status .gt. 0)return + + call ftgkyd(iunit,'CRVAL1',xrval,comm,status) + call ftgkyd(iunit,'CRVAL2',yrval,comm,status) + + call ftgkyd(iunit,'CRPIX1',xrpix,comm,status) + call ftgkyd(iunit,'CRPIX2',yrpix,comm,status) + + call ftgkyd(iunit,'CDELT1',xinc,comm,status) + call ftgkyd(iunit,'CDELT2',yinc,comm,status) + + call ftgkys(iunit,'CTYPE1',ctype,comm,status) + + if (status .gt. 0)then + call ftpmsg('FTGICS could not find all the required'// + & 'celestial coordinate Keywords.') + status=505 + return + end if + + type=ctype(5:8) + + tstat=status + call ftgkyd(iunit,'CROTA2',rot,comm,status) + if (status .gt. 0)then +C CROTA2 is assumed to = 0 if keyword is not present + status=tstat + rot=0. + end if + end diff --git a/pkg/tbtables/fitsio/ftgiou.f b/pkg/tbtables/fitsio/ftgiou.f new file mode 100644 index 00000000..adf3881d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgiou.f @@ -0,0 +1,11 @@ +C------------------------------------------------------------------------------ + subroutine ftgiou(iounit,status) + +C get an unallocated logical unit number + + integer iounit,status + + if (status .gt. 0)return + iounit=0 + call ftxiou(iounit,status) + end diff --git a/pkg/tbtables/fitsio/ftgkey.f b/pkg/tbtables/fitsio/ftgkey.f new file mode 100644 index 00000000..c473f8e2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkey.f @@ -0,0 +1,24 @@ +C-------------------------------------------------------------------------- + subroutine ftgkey(iunit,keynam,value,comm,status) + +C Read value and comment of a header keyword from the keyword buffer + +C iunit i Fortran I/O unit number +C keynam c name of keyword to be read +C OUTPUT PARAMETERS: +C value c output value of the keyword, if any +C comm c output comment string, if any, of the keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,status + character*(*) keynam,value,comm + character*80 keybuf + + call ftgcrd(iunit,keynam,keybuf,status) + if (status .le. 0)then +C parse the record to find value and comment strings + call ftpsvc(keybuf,value,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftgknd.f b/pkg/tbtables/fitsio/ftgknd.f new file mode 100644 index 00000000..682d1f36 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgknd.f @@ -0,0 +1,79 @@ +C-------------------------------------------------------------------------- + subroutine ftgknd(iunit,keywrd,nstart,nmax, + & dval,nfound,status) + +C read an array of real*8 values from header records +C +C iunit i fortran input unit number +C keywrd c keyword name +C nstart i starting sequence number (usually 1) +C nmax i number of keywords to read +C OUTPUT PARAMETERS: +C dval d array of output keyword values +C nfound i number of keywords found +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd + double precision dval(*) + integer iunit,nstart,nmax,nfound,status,tstat + integer nkeys,mkeys,i,ival,nend,namlen,indval + character inname*8,keynam*8 + character*80 rec,value,comm + + if (status .gt. 0)return + +C for efficiency, we want to search just once through the header +C for all the keywords which match the root. + + nfound=0 + nend=nstart+nmax-1 + inname=keywrd + call ftupch(inname) + +C find the length of the root name + namlen=0 + do 5 i=8,1,-1 + if (inname(i:i) .ne. ' ')then + namlen=i + go to 6 + end if +5 continue +6 if (namlen .eq. 0)return + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,mkeys,status) + + do 10 i=3,nkeys + call ftgrec(iunit,i,rec,status) + if (status .gt. 0)return + keynam=rec(1:8) + if (keynam(1:namlen) .eq. inname(1:namlen))then + +C try to interpret the remainder of the name as an integer + tstat=status + call ftc2ii(keynam(namlen+1:8),ival,status) + if (status .le. 0)then + if (ival .le. nend .and. ival .ge. nstart)then + call ftpsvc(rec,value,comm,status) + indval=ival-nstart+1 + call ftc2dd(value,dval(indval),status) + if (status .gt. 0)then + call ftpmsg('Error in FTGKND evaluating '//keynam// + & ' as a Double: '//value) + return + else + nfound=max(nfound,indval) + end if + end if + else + if (status .eq. 407)then + status=tstat + else + return + end if + end if + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgkne.f b/pkg/tbtables/fitsio/ftgkne.f new file mode 100644 index 00000000..3ec392a8 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkne.f @@ -0,0 +1,79 @@ +C-------------------------------------------------------------------------- + subroutine ftgkne(iunit,keywrd,nstart,nmax, + & rval,nfound,status) + +C read an array of real*4 values from header records +C +C iunit i fortran input unit number +C keywrd c keyword name +C nstart i starting sequence number (usually 1) +C nmax i number of keywords to read +C OUTPUT PARAMETERS: +C rval r array of output keyword values +C nfound i number of keywords found +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd + real rval(*) + integer iunit,nstart,nmax,nfound,status,tstat + integer nkeys,mkeys,i,ival,nend,namlen,indval + character inname*8,keynam*8 + character*80 rec,value,comm + + if (status .gt. 0)return + +C for efficiency, we want to search just once through the header +C for all the keywords which match the root. + + nfound=0 + nend=nstart+nmax-1 + inname=keywrd + call ftupch(inname) + +C find the length of the root name + namlen=0 + do 5 i=8,1,-1 + if (inname(i:i) .ne. ' ')then + namlen=i + go to 6 + end if +5 continue +6 if (namlen .eq. 0)return + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,mkeys,status) + + do 10 i=3,nkeys + call ftgrec(iunit,i,rec,status) + if (status .gt. 0)return + keynam=rec(1:8) + if (keynam(1:namlen) .eq. inname(1:namlen))then + +C try to interpret the remainder of the name as an integer + tstat=status + call ftc2ii(keynam(namlen+1:8),ival,status) + if (status .le. 0)then + if (ival .le. nend .and. ival .ge. nstart)then + call ftpsvc(rec,value,comm,status) + indval=ival-nstart+1 + call ftc2rr(value,rval(indval),status) + if (status .gt. 0)then + call ftpmsg('Error in FTGKNE evaluating '//keynam// + & ' as a Real: '//value) + return + else + nfound=max(nfound,indval) + end if + end if + else + if (status .eq. 407)then + status=tstat + else + return + end if + end if + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgknj.f b/pkg/tbtables/fitsio/ftgknj.f new file mode 100644 index 00000000..390b4216 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgknj.f @@ -0,0 +1,79 @@ +C-------------------------------------------------------------------------- + subroutine ftgknj(iunit,keywrd,nstart,nmax,intval, + & nfound,status) + +C read an array of integer values from header records +C +C iunit i fortran input unit number +C keywrd c keyword name +C nstart i starting sequence number (usually 1) +C nmax i number of keywords to read +C OUTPUT PARAMETERS: +C intval i array of output keyword values +C nfound i number of keywords found +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd + integer intval(*) + integer iunit,nstart,nmax,nfound,status,tstat + integer nkeys,mkeys,i,ival,nend,namlen,indval + character inname*8,keynam*8 + character*80 rec,value,comm + + if (status .gt. 0)return + +C for efficiency, we want to search just once through the header +C for all the keywords which match the root. + + nfound=0 + nend=nstart+nmax-1 + inname=keywrd + call ftupch(inname) + +C find the length of the root name + namlen=0 + do 5 i=8,1,-1 + if (inname(i:i) .ne. ' ')then + namlen=i + go to 6 + end if +5 continue +6 if (namlen .eq. 0)return + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,mkeys,status) + + do 10 i=3,nkeys + call ftgrec(iunit,i,rec,status) + if (status .gt. 0)return + keynam=rec(1:8) + if (keynam(1:namlen) .eq. inname(1:namlen))then + +C try to interpret the remainder of the name as an integer + tstat=status + call ftc2ii(keynam(namlen+1:8),ival,status) + if (status .le. 0)then + if (ival .le. nend .and. ival .ge. nstart)then + call ftpsvc(rec,value,comm,status) + indval=ival-nstart+1 + call ftc2ii(value,intval(indval),status) + if (status .gt. 0)then + call ftpmsg('Error in FTGKNJ evaluating '//keynam// + & ' as an integer: '//value) + return + else + nfound=max(nfound,indval) + end if + end if + else + if (status .eq. 407)then + status=tstat + else + return + end if + end if + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgknl.f b/pkg/tbtables/fitsio/ftgknl.f new file mode 100644 index 00000000..5c21077d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgknl.f @@ -0,0 +1,73 @@ +C-------------------------------------------------------------------------- + subroutine ftgknl(iunit,keywrd,nstart,nmax,logval, + & nfound,status) + +C read an array of logical values from header records +C +C iunit i fortran input unit number +C keywrd c keyword name +C nstart i starting sequence number (usually 1) +C nmax i number of keywords to read +C OUTPUT PARAMETERS: +C logval l array of output keyword values +C nfound i number of keywords found +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd + logical logval(*) + integer iunit,nstart,nmax,nfound,status,tstat + integer nkeys,mkeys,i,ival,nend,namlen,indval + character inname*8,keynam*8 + character*80 rec,value,comm + + if (status .gt. 0)return + +C for efficiency, we want to search just once through the header +C for all the keywords which match the root. + + nfound=0 + nend=nstart+nmax-1 + inname=keywrd + call ftupch(inname) + +C find the length of the root name + namlen=0 + do 5 i=8,1,-1 + if (inname(i:i) .ne. ' ')then + namlen=i + go to 6 + end if +5 continue +6 if (namlen .eq. 0)return + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,mkeys,status) + + do 10 i=3,nkeys + call ftgrec(iunit,i,rec,status) + if (status .gt. 0)return + keynam=rec(1:8) + if (keynam(1:namlen) .eq. inname(1:namlen))then + +C try to interpret the remainder of the name as an integer + tstat=status + call ftc2ii(keynam(namlen+1:8),ival,status) + if (status .le. 0)then + if (ival .le. nend .and. ival .ge. nstart)then + call ftpsvc(rec,value,comm,status) + indval=ival-nstart+1 + call ftc2ll(value,logval(indval),status) + nfound=max(nfound,indval) + end if + else + if (status .eq. 407)then + status=tstat + else + return + end if + end if + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgkns.f b/pkg/tbtables/fitsio/ftgkns.f new file mode 100644 index 00000000..66194c38 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkns.f @@ -0,0 +1,94 @@ +C-------------------------------------------------------------------------- + subroutine ftgkns(iunit,keywrd,nstart,nmax,strval,nfound, + & status) + +C read an array of character string values from header records +C +C iunit i fortran input unit number +C keywrd c keyword name +C nstart i starting sequence number (usually 1) +C nmax i number of keywords to read +C OUTPUT PARAMETERS: +C strval i array of output keyword values +C nfound i number of keywords found +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,strval(*) + integer iunit,nstart,nmax,nfound,status,tstat + integer nkeys,mkeys,i,ival,nend,namlen,indval,ibuff + character inname*8,keynam*8 + character*80 value,comm + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(iunit) + +C for efficiency, we want to search just once through the header +C for all the keywords which match the root. + + nfound=0 + nend=nstart+nmax-1 + inname=keywrd + call ftupch(inname) + +C find the length of the root name + namlen=0 + do 5 i=8,1,-1 + if (inname(i:i) .ne. ' ')then + namlen=i + go to 6 + end if +5 continue +6 if (namlen .eq. 0)return + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,mkeys,status) + + do 10 i=3,nkeys + call ftgrec(iunit,i,value,status) + if (status .gt. 0)return + keynam=value(1:8) + if (keynam(1:namlen) .eq. inname(1:namlen))then + +C try to interpret the remainder of the name as an integer + tstat=status + call ftc2ii(keynam(namlen+1:8),ival,status) + if (status .le. 0)then + if (ival .le. nend .and. ival .ge. nstart)then + +C OK, this looks like a valid keyword; Reset the +C next-header-keyword pointer by one record, then +C call ftgkys to read it. (This does support +C long continued string values) + + nxthdr(ibuff)=nxthdr(ibuff)-80 + indval=ival-nstart+1 + call ftgkys(iunit,keynam,strval(indval), + & comm,status) + + nfound=max(nfound,indval) + end if + else + if (status .eq. 407)then + status=tstat + else + return + end if + end if + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgkyd.f b/pkg/tbtables/fitsio/ftgkyd.f new file mode 100644 index 00000000..b1ca4ccc --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkyd.f @@ -0,0 +1,26 @@ +C-------------------------------------------------------------------------- + subroutine ftgkyd(iunit,keywrd,dval,comm,status) + +C read a double precision value and comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C dval i output keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer iunit,status + character value*35 + double precision dval + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C convert character string to double precision +C datatype conversion will be performed if necessary and if possible + call ftc2d(value,dval,status) + end diff --git a/pkg/tbtables/fitsio/ftgkye.f b/pkg/tbtables/fitsio/ftgkye.f new file mode 100644 index 00000000..9477ba34 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkye.f @@ -0,0 +1,26 @@ +C-------------------------------------------------------------------------- + subroutine ftgkye(iunit,keywrd,rval,comm,status) + +C read a real*4 value and the comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C rval r output keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer iunit,status + character value*35 + real rval + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C convert character string to real +C datatype conversion will be performed if necessary and if possible + call ftc2r(value,rval,status) + end diff --git a/pkg/tbtables/fitsio/ftgkyj.f b/pkg/tbtables/fitsio/ftgkyj.f new file mode 100644 index 00000000..ff0b84da --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkyj.f @@ -0,0 +1,25 @@ +C-------------------------------------------------------------------------- + subroutine ftgkyj(iunit,keywrd,intval,comm,status) + +C read an integer value and the comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C intval i output keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer iunit,intval,status + character value*35 + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C convert character string to integer +C datatype conversion will be performed if necessary and if possible + call ftc2i(value,intval,status) + end diff --git a/pkg/tbtables/fitsio/ftgkyl.f b/pkg/tbtables/fitsio/ftgkyl.f new file mode 100644 index 00000000..a4d355a5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkyl.f @@ -0,0 +1,25 @@ +C-------------------------------------------------------------------------- + subroutine ftgkyl(iunit,keywrd,logval,comm,status) + +C read a logical value and the comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C logval l output keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer iunit,status + character value*20 + logical logval + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C convert character string to logical + call ftc2l(value,logval,status) + end diff --git a/pkg/tbtables/fitsio/ftgkyn.f b/pkg/tbtables/fitsio/ftgkyn.f new file mode 100644 index 00000000..09a95421 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkyn.f @@ -0,0 +1,49 @@ +C-------------------------------------------------------------------------- + subroutine ftgkyn(iunit,nkey,keynam,value,comm,status) + +C Read value and comment of the NKEYth header record +C This routine is useful for reading the entire header, one +C record at a time. + +C iunit i Fortran I/O unit number +C nkey i sequence number (starting with 1) of the keyword to read +C OUTPUT PARAMETERS: +C keynam c output name of the keyword +C value c output value of the keyword, if any +C comm c output comment string, if any, of the keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,nkey,status + character*(*) keynam,value,comm + character keybuf*80,arec*8 + + if (status .gt. 0)return + + call ftgrec(iunit,nkey,keybuf,status) + if (status .gt. 0)return + + keynam=keybuf(1:8) + +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + if (status .gt. 0)return + +C Test that keyword name contains only valid characters. +C This also serves as a check in case there was no END keyword and +C program continues to read on into the data unit + call fttkey(keybuf(1:8),status) + if (status .gt. 0)then + write(arec,1000)nkey +1000 format(i8) + call ftpmsg('Name of header keyword number'//arec// + & ' contains illegal character(s):') + call ftpmsg(keybuf) + +C see if we are at the beginning of FITS logical record + if (nkey-1 .eq. (nkey-1)/36*36 .and. nkey .gt. 1)then + call ftpmsg('(This may indicate a missing END keyword).') + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftgkys.f b/pkg/tbtables/fitsio/ftgkys.f new file mode 100644 index 00000000..22c8479a --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkys.f @@ -0,0 +1,68 @@ +C-------------------------------------------------------------------------- + subroutine ftgkys(iunit,keywrd,strval,comm,status) + +C read a character string value and comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C strval c output keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C modified 6/93 to support long strings which are continued +C over several keywords. A string may be continued by putting +C a backslash as the last non-blank character in the keyword string, +C then continuing the string in the next keyword which must have +C a blank keyword name. +C Modified 9/94 to support the new OGIP continuation convention + + character*(*) keywrd,comm,strval + integer status,iunit + character value*70, comm2*70, bslash*1 + integer clen,i,bspos,lenval + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C convert character string to unquoted string + call ftc2s(value,strval,status) + + if (status .gt. 0)return + + clen=len(strval) + +C is last character a backslash or & ? +C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape + bslash='\\' + do 10 i=70,1,-1 + if (value(i:i) .ne. ' ' .and. value(i:i).ne.'''')then + if (value(i:i) .eq. bslash .or. + & value(i:i) .eq. '&')then +C have to subtract 1 due to the leading quote char + bspos=i-1 + go to 20 + end if +C no continuation character, so just return + return + end if +10 continue +C value field was blank, so just return + return + +C try to get the string continuation, and new comment string +20 call ftgnst(iunit,value,lenval,comm2,status) + if (lenval .eq. 0)return + + if (bspos .le. clen)then + strval(bspos:)=value(1:lenval) + bspos=bspos+lenval-1 + end if + + if (comm2 .ne. ' ')comm=comm2 + +C see if there is another continuation line + if (value(lenval:lenval) .eq. bslash .or. + & value(lenval:lenval) .eq. '&')go to 20 + end diff --git a/pkg/tbtables/fitsio/ftgkyt.f b/pkg/tbtables/fitsio/ftgkyt.f new file mode 100644 index 00000000..3acaa846 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgkyt.f @@ -0,0 +1,53 @@ +C-------------------------------------------------------------------------- + subroutine ftgkyt(iunit,keywrd,jval,dval,comm,status) + +C read an integer value and fractional parts of a keyword value +C and the comment string from a header record +C +C iunit i fortran input unit number +C keywrd c keyword name +C OUTPUT PARAMETERS: +C jval i output integer part of keyword value +C dval d output fractional part of keyword value +C comm c output keyword comment +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, Sept 1992 + + character*(*) keywrd,comm + integer iunit,jval,status,i,dot + double precision dval + character value*35 + logical ed + +C find the keyword and return value and comment as character strings + call ftgkey(iunit,keywrd,value,comm,status) + +C read keyword in straight forward way first: +C just convert character string to double precision +C datatype conversion will be performed if necessary and if possible + call ftc2d(value,dval,status) + jval=dval + if (jval .ge. 0)then + dval=dval-jval + else + dval=dval+jval + end if + +C now see if we have to read the fractional part again, this time +C with more precision + +C find the decimal point, if any, and look for a D or E + dot=0 + ed=.false. + do 10 i=1,35 + if (value(i:i) .eq. '.')dot=i + if (value(i:i) .eq. 'E' .or. value(i:i) .eq. 'D')ed=.true. +10 continue + + if (.not. ed .and. dot .gt. 0)then +C convert fractional part to double precision + call ftc2d(value(dot:),dval,status) + end if + + end diff --git a/pkg/tbtables/fitsio/ftgmsg.f b/pkg/tbtables/fitsio/ftgmsg.f new file mode 100644 index 00000000..b8835dec --- /dev/null +++ b/pkg/tbtables/fitsio/ftgmsg.f @@ -0,0 +1,7 @@ +C------------------------------------------------------------------------------ + subroutine ftgmsg(text) + +C get error message from top of stack and shift the stack up one message + character*(*) text + call ftxmsg(-1,text) + end diff --git a/pkg/tbtables/fitsio/ftgnst.f b/pkg/tbtables/fitsio/ftgnst.f new file mode 100644 index 00000000..0d9ed966 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgnst.f @@ -0,0 +1,70 @@ +C-------------------------------------------------------------------------- + subroutine ftgnst(iunit,value,lenval,comm,status) + +C get the next string keyword. +C see if the next keyword in the header is the continuation +C of a long string keyword, and if so, return the value string, +C the number of characters in the string, and the associated comment +C string. + +C value c returned value of the string continuation +C lenval i number of non-blank characters in the continuation string +C comm C value of the comment string, if any, in this keyword. + + character*(*) value,comm + integer iunit,lenval,status + + integer i,length,tstat,nkeys,nextky + character record*80, strval*70 + + if (status .gt. 0)return + + tstat=status + value=' ' + comm=' ' + lenval=0 + +C get current header position + call ftghps(iunit,nkeys,nextky,status) + +C get the next keyword record + if (nextky .le. nkeys)then + call ftgrec(iunit,nextky,record,status) + else +C positioned at end of header, so there is no next keyword to read + return + end if + +C does this appear to be a continuation keyword (=blank keyword name +C or CONTINUE)? + if (record(1:10) .ne. ' ' .and. record(1:10) .ne. + & 'CONTINUE ')return + +C return if record is blank + if (record .eq. ' ')return + +C set a dummy keyword name + record(1:10)='DUMMYKEY= ' + +C parse the record to get the value string and comment + call ftpsvc(record,strval,comm,status) + +C convert character string to unquoted string + call ftc2s(strval,value,status) + if (status .gt. 0)then +C this must not be a continuation card; reset status and messages + status=tstat + call ftcmsg + value=' ' + comm=' ' + return + end if + + length=len(value) + do 10 i=length,1,-1 + if (value(i:i) .ne. ' ')then + lenval=i + return + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftgpfb.f b/pkg/tbtables/fitsio/ftgpfb.f new file mode 100644 index 00000000..62b4defb --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpfb.f @@ -0,0 +1,42 @@ +C---------------------------------------------------------------------- + subroutine ftgpfb(iunit,group,felem,nelem, + & array,flgval,anynul,status) + +C Read an array of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will have the corresponding element of +C FLGVAL set equal to .true. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C array b returned array of values that were read +C flgval l set to .true. if the corresponding element is undefined +C anynul l set to .true. if any returned elements are undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + character*1 nulval,array(*) + logical anynul,flgval(*) + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgclb(iunit,2,row,felem,nelem,1,2,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpfd.f b/pkg/tbtables/fitsio/ftgpfd.f new file mode 100644 index 00000000..b92e8879 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpfd.f @@ -0,0 +1,42 @@ +C---------------------------------------------------------------------- + subroutine ftgpfd(iunit,group,felem,nelem, + & array,flgval,anynul,status) + +C Read an array of r*8 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will have the corresponding element of +C FLGVAL set equal to .true. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C array d returned array of values that were read +C flgval l set to .true. if the corresponding element is undefined +C anynul l set to .true. if any returned elements are undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + double precision nulval,array(*) + logical anynul,flgval(*) + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcld(iunit,2,row,felem,nelem,1,2,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpfe.f b/pkg/tbtables/fitsio/ftgpfe.f new file mode 100644 index 00000000..715adc29 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpfe.f @@ -0,0 +1,42 @@ +C---------------------------------------------------------------------- + subroutine ftgpfe(iunit,group,felem,nelem, + & array,flgval,anynul,status) + +C Read an array of r*4 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will have the corresponding element of +C FLGVAL set equal to .true. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C array r returned array of values that were read +C flgval l set to .true. if the corresponding element is undefined +C anynul l set to .true. if any returned elements are undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + real nulval,array(*) + logical anynul,flgval(*) + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcle(iunit,2,row,felem,nelem,1,2,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpfi.f b/pkg/tbtables/fitsio/ftgpfi.f new file mode 100644 index 00000000..5292eec2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpfi.f @@ -0,0 +1,42 @@ +C---------------------------------------------------------------------- + subroutine ftgpfi(iunit,group,felem,nelem, + & array,flgval,anynul,status) + +C Read an array of I*2 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will have the corresponding element of +C FLGVAL set equal to .true. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C array i*2 returned array of values that were read +C flgval l set to .true. if the corresponding element is undefined +C anynul l set to .true. if any returned elements are undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + integer*2 nulval,array(*) + logical anynul,flgval(*) + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcli(iunit,2,row,felem,nelem,1,2,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpfj.f b/pkg/tbtables/fitsio/ftgpfj.f new file mode 100644 index 00000000..091bf121 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpfj.f @@ -0,0 +1,42 @@ +C---------------------------------------------------------------------- + subroutine ftgpfj(iunit,group,felem,nelem, + & array,flgval,anynul,status) + +C Read an array of I*4 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will have the corresponding element of +C FLGVAL set equal to .true. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C array i returned array of values that were read +C flgval l set to .true. if the corresponding element is undefined +C anynul l set to .true. if any returned elements are undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + integer nulval,array(*) + logical anynul,flgval(*) + integer i + + do 10 i=1,nelem + flgval(i)=.false. +10 continue + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgclj(iunit,2,row,felem,nelem,1,2,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgphx.f b/pkg/tbtables/fitsio/ftgphx.f new file mode 100644 index 00000000..c625413d --- /dev/null +++ b/pkg/tbtables/fitsio/ftgphx.f @@ -0,0 +1,281 @@ +C---------------------------------------------------------------------- + subroutine ftgphx(iunit,maxdim,simple,bitpix,naxis,naxes,pcount + & ,gcount,extend,bscale,bzero,blank,nblank,status) + +C get the main primary header keywords which define the array structure +C +C iunit i fortran unit number to use for reading +C maxdim i maximum no. of dimensions to read; dimension of naxes +C OUTPUT PARAMETERS: +C simple l does file conform to FITS standard? +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C pcount i number of group parameters (usually 0) +C gcount i number of random groups (usually 1 or 0) +C extend l may extensions be present in the FITS file? +C bscale d scaling factor +C bzero d scaling zero point +C blank i value used to represent undefined pixels +C nblank i number of trailing blank keywords immediately before the END +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,maxdim,bitpix,naxis + integer naxes(*),pcount,gcount,blank,status,tstat + logical simple,extend,unknow + character keynam*8,value*20,lngval*40,comm*72,extn*4,keybuf*80 + double precision bscale,bzero + integer nkey,nblank,i,ibuff,taxes,maxd + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check that the first keyword is valid + call ftgrec(iunit,1,keybuf,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + + simple=.true. + unknow=.false. + if (chdu(ibuff) .eq. 1)then + if (keynam .eq. 'SIMPLE')then + if (value .eq. 'F')then +C this is not a simple FITS file; try to process it anyway + simple=.false. + else if (value .ne. 'T')then +C illegal value for the SIMPLE keyword + status=220 + + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('The SIMPLE keyword is missing "= " in '// + & 'columns 9-10.') + else + call ftpmsg('The SIMPLE keyword value is illegal:'//value + & // '. It must equal T or F:') + end if + + call ftpmsg(keybuf) + end if + else + status=221 + call ftpmsg('First keyword of the file is not SIMPLE: '//keynam) + call ftpmsg(keybuf) + go to 900 + end if + else + if (keynam .eq. 'XTENSION')then + if (value(2:9) .ne. 'IMAGE ' .and. + & value(2:9) .ne. 'IUEIMAGE')then +C I don't know what type of extension this is, but press on + unknow=.true. + + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('The XTENSION keyword is missing "= " in '// + & 'columns 9-10.') + else + call ftpmsg('This is not an IMAGE extension: '//value) + end if + + call ftpmsg(keybuf) + end if + else + status=225 + write(extn,1000)chdu(ibuff) +1000 format(i4) + call ftpmsg('First keyword in extension '//extn// + & ' was not XTENSION: '//keynam) + call ftpmsg(keybuf) + end if + end if + if (status .gt. 0)go to 900 + +C check that BITPIX is the second keyword + call ftgrec(iunit,2,keybuf,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + if (keynam .ne. 'BITPIX')then + status=222 + call ftpmsg('Second keyword was not BITPIX: '//keynam) + call ftpmsg(keybuf) + go to 900 + end if +C convert character string to integer + call ftc2ii(value,bitpix,status) + if (status .gt. 0)then +C bitpix value must be an integer + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('BITPIX keyword is missing "= "'// + & ' in columns 9-10.') + else + call ftpmsg('Value of BITPIX is not an integer: '//value) + end if + call ftpmsg(keybuf) + status=211 + go to 900 + end if + +C test that bitpix has a legal value + call fttbit(bitpix,status) + if (status .gt. 0)then + call ftpmsg(keybuf) + go to 900 + end if + +C check that the third keyword is NAXIS + call ftgtkn(iunit,3,'NAXIS',naxis,status) + if (status .eq. 208)then +C third keyword was not NAXIS + status=223 + else if (status .eq. 209)then +C NAXIS value was not an integer + status=212 + end if + if (status .gt. 0)go to 900 + + if (maxdim .le. 0)then + maxd=naxis + else + maxd=min(maxdim,naxis) + end if + + do 10 i=1,naxis +C construct keyword name + call ftkeyn('NAXIS',i,keynam,status) +C attempt to read the keyword + call ftgtkn(iunit,3+i,keynam,taxes,status) + if (status .gt. 0)then + status=224 + go to 900 + else if (taxes .lt. 0)then +C NAXISn keywords must not be negative + status=213 + go to 900 + else if (i .le. maxd)then + naxes(i)=taxes + end if +10 continue + +C now look for other keywords of interest: bscale, bzero, blank, and END +C and pcount, gcount, and extend +15 bscale=1. + bzero=0. + pcount=0 + gcount=1 + extend=.false. +C choose a special value to represent the absence of a blank value + blank=123454321 + + nkey=3+naxis +18 nblank=0 +20 nkey=nkey+1 + tstat=status + call ftgrec(iunit,nkey,keybuf,status) + if (status .gt. 0)then +C first, check for normal end-of-header status, and reset to 0 + if (status .eq. 203)status=tstat +C if we hit the end of file, then set status = no END card found + if (status .eq. 107)then + status=210 + call ftpmsg('FITS header has no END keyword!') + end if + go to 900 + end if + keynam=keybuf(1:8) + comm=keybuf(9:80) + + if (keynam .eq. 'BSCALE')then +C convert character string to floating pt. + call ftpsvc(keybuf,lngval,comm,status) + call ftc2dd(lngval,bscale,status) + if (status .gt. 0)then + call ftpmsg('Error reading BSCALE keyword value'// + & ' as a Double:'//lngval) + end if + else if (keynam .eq. 'BZERO')then +C convert character string to floating pt. + call ftpsvc(keybuf,lngval,comm,status) + call ftc2dd(lngval,bzero,status) + if (status .gt. 0)then + call ftpmsg('Error reading BZERO keyword value'// + & ' as a Double:'//lngval) + end if + else if (keynam .eq. 'BLANK')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,blank,status) + if (status .gt. 0)then + call ftpmsg('Error reading BLANK keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'PCOUNT')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,pcount,status) + if (status .gt. 0)then + call ftpmsg('Error reading PCOUNT keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'GCOUNT')then +C convert character string to integer + call ftpsvc(keybuf,value,comm,status) + call ftc2ii(value,gcount,status) + if (status .gt. 0)then + call ftpmsg('Error reading GCOUNT keyword value'// + & ' as an integer:'//value) + end if + else if (keynam .eq. 'EXTEND')then +C convert character string to logical + call ftpsvc(keybuf,value,comm,status) + call ftc2ll(value,extend,status) + if (status .gt. 0)then + call ftpmsg('Error reading EXTEND keyword value'// + & ' as a Logical:'//value) + end if + else if (keynam .eq. ' ' .and. comm .eq. ' ')then +C need to ignore trailing blank records before the END card + nblank=nblank+1 + go to 20 + else if (keynam .eq. 'END')then + go to 900 + end if + if (status .gt. 0)go to 900 + go to 18 + +900 continue + + if (status .gt. 0)then + if (chdu(ibuff) .eq. 1)then + call ftpmsg('Failed to parse the required keywords in '// + & 'the Primary Array header ') + else + call ftpmsg('Failed to parse the required keywords in '// + & 'the Image Extension header (FTGPHX).') + end if + + else if (unknow)then +C set status if this was an unknown type of extension + status=233 + end if + end diff --git a/pkg/tbtables/fitsio/ftgprh.f b/pkg/tbtables/fitsio/ftgprh.f new file mode 100644 index 00000000..6171cfa6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgprh.f @@ -0,0 +1,14 @@ +C---------------------------------------------------------------------- + subroutine ftgprh(iunit,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + +C OBSOLETE routine: should call ftghpr instead + + integer iunit,bitpix,naxis,naxes(*),pcount,gcount,blank,status + integer nblank + logical simple,extend + double precision fill + + call ftgphx(iunit,0,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,fill,fill,blank,nblank,status) + end diff --git a/pkg/tbtables/fitsio/ftgpvb.f b/pkg/tbtables/fitsio/ftgpvb.f new file mode 100644 index 00000000..9c412ecf --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpvb.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftgpvb(iunit,group,felem,nelem,nulval, + & array,anynul,status) + +C Read an array of byte values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will be set equal to NULVAL, unless NULVAL=0 +C in which case no checking for undefined values will be performed. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C nulval b the value to be assigned to undefined pixels +C array b returned array of values that were read +C anynul l set to .true. if any returned elements were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + character nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgclb(iunit,2,row,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpvd.f b/pkg/tbtables/fitsio/ftgpvd.f new file mode 100644 index 00000000..7e5c3e79 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpvd.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftgpvd(iunit,group,felem,nelem,nulval, + & array,anynul,status) + +C Read an array of r*8 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will be set equal to NULVAL, unless NULVAL=0 +C in which case no checking for undefined values will be performed. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C nulval b the value to be assigned to undefined pixels +C array b returned array of values that were read +C anynul l set to .true. if any returned elements were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + double precision nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcld(iunit,2,row,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpve.f b/pkg/tbtables/fitsio/ftgpve.f new file mode 100644 index 00000000..4a5433f4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpve.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftgpve(iunit,group,felem,nelem,nulval, + & array,anynul,status) + +C Read an array of r*4 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will be set equal to NULVAL, unless NULVAL=0 +C in which case no checking for undefined values will be performed. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C nulval r the value to be assigned to undefined pixels +C array r returned array of values that were read +C anynul l set to .true. if any returned elements were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + real nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcle(iunit,2,row,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpvi.f b/pkg/tbtables/fitsio/ftgpvi.f new file mode 100644 index 00000000..397ec611 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpvi.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftgpvi(iunit,group,felem,nelem,nulval, + & array,anynul,status) + +C Read an array of i*2 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will be set equal to NULVAL, unless NULVAL=0 +C in which case no checking for undefined values will be performed. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C nulval i*2 the value to be assigned to undefined pixels +C array i*2 returned array of values that were read +C anynul l set to .true. if any returned elements were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + integer*2 nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgcli(iunit,2,row,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgpvj.f b/pkg/tbtables/fitsio/ftgpvj.f new file mode 100644 index 00000000..ea5802b1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgpvj.f @@ -0,0 +1,37 @@ +C---------------------------------------------------------------------- + subroutine ftgpvj(iunit,group,felem,nelem,nulval, + & array,anynul,status) + +C Read an array of i*4 values from the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). +C Undefined elements will be set equal to NULVAL, unless NULVAL=0 +C in which case no checking for undefined values will be performed. +C ANYNUL is return with a value of .true. if any pixels were undefined. + +C iunit i Fortran unit number +C group i number of the data group, if any +C felem i the first pixel to be read (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be read +C nulval i the value to be assigned to undefined pixels +C array i returned array of values that were read +C anynul l set to .true. if any returned elements were undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,group,felem,nelem,status,row + integer nulval,array(*) + logical anynul,flgval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(1,group) + call ftgclj(iunit,2,row,felem,nelem,1,1,nulval, + & array,flgval,anynul,status) + end diff --git a/pkg/tbtables/fitsio/ftgrec.f b/pkg/tbtables/fitsio/ftgrec.f new file mode 100644 index 00000000..d64aaa75 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgrec.f @@ -0,0 +1,71 @@ +C-------------------------------------------------------------------------- + subroutine ftgrec(iunit,nrec,record,status) + +C Read the Nth 80-byte header record +C This routine is useful for reading the entire header, one +C record at a time. + +C iunit i Fortran I/O unit number +C nrec i sequence number (starting with 1) of the record to read +C OUTPUT PARAMETERS: +C record c output 80-byte record +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,nrec,status + character*80 record + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,nbyte,endhd + character arec*8 + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(iunit) + +C calculate byte location of the record, and check if it is legal + nbyte=hdstrt(ibuff,chdu(ibuff))+(nrec-1)*80 + +C endhd=(hdend(ibuff)/2880+1)*2880 +C modified this on 4 Nov 1994 to allow for blanks before the END keyword + endhd=max(hdend(ibuff),dtstrt(ibuff)-2880) + + if (nbyte .gt. endhd .or. nrec .le. 0)then +C header record number is out of bounds + status=203 + write(arec,1000)nrec +1000 format(i8) + call ftpmsg('Cannot get Keyword number '//arec//'.'// + & ' It does not exist.') + go to 100 + end if + +C position the I/O pointer to the appropriate header keyword + call ftmbyt(iunit,nbyte,.false.,status) + +C read the 80 byte record + call ftgcbf(iunit,1,80,record,status) + if (status .gt. 0)then + write(arec,1000)nrec + call ftpmsg('FTGREC could not read header keyword'// + & ' number '//arec//'.') + return + end if + +C update the keyword pointer position + nxthdr(ibuff)=nbyte+80 + +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsfb.f b/pkg/tbtables/fitsio/ftgsfb.f new file mode 100644 index 00000000..365214cf --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsfb.f @@ -0,0 +1,142 @@ +C---------------------------------------------------------------------------- + subroutine ftgsfb(iunit,colnum,naxis,naxes,blc,trc,inc, + & array,flgval,anynul,status) + +C read a subsection of byte data values from an image or +C a table column. Returns an associated array of null value flags. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C array i array of data values that are read from the FITS file +C flgval l set to .true. if corresponding array element is undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + character*1 array(*),nulval + logical anynul,anyf,flgval(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFB ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=2 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSFB, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgclb(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),flgval(i1),anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsfd.f b/pkg/tbtables/fitsio/ftgsfd.f new file mode 100644 index 00000000..4bd9acbe --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsfd.f @@ -0,0 +1,142 @@ +C---------------------------------------------------------------------------- + subroutine ftgsfd(iunit,colnum,naxis,naxes,blc,trc,inc, + & array,flgval,anynul,status) + +C read a subsection of double precision data values from an image or +C a table column. Returns an associated array of null value flags. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C array i array of data values that are read from the FITS file +C flgval l set to .true. if corresponding array element is undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + double precision array(*),nulval + logical anynul,anyf,flgval(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFD ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=2 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSFD, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcld(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),flgval(i1),anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsfe.f b/pkg/tbtables/fitsio/ftgsfe.f new file mode 100644 index 00000000..d7cf71d4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsfe.f @@ -0,0 +1,142 @@ +C---------------------------------------------------------------------------- + subroutine ftgsfe(iunit,colnum,naxis,naxes,blc,trc,inc, + & array,flgval,anynul,status) + +C read a subsection of real data values from an image or +C a table column. Returns an associated array of null value flags. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C array i array of data values that are read from the FITS file +C flgval l set to .true. if corresponding array element is undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + real array(*),nulval + logical anynul,anyf,flgval(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFE ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=2 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSFE, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcle(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),flgval(i1),anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsfi.f b/pkg/tbtables/fitsio/ftgsfi.f new file mode 100644 index 00000000..7d106532 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsfi.f @@ -0,0 +1,142 @@ +C---------------------------------------------------------------------------- + subroutine ftgsfi(iunit,colnum,naxis,naxes,blc,trc,inc, + & array,flgval,anynul,status) + +C read a subsection of integer*2 data values from an image or +C a table column. Returns an associated array of null value flags. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C array i array of data values that are read from the FITS file +C flgval l set to .true. if corresponding array element is undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + integer*2 array(*),nulval + logical anynul,anyf,flgval(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFI ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=2 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSFI, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcli(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),flgval(i1),anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsfj.f b/pkg/tbtables/fitsio/ftgsfj.f new file mode 100644 index 00000000..f873ffb0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsfj.f @@ -0,0 +1,142 @@ +C---------------------------------------------------------------------------- + subroutine ftgsfj(iunit,colnum,naxis,naxes,blc,trc,inc, + & array,flgval,anynul,status) + +C read a subsection of integer*4 data values from an image or +C a table column. Returns an associated array of null value flags. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C array i array of data values that are read from the FITS file +C flgval l set to .true. if corresponding array element is undefined +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + integer array(*),nulval + logical anynul,anyf,flgval(*) + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSFJ ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=2 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSFJ, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgclj(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),flgval(i1),anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsvb.f b/pkg/tbtables/fitsio/ftgsvb.f new file mode 100644 index 00000000..2c4882cc --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsvb.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------------- + subroutine ftgsvb(iunit,colnum,naxis,naxes,blc,trc,inc, + & nulval,array,anynul,status) + +C read a subsection of byte data values from an image or +C a table column. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C nulval i value that undefined pixels will be set to +C array i array of data values that are read from the FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + character*1 array(*),nulval + logical anynul,anyf + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + logical ldummy + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVB ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=1 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSVB, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgclb(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),ldummy,anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsvd.f b/pkg/tbtables/fitsio/ftgsvd.f new file mode 100644 index 00000000..c7e1d30b --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsvd.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------------- + subroutine ftgsvd(iunit,colnum,naxis,naxes,blc,trc,inc, + & nulval,array,anynul,status) + +C read a subsection of double precision data values from an image or +C a table column. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C nulval i value that undefined pixels will be set to +C array i array of data values that are read from the FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + double precision array(*),nulval + logical anynul,anyf + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + logical ldummy + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVD ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=1 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSVD, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcld(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),ldummy,anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsve.f b/pkg/tbtables/fitsio/ftgsve.f new file mode 100644 index 00000000..c0024029 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsve.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------------- + subroutine ftgsve(iunit,colnum,naxis,naxes,blc,trc,inc, + & nulval,array,anynul,status) + +C read a subsection of real data values from an image or +C a table column. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C nulval i value that undefined pixels will be set to +C array i array of data values that are read from the FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + real array(*),nulval + logical anynul,anyf + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + logical ldummy + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVE ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=1 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSVE, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcle(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),ldummy,anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsvi.f b/pkg/tbtables/fitsio/ftgsvi.f new file mode 100644 index 00000000..a72beda6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsvi.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------------- + subroutine ftgsvi(iunit,colnum,naxis,naxes,blc,trc,inc, + & nulval,array,anynul,status) + +C read a subsection of integer*2 data values from an image or +C a table column. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C nulval i value that undefined pixels will be set to +C array i array of data values that are read from the FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + integer*2 array(*),nulval + logical anynul,anyf + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + logical ldummy + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVI ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=1 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSVI, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgcli(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),ldummy,anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgsvj.f b/pkg/tbtables/fitsio/ftgsvj.f new file mode 100644 index 00000000..b4f798e6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgsvj.f @@ -0,0 +1,143 @@ +C---------------------------------------------------------------------------- + subroutine ftgsvj(iunit,colnum,naxis,naxes,blc,trc,inc, + & nulval,array,anynul,status) + +C read a subsection of integer*4 data values from an image or +C a table column. + +C iunit i fortran unit number +C colnum i number of the column to read from +C naxis i number of dimensions in the FITS array +C naxes i size of each dimension. +C blc i 'bottom left corner' of the subsection to be read +C trc i 'top right corner' of the subsection to be read +C inc i increment to be applied in each dimension +C nulval i value that undefined pixels will be set to +C array i array of data values that are read from the FITS file +C anynul l set to .true. if any of the returned values are undefined +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1993 + + integer iunit,colnum,naxis,naxes(*),blc(*),trc(*),inc(*),status + integer array(*),nulval + logical anynul,anyf + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer i,i1,i2,i3,i4,i5,i6,i7,i8,i9,row,rstr,rstp,rinc + integer str(9),stp(9),incr(9),dsize(10) + integer felem,nelem,nultyp,ninc,ibuff,numcol + logical ldummy + character caxis*20 + +C this routine is set up to handle a maximum of nine dimensions + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 9)then + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTGSVJ ' + & //'is illegal.') + return + end if + +C if this is a primary array, then the input COLNUM parameter should +C be interpreted as the row number, and we will alway read the image +C data from column 2 (any group parameters are in column 1). + + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array, or image extension + if (colnum .eq. 0)then + rstr=1 + rstp=1 + else + rstr=colnum + rstp=colnum + end if + rinc=1 + numcol=2 + else +C this is a table, so the row info is in the (naxis+1) elements + rstr=blc(naxis+1) + rstp=trc(naxis+1) + rinc=inc(naxis+1) + numcol=colnum + end if + + nultyp=1 + anynul=.false. + i1=1 + do 5 i=1,9 + str(i)=1 + stp(i)=1 + incr(i)=1 + dsize(i)=1 +5 continue + do 10 i=1,naxis + if (trc(i) .lt. blc(i))then + status=321 + write(caxis,1001)i + call ftpmsg('In FTGSVJ, the range specified for axis '// + & caxis(19:20)//' has the start greater than the end.') + return + end if + str(i)=blc(i) + stp(i)=trc(i) + incr(i)=inc(i) + dsize(i+1)=dsize(i)*naxes(i) +10 continue + + if (naxis .eq. 1 .and. naxes(1) .eq. 1)then +C This is not a vector column, so read all the rows at once + nelem=(rstp-rstr)/rinc+1 + ninc=rinc + rstp=rstr + else +C have to read each row individually, in all dimensions + nelem=(stp(1)-str(1))/inc(1)+1 + ninc=incr(1) + end if + + do 100 row=rstr,rstp,rinc + do 90 i9=str(9),stp(9),incr(9) + do 80 i8=str(8),stp(8),incr(8) + do 70 i7=str(7),stp(7),incr(7) + do 60 i6=str(6),stp(6),incr(6) + do 50 i5=str(5),stp(5),incr(5) + do 40 i4=str(4),stp(4),incr(4) + do 30 i3=str(3),stp(3),incr(3) + do 20 i2=str(2),stp(2),incr(2) + + felem=str(1)+(i2-1)*dsize(2)+(i3-1)*dsize(3)+(i4-1)*dsize(4) + & +(i5-1)*dsize(5)+(i6-1)*dsize(6)+(i7-1)*dsize(7) + & +(i8-1)*dsize(8)+(i9-1)*dsize(9) + + call ftgclj(iunit,numcol,row,felem,nelem,ninc, + & nultyp,nulval,array(i1),ldummy,anyf,status) + if (status .gt. 0)return + if (anyf)anynul=.true. + i1=i1+nelem + +20 continue +30 continue +40 continue +50 continue +60 continue +70 continue +80 continue +90 continue +100 continue + end diff --git a/pkg/tbtables/fitsio/ftgtbb.f b/pkg/tbtables/fitsio/ftgtbb.f new file mode 100644 index 00000000..7651d71e --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbb.f @@ -0,0 +1,64 @@ +C---------------------------------------------------------------------- + subroutine ftgtbb(iunit,frow,fchar,nchars,value,status) + +C read a consecutive string of bytes from an ascii or binary +C table. This will span multiple rows of the table if NCHARS+FCHAR is +C greater than the length of a row. + +C iunit i fortran unit number +C frow i starting row number (1st row = 1) +C fchar i starting character/byte in the row to read (1st character=1) +C nchars i number of characters/bytes to read (can span multiple rows) +C value i returned string of bytes +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Dec 1991 + + integer iunit,frow,fchar,nchars,status + integer value(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check for errors + if (nchars .le. 0)then +C zero or negative number of character requested + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + return + else if (fchar .lt. 1)then +C error: illegal starting character + status=308 + return + end if + +C move the i/o pointer to the start of the sequence of characters + bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 + call ftmbyt(iunit,bstart,.false.,status) + +C get the string of bytes + call ftgbyt(iunit,nchars,value,status) + end diff --git a/pkg/tbtables/fitsio/ftgtbc.f b/pkg/tbtables/fitsio/ftgtbc.f new file mode 100644 index 00000000..c4f6307a --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbc.f @@ -0,0 +1,81 @@ +C---------------------------------------------------------------------- + subroutine ftgtbc(tfld,tdtype,trept,tbcol,lenrow,status) + +C Get Table Beginning Columns +C determine the byte offset of the beginning of each field of a +C binary table + +C tfld i number of fields in the binary table +C tdtype i array of numerical datatype codes of each column +C trept i array of repetition factors for each column +C OUTPUT PARAMETERS: +C tbcol i array giving the byte offset to the start of each column +C lenrow i total width of the table, in bytes +C status i returned error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C modified 6/17/92 to deal with ASCII column trept values measured +C in units of characters rather than in terms of number of repeated +C strings. + + integer tfld,tdtype(*),trept(*),tbcol(*),lenrow + integer status,i,nbytes + character ifld*4 + + if (status .gt. 0)return + +C the first column always begins at the first byte of the row: + tbcol(1)=0 + + do 100 i=1,tfld-1 + if (tdtype(i) .eq. 16)then +C ASCII field; each character is 1 byte + nbytes=1 + else if (tdtype(i) .gt. 0)then + nbytes=tdtype(i)/10 + else if (tdtype(i) .eq. 0)then +C error: data type of column not defined! (no TFORM keyword) + status=232 + write(ifld,1000)i +1000 format(i4) + call ftpmsg('Field'//ifld//' of the binary'// + & ' table has no TFORMn keyword') + return + else +C this is a descriptor field: 2J + nbytes=8 + end if + + if (nbytes .eq. 0)then +C this is a bit array + tbcol(i+1)=tbcol(i)+(trept(i)+7)/8 + else + tbcol(i+1)=tbcol(i)+trept(i)*nbytes + end if +100 continue + +C determine the total row width + if (tdtype(tfld) .eq. 16)then +C ASCII field; each character is 1 byte + nbytes=1 + else if (tdtype(tfld) .gt. 0)then + nbytes=tdtype(tfld)/10 + else if (tdtype(i) .eq. 0)then +C error: data type of column not defined! (no TFORM keyword) + status=232 + write(ifld,1000)tfld + call ftpmsg('Field'//ifld//' of the binary'// + & ' table is missing required TFORMn keyword.') + return + else +C this is a descriptor field: 2J + nbytes=8 + end if + if (nbytes .eq. 0)then +C this is a bit array + lenrow=tbcol(tfld)+(trept(tfld)+7)/8 + else + lenrow=tbcol(tfld)+trept(tfld)*nbytes + end if + + end diff --git a/pkg/tbtables/fitsio/ftgtbh.f b/pkg/tbtables/fitsio/ftgtbh.f new file mode 100644 index 00000000..a07e29e6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbh.f @@ -0,0 +1,12 @@ +C---------------------------------------------------------------------- + subroutine ftgtbh(iunit,ncols,nrows,nfield,ttype,tbcol, + & tform,tunit,extnam,status) + +C OBSOLETE routine: should call ftghtb instead + + integer iunit,ncols,nrows,nfield,status,tbcol(*) + character*(*) ttype(*),tform(*),tunit(*),extnam + + call ftghtb(iunit,0,ncols,nrows,nfield,ttype, + & tbcol,tform,tunit,extnam,status) + end diff --git a/pkg/tbtables/fitsio/ftgtbn.f b/pkg/tbtables/fitsio/ftgtbn.f new file mode 100644 index 00000000..cf3c73bc --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbn.f @@ -0,0 +1,123 @@ +C---------------------------------------------------------------------- + subroutine ftgtbn(iunit,ncols,nrows,pcount,nfield,status) + +C check that this is a valid binary table and get parameters +C +C iunit i Fortran i/o unit number +C ncols i width of each row of the table, in bytes +C nrows i number of rows in the table +C pcount i size of special data area following the table (usually = 0) +C nfield i number of fields in the table +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,ncols,nrows,nfield,pcount,status + character keynam*8,value*10,comm*8,rec*80 + + if (status .gt. 0)return + +C check for correct type of extension + call ftgrec(iunit,1,rec,status) + if (status .gt. 0)go to 900 + + keynam=rec(1:8) + + if (keynam .eq. 'XTENSION')then + call ftpsvc(rec,value,comm,status) + if (status .gt. 0)go to 900 + + if (value(2:9) .ne. 'BINTABLE' .and. + & value(2:9) .ne. 'A3DTABLE' .and. + & value(2:9) .ne. '3DTABLE ')then +C this is not a binary table extension + status=227 + go to 900 + end if + else + status=225 + go to 900 + end if + +C check that the second keyword is BITPIX = 8 + call fttkyn(iunit,2,'BITPIX','8',status) + if (status .eq. 208)then +C BITPIX keyword not found + status=222 + else if (status .eq. 209)then +C illegal value of BITPIX + status=211 + end if + if (status .gt. 0)go to 900 + +C check that the third keyword is NAXIS = 2 + call fttkyn(iunit,3,'NAXIS','2',status) + if (status .eq. 208)then +C NAXIS keyword not found + status=223 + else if (status .eq. 209)then +C illegal NAXIS value + status=212 + end if + if (status .gt. 0)go to 900 + +C check that the 4th keyword is NAXIS1 and get it's value + call ftgtkn(iunit,4,'NAXIS1',ncols,status) + if (status .eq. 208)then +C NAXIS1 keyword not found + status=224 + else if (status .eq. 209)then +C illegal value of NAXISnnn + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 5th keyword is NAXIS2 and get it's value + call ftgtkn(iunit,5,'NAXIS2',nrows,status) + if (status .eq. 208)then +C NAXIS2 keyword not found + status=224 + else if (status .eq. 209)then +C illegal value of NAXISnnn + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 6th keyword is PCOUNT and get it's value + call ftgtkn(iunit,6,'PCOUNT',pcount,status) + if (status .eq. 208)then +C PCOUNT keyword not found + status=228 + else if (status .eq. 209)then +C illegal PCOUNT value + status=214 + end if + if (status .gt. 0)go to 900 + +C check that the 7th keyword is GCOUNT = 1 + call fttkyn(iunit,7,'GCOUNT','1',status) + if (status .eq. 208)then +C GCOUNT keyword not found + status=229 + else if (status .eq. 209)then +C illegal value of GCOUNT + status=215 + end if + if (status .gt. 0)go to 900 + +C check that the 8th keyword is TFIELDS and get it's value + call ftgtkn(iunit,8,'TFIELDS',nfield,status) + if (status .eq. 208)then +C TFIELDS keyword not found + status=230 + else if (status .eq. 209)then +C illegal value of TFIELDS + status=216 + end if + +900 continue + if (status .gt. 0)then + call ftpmsg('Failed to parse the required keywords in '// + & 'the binary BINTABLE header (FTGTTB).') + end if + end diff --git a/pkg/tbtables/fitsio/ftgtbs.f b/pkg/tbtables/fitsio/ftgtbs.f new file mode 100644 index 00000000..2a659b66 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtbs.f @@ -0,0 +1,71 @@ +C---------------------------------------------------------------------- + subroutine ftgtbs(iunit,frow,fchar,nchars,svalue,status) + +C read a consecutive string of characters from an ascii or binary +C table. This will span multiple rows of the table if NCHARS+FCHAR is +C greater than the length of a row. + +C iunit i fortran unit number +C frow i starting row number (1st row = 1) +C fchar i starting character/byte in the row to read (1st character=1) +C nchars i number of characters/bytes to read (can span multiple rows) +C svalue c returned string of characters +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,frow,fchar,nchars,status + character*(*) svalue + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart,nget + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check for errors + if (nchars .le. 0)then +C zero or negative number of character requested + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + return + else if (fchar .lt. 1)then +C error: illegal starting character + status=308 + return + end if + +C move the i/o pointer to the start of the sequence of characters + bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 + call ftmbyt(iunit,bstart,.false.,status) + +C get the string of characters, (up to the length of the input string) + if (len(svalue) .ne. 1)then + svalue=' ' + nget=min(nchars,len(svalue)) + else +C assume svalue was dimensioned as: character*1 svalue(nchars) + nget=nchars + end if + call ftgcbf(iunit,1,nget,svalue,status) + end diff --git a/pkg/tbtables/fitsio/ftgtcl.f b/pkg/tbtables/fitsio/ftgtcl.f new file mode 100644 index 00000000..cbc680a1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtcl.f @@ -0,0 +1,64 @@ +C-------------------------------------------------------------------------- + subroutine ftgtcl(iunit,colnum,datcod,repeat,width,status) + +C get the datatype of the column, as well as the vector +C repeat count and (if it is an ASCII character column) the +C width of a unit string within the column. This supports the +C TFORMn = 'rAw' syntax for specifying arrays of substrings. + + +C iunit i Fortran i/o unit number +C colnum i number of the column (first column = 1) + +C datcod i returned datatype code +C repeat i number of elements in the vector column +C width i width of unit string in character columns +C status i returned error status +C +C written by Wm Pence, HEASARC/GSFC, November 1994 + + integer iunit,colnum,datcod,repeat,width,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS------------------------------------ + + integer ibuff,dummy + character keywrd*8,tform*24,comm*20 + + if (status .gt. 0)return + +C construct the keyword name + call ftkeyn('TFORM',colnum,keywrd,status) + +C get the keyword value + call ftgkys(iunit,keywrd,tform,comm,status) + if (status .gt. 0)then + call ftpmsg('Could not read the '//keywrd//' keyword.') + return + end if + +C parse the keyword value + ibuff=bufnum(iunit) + if (hdutyp(ibuff) .eq. 1)then +C this is an ASCII table + repeat=1 + call ftasfm(tform,datcod,width,dummy,status) + + else if (hdutyp(ibuff) .eq. 2)then +C this is a binary table + call ftbnfm(tform,datcod,repeat,width,status) + + else +C error: this HDU is not a table + status=235 + return + end if + end diff --git a/pkg/tbtables/fitsio/ftgtcs.f b/pkg/tbtables/fitsio/ftgtcs.f new file mode 100644 index 00000000..09e78618 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtcs.f @@ -0,0 +1,53 @@ +C------------------------------------------------------------------------------ + subroutine ftgtcs(iunit,xcol,ycol,xrval,yrval,xrpix,yrpix, + & xinc,yinc,rot,type,status) + +C read the values of the celestial coordinate system keywords +C from a FITS table where the X and Y or RA and DEC coordinates +C are stored in separate column. +C +C These values may be used as input to the subroutines that +C calculate celestial coordinates. (FTXYPX, FTWLDP) + +C xcol (integer) number of the column containing the RA type coordinate +C ycol (integer) number of the column containing the DEC type coordinate + + double precision xrval,yrval,xrpix,yrpix,xinc,yinc,rot + integer iunit,xcol,ycol,status + character*(*) type + character comm*20,ctype*8,keynam*8,xnum*3,ynum*3 + + if (status .gt. 0)return + + call ftkeyn('TCRVL',xcol,keynam,status) + xnum=keynam(6:8) + call ftgkyd(iunit,keynam,xrval,comm,status) + + call ftkeyn('TCRVL',ycol,keynam,status) + ynum=keynam(6:8) + call ftgkyd(iunit,keynam,yrval,comm,status) + + keynam='TCRPX'//xnum + call ftgkyd(iunit,keynam,xrpix,comm,status) + keynam='TCRPX'//ynum + call ftgkyd(iunit,keynam,yrpix,comm,status) + + keynam='TCDLT'//xnum + call ftgkyd(iunit,keynam,xinc,comm,status) + keynam='TCDLT'//ynum + call ftgkyd(iunit,keynam,yinc,comm,status) + + keynam='TCTYP'//xnum + call ftgkys(iunit,keynam,ctype,comm,status) + + if (status .gt. 0)then + call ftpmsg('FTGTCS could not find all the required'// + & ' celestial coordinate Keywords.') + status=505 + return + end if + + type=ctype(5:8) + + rot=0. + end diff --git a/pkg/tbtables/fitsio/ftgtdm.f b/pkg/tbtables/fitsio/ftgtdm.f new file mode 100644 index 00000000..49230faa --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtdm.f @@ -0,0 +1,99 @@ +C---------------------------------------------------------------------- + subroutine ftgtdm(iunit,colnum,maxdim,naxis,naxes,status) + +C parse the TDIMnnn keyword to get the dimensionality of a column + +C iunit i fortran unit number to use for reading +C colnum i column number to read +C maxdim i maximum no. of dimensions to read; dimension of naxes +C OUTPUT PARAMETERS: +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, October 1993 + + integer iunit,colnum,maxdim,naxis,naxes(*),status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,nfound,c1,c2,clast,dimval + logical last + character*120 tdim + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + + if (colnum .lt. 1 .or. colnum .gt. tfield(ibuff))then +C illegal column number + status=302 + return + end if + + nfound=0 +C try getting the TDIM keyword value + call ftgkns(iunit,'TDIM',colnum,1,tdim,nfound,status) + + if (nfound .ne. 1)then +C no TDIM keyword found + naxis=1 + naxes(1)=trept(colnum+tstart(ibuff)) + return + end if + + naxis=0 +C first, find the opening ( and closing ) + c1=index(tdim,'(')+1 + c2=index(tdim,')')-1 + if (c1 .eq. 1 .or. c2 .eq. -1)go to 900 + + last=.false. +C find first non-blank character +10 if (tdim(c1:c1) .ne. ' ')go to 20 + c1=c1+1 + go to 10 + +C find the comma separating the dimension sizes +20 clast=index(tdim(c1:c2),',')+c1-2 + if (clast .eq. c1-2)then + last=.true. + clast=c2 + end if + +C read the string of characters as the (integer) dimension size + call ftc2ii(tdim(c1:clast),dimval,status) + if (status .gt. 0)then + call ftpmsg('Error in FTGTDM parsing dimension string: ' + & //tdim) + go to 900 + end if + + naxis=naxis+1 + if (naxis .le. maxdim)naxes(naxis)=dimval + + if (last)return + + c1=clast+2 + go to 10 + +C could not parse the tdim value +900 status=263 + end diff --git a/pkg/tbtables/fitsio/ftgthd.f b/pkg/tbtables/fitsio/ftgthd.f new file mode 100644 index 00000000..ee4a3aa6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgthd.f @@ -0,0 +1,297 @@ +C-------------------------------------------------------------------------- + subroutine ftgthd(tmplat,card,hdtype,status) + +C 'Get Template HeaDer' +C parse a template header line and create a formated +C 80-character string which is suitable for appending to a FITS header + +C tmplat c input header template string +C card c returned 80-character string = FITS header record +C hdtype i type of operation that should be applied to this keyword: +C -2 = modify the name of a keyword; the new name +C is returned in characters 41:48 of CARD. +C -1 = delete this keyword +C 0 = append (if it doesn't already exist) or +C overwrite this keyword (if it does exist) +C 1 = append this comment keyword ('HISTORY', +C 'COMMENT', or blank keyword name) +C 2 = this is an END record; do not append it +C to a FITS header! +C status i returned error status +C if a positive error status is returned then the first +C 80 characters of the offending input line are returned +C by the CARD parameter + + integer hdtype,status,tstat + character*(*) tmplat + character*80 card + integer i1,i2,com1,strend,length + character inline*100,keynam*8,ctemp*80,qc*1 + logical number + double precision dvalue + + if (status .gt. 0)return + card=' ' + hdtype=0 + + inline=tmplat + +C test if columns 1-8 are blank; if so, this is a FITS comment record; +C just copy it verbatim to the FITS header + if (inline(1:8) .eq. ' ')then + card=inline(1:80) + go to 999 + end if + +C parse the keyword name = the first token separated by a space or a '=' +C 1st locate the first nonblank character (we know it is not all blank): + i1=0 +20 i1=i1+1 +C test for a leading minus sign which flags name of keywords to be deleted + if (inline(i1:i1) .eq. '-')then + hdtype=-1 +C test for a blank keyword name + if (inline(i1+1:i1+8) .eq. ' ')then + card=' ' + i2=i1+9 + go to 35 + end if + go to 20 + else if (inline(i1:i1) .eq. ' ')then + go to 20 + end if + +C now find the last character of the keyword name + i2=i1 +30 i2=i2+1 + if (inline(i2:i2) .ne. ' ' .and. inline(i2:i2) .ne. '=')go to 30 + +C test for legal keyword name length (max 8 characters) + if (i2-i1 .gt. 8)then + status=207 + card=inline(1:80) + go to 999 + end if + + keynam=inline(i1:i2-1) + +C convert to upper case and test for illegal characters in keyword name + call ftupch(keynam) + call fttkey(keynam,status) + if (status .gt. 0)then + card=inline(1:80) + go to 999 + end if + +C if this is the 'END' then this is the end of the input file + if (keynam .eq. 'END ')goto 998 + +C copy the keyword name to the output record string + card(1:8)=keynam + +C jump if this is just the name of keyword to be deleted + if (hdtype .lt. 0)go to 35 + +C test if this is a COMMENT or HISTORY record + if (keynam .eq. 'COMMENT' .or. keynam .eq. 'HISTORY')then +C append next 72 characters from input line to output record + card(9:80)=inline(i2:) + hdtype=1 + go to 999 + else +C this keyword must have a value, so append the '= ' to output + card(9:10)='= ' + end if + +C now locate the value token in the input line. If it includes +C embedded spaces it must be enclosed in single quotes. The value must +C be separated by at least one blank space from the comment string + +C find the first character of the value string +35 i1=i2-1 +40 i1=i1+1 + if (i1 .gt. 100)then +C no value is present in the input line + if (hdtype .lt. 0)then +C this is normal; just quit + go to 999 + else + status=204 + card=inline(1:80) + go to 999 + end if + end if + if (hdtype .lt. 0 .and. inline(i1:i1) .eq. '=')then +C The leading minus sign, plus the presence of an equal sign +C between the first 2 tokens is taken to mean that the +C keyword with the first token name is to be deleted. + go to 999 + else if (inline(i1:i1).eq. ' ' .or.inline(i1:i1).eq. '=')then + go to 40 + end if + +C is the value a quoted string? + if (inline(i1:i1) .eq. '''')then +C find the closing quote + i2=i1 +50 i2=i2+1 + if (i2 .gt. 100)then +C error: no closing quote on value string + status=205 + card=inline(1:80) + call ftpmsg('Keyword value string has no closing quote:') + call ftpmsg(card) + go to 999 + end if + if (inline(i2:i2) .eq. '''')then + if (inline(i2+1:i2+1) .eq. '''')then +C ignore 2 adjacent single quotes + i2=i2+1 + go to 50 + end if + else + go to 50 + end if +C value string can't be more than 70 characters long (cols 11-80) + length=i2-i1 + if (length .gt. 69)then + status=205 + card=inline(1:80) + call ftpmsg('Keyword value string is too long:') + call ftpmsg(card) + go to 999 + end if + +C append value string to output, left justified in column 11 + card(11:11+length)=inline(i1:i2) +C com1 is the starting position for the comment string + com1=max(32,13+length) + +C FITS string must be at least 8 characters long + if (length .lt. 9)then + card(11+length:11+length)=' ' + card(20:20)='''' + end if + else +C find the end of the value field + i2=i1 +60 i2=i2+1 + if (i2 .gt. 100)then +C error: value string is too long + status=205 + card=inline(1:80) + call ftpmsg('Keyword value string is too long:') + call ftpmsg(card) + go to 999 + end if + if (inline(i2:i2) .ne. ' ')go to 60 + +C test if this is a logical value + length=i2-i1 + if (length .eq. 1 .and. (inline(i1:i1) .eq. 'T' + & .or. inline(i1:i1) .eq. 'F'))then + card(30:30)=inline(i1:i1) + com1=32 + else +C test if this is a numeric value; try reading it as +C double precision value; if it fails, it must be a string + number=.true. + tstat=status + call ftc2dd(inline(i1:i2-1),dvalue,status) + if (status .gt. 0)then + status=tstat + number=.false. + else +C check the first character to make sure this is a number +C since certain non-numeric character strings pass the +C above test on SUN machines. + qc=inline(i1:i1) + if (qc .ne. '+' .and. qc .ne. '-' .and. qc .ne. + & '.' .and. (qc .lt. '0' .or. qc .gt. '9'))then +C This really was not a number! + number=.false. + end if + end if + + if (number)then + if (length .le. 20)then +C write the value right justified in col 30 + card(31-length:30)=inline(i1:i2-1) + com1=32 + else +C write the long value left justified in col 11 + card(11:10+length)=inline(i1:i2-1) + com1=max(32,12+length) + end if + else +C value is a character string datatype + card(11:11)='''' + strend=11+length + card(12:strend)=inline(i1:i2-1) +C need to expand any embedded single quotes into 2 quotes + i1=11 +70 i1=i1+1 + if (i1 .gt. strend) go to 80 + if (card(i1:i1) .eq. '''')then + i1=i1+1 + if (card(i1:i1) .ne. '''')then +C have to insert a 2nd quote into string + ctemp=card(i1:strend) + card(i1:i1)='''' + strend=strend+1 + i1=i1+1 + card(i1:strend)=ctemp + end if + end if + go to 70 + +80 strend=max(20,strend+1) + card(strend:strend)='''' + com1=max(32,strend+2) + end if + end if + end if + +C check if this was a request to modify a keyword name + if (hdtype .eq. -1)then + hdtype = -2 +C the keyword value is really the new keyword name +C return the new name in characters 41:48 of the output card + keynam=card(12:19) +C convert to upper case and test for illegal characters in name + call ftupch(keynam) + call fttkey(keynam,status) + if (status .gt. 0)then + card=inline(1:80) + go to 999 + else + card(9:80)=' ' + card(41:48)=keynam + go to 999 + end if + end if + +C is there room for a comment string? + if (com1 .lt. 79)then +C now look for the beginning of the comment string + i1=i2 +90 i1=i1+1 +C if no comment field then just quit + if (i1 .gt. 100)go to 999 + if (inline(i1:i1) .eq. ' ')go to 90 + +C append the comment field + if (inline(i1:i1) .eq. '/')then + card(com1:80)=inline(i1:) + else + card(com1:80)='/ '//inline(i1:) + end if + end if + + go to 999 + +C end of input file was detected +998 hdtype=2 + +999 continue + end diff --git a/pkg/tbtables/fitsio/ftgtkn.f b/pkg/tbtables/fitsio/ftgtkn.f new file mode 100644 index 00000000..83ddbac5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftgtkn.f @@ -0,0 +1,64 @@ +C-------------------------------------------------------------------------- + subroutine ftgtkn(iunit,nkey,keynam,ival,status) + +C test that keyword number NKEY has name = KEYNAM and get the +C integer value of the keyword. Return an error if the keyword +C name does not match the input KEYNAM, or if the value of the +C keyword is not a positive integer. +C +C iunit i Fortran I/O unit number +C nkey i sequence number of the keyword to test +C keynam c name that the keyword is supposed to have +C OUTPUT PARAMETERS: +C ival i returned value of the integer keyword +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C + integer iunit,nkey,status,ival + character*(*) keynam + character kname*8,value*30,comm*48,npos*8,keybuf*80 + + if (status .gt. 0)return + +C read the name and value of the keyword + call ftgrec(iunit,nkey,keybuf,status) + + kname=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + +C test if the keyword has the correct name + if (kname .ne. keynam)then + status=208 + go to 900 + end if + +C convert character string to integer + call ftc2ii(value,ival,status) + if (status .gt. 0 .or. ival .lt. 0 )then +C keyword value must be zero or positive integer + status=209 + end if + +900 continue + + if (status .gt. 0)then + write(npos,1000)nkey +1000 format(i8) + call ftpmsg('FTGTKN found unexpected keyword or value '// + & 'for header keyword number '//npos//'.') + call ftpmsg(' Was expecting positive integer keyword '// + & keynam(1:8)) + if (keybuf(9:10) .ne. '= ')then + call ftpmsg(' but found the keyword '//kname// + & ' with no value field (no "= " in cols. 9-10).') + else + call ftpmsg(' but instead found keyword = '//kname// + & ' with value = '//value) + end if + call ftpmsg(keybuf) + end if + end diff --git a/pkg/tbtables/fitsio/ftgttb.f b/pkg/tbtables/fitsio/ftgttb.f new file mode 100644 index 00000000..e675cc6a --- /dev/null +++ b/pkg/tbtables/fitsio/ftgttb.f @@ -0,0 +1,127 @@ +C---------------------------------------------------------------------- + subroutine ftgttb(iunit,ncols,nrows,nfield,status) + +C test that this is a legal ASCII table, and get some keywords +C +C iunit i Fortran i/o unit number +C OUTPUT PARAMETERS: +C ncols i number of columns in the table +C nrows i number of rows in the table +C nfield i number of fields in the table +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,ncols,nrows,nfield,status + character keynam*8,value*10,comm*8,keybuf*80 + + if (status .gt. 0)return + +C check for correct type of extension + call ftgrec(iunit,1,keybuf,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + + if (status .gt. 0)go to 900 + + if (keynam .eq. 'XTENSION')then + if (value(2:9) .ne. 'TABLE ')then +C this is not a ASCII table extension + status=226 + call ftpmsg('Was expecting an ASCII table; instead got '// + & 'XTENSION= '//value) + call ftpmsg(keybuf) + go to 900 + end if + else + status=225 + call ftpmsg('First keyword of extension was not XTENSION:'// + & keynam) + call ftpmsg(keybuf) + go to 900 + end if + +C check that the second keyword is BITPIX = 8 + call fttkyn(iunit,2,'BITPIX','8',status) + if (status .eq. 208)then +C BITPIX keyword not found + status=222 + else if (status .eq. 209)then +C illegal value of BITPIX + status=211 + end if + if (status .gt. 0)go to 900 + +C check that the third keyword is NAXIS = 2 + call fttkyn(iunit,3,'NAXIS','2',status) + if (status .eq. 208)then +C NAXIS keyword not found + status=223 + else if (status .eq. 209)then +C illegal value of NAXIS + status=212 + end if + if (status .gt. 0)go to 900 + +C check that the 4th keyword is NAXIS1 and get it's value + call ftgtkn(iunit,4,'NAXIS1',ncols,status) + if (status .eq. 208)then +C NAXIS1 keyword not found + status=224 + else if (status .eq. 209)then +C illegal NAXIS1 value + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 5th keyword is NAXIS2 and get it's value + call ftgtkn(iunit,5,'NAXIS2',nrows,status) + if (status .eq. 208)then +C NAXIS2 keyword not found + status=224 + else if (status .eq. 209)then +C illegal NAXIS2 value + status=213 + end if + if (status .gt. 0)go to 900 + +C check that the 6th keyword is PCOUNT = 0 + call fttkyn(iunit,6,'PCOUNT','0',status) + if (status .eq. 208)then +C PCOUNT keyword not found + status=228 + else if (status .eq. 209)then +C illegal PCOUNT value + status=214 + end if + if (status .gt. 0)go to 900 + +C check that the 7th keyword is GCOUNT = 1 + call fttkyn(iunit,7,'GCOUNT','1',status) + if (status .eq. 208)then +C GCOUNT keyword not found + status=229 + else if (status .eq. 209)then +C illegal value of GCOUNT + status=215 + end if + if (status .gt. 0)go to 900 + +C check that the 8th keyword is TFIELDS + call ftgtkn(iunit,8,'TFIELDS',nfield,status) + if (status .eq. 208)then +C TFIELDS keyword not found + status=230 + else if (status .eq. 209)then +C illegal value of TFIELDS + status=216 + end if + +900 continue + if (status .gt. 0)then + call ftpmsg('Failed to parse the required keywords in '// + & 'the ASCII TABLE header (FTGTTB).') + end if + end diff --git a/pkg/tbtables/fitsio/fthdef.f b/pkg/tbtables/fitsio/fthdef.f new file mode 100644 index 00000000..2a0b5fe1 --- /dev/null +++ b/pkg/tbtables/fitsio/fthdef.f @@ -0,0 +1,40 @@ +C-------------------------------------------------------------------------- + subroutine fthdef(ounit,moreky,status) + +C Header DEFinition +C define the size of the current header unit; this simply lets +C us determine where the data unit will start +C +C ounit i Fortran I/O unit number +C moreky i number of additional keywords to reserve space for +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,moreky,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,mkeys + + if (status .gt. 0)return + +C based on the number of keywords which have already been written, +C plus the number of keywords to reserve space for, we then can +C define where the data unit should start (it must start at the +C beginning of a 2880-byte logical block). + + ibuff=bufnum(ounit) + + mkeys=max(moreky,0) + dtstrt(ibuff)=((hdend(ibuff)+mkeys*80)/2880+1)*2880 + end diff --git a/pkg/tbtables/fitsio/fthpdn.f b/pkg/tbtables/fitsio/fthpdn.f new file mode 100644 index 00000000..d95f092b --- /dev/null +++ b/pkg/tbtables/fitsio/fthpdn.f @@ -0,0 +1,92 @@ +C-------------------------------------------------------------------------- + subroutine fthpdn(ounit,nbytes,status) + +C shift the binary table heap down by nbyte bytes + +C ounit i fortran output unit number +C nbytes i number of bytes by which to move the heap +C status i returned error status (0=ok) + + integer ounit,nbytes,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer i,ibuff,ntodo,jpoint,nchar,tstat + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + if (scount(ibuff) .gt. 0)then + ntodo=scount(ibuff) + +C set pointer to the end of the heap + jpoint=dtstrt(ibuff)+theap(ibuff)+scount(ibuff) + +10 nchar=min(ntodo,5760) + jpoint=jpoint-nchar + +C move to the read start position + call ftmbyt(ounit,jpoint,.false.,status) + +C read the heap + call ftgcbf(ounit,0,nchar,buff,status) + +C move forward to the write start postion + call ftmbyt(ounit,jpoint+nbytes,.true.,status) + +C write the heap + call ftpcbf(ounit,0,nchar,buff,status) + +C check for error + if (status .gt. 0)then + call ftpmsg('Error while moving heap down (FTDNHP)') + return + end if + +C check for more data in the heap + ntodo=ntodo-nchar + if (ntodo .gt. 0)go to 10 + +C now overwrite the old fill data with zeros + do 20 i=1,5760 + buff(i)=char(0) +20 continue + + jpoint=dtstrt(ibuff)+theap(ibuff) + call ftmbyt(ounit,jpoint,.false.,status) + + ntodo=nbytes +30 nchar=min(ntodo,5760) + call ftpcbf(ounit,0,nchar,buff,status) + ntodo=ntodo-nchar + if (ntodo .gt. 0)go to 30 + end if + +C update the heap starting address + theap(ibuff)=theap(ibuff)+nbytes + +C try updating the keyword value, if it exists + tstat=status + call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) + if (status .eq. 202)status=tstat + end diff --git a/pkg/tbtables/fitsio/fthpup.f b/pkg/tbtables/fitsio/fthpup.f new file mode 100644 index 00000000..6a1ac11a --- /dev/null +++ b/pkg/tbtables/fitsio/fthpup.f @@ -0,0 +1,92 @@ +C-------------------------------------------------------------------------- + subroutine fthpup(ounit,nbytes,status) + +C shift the binary table heap up by nbytes bytes + +C ounit i fortran output unit number +C nbytes i number of bytes by which to move the heap +C status i returned error status (0=ok) + + integer ounit,nbytes,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer i,ibuff,ntodo,jpoint,nchar,tstat + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + if (scount(ibuff) .gt. 0)then + ntodo=scount(ibuff) + +C set pointer to the start of the heap + jpoint=dtstrt(ibuff)+theap(ibuff) + +10 nchar=min(ntodo,5760) + +C move to the read start position + call ftmbyt(ounit,jpoint,.false.,status) + +C read the heap + call ftgcbf(ounit,0,nchar,buff,status) + +C move back to the write start postion + call ftmbyt(ounit,jpoint-nbytes,.false.,status) + +C write the heap + call ftpcbf(ounit,0,nchar,buff,status) + +C check for error + if (status .gt. 0)then + call ftpmsg('Error while moving heap up (FTUPHP)') + return + end if + +C check for more data in the heap + ntodo=ntodo-nchar + jpoint=jpoint+nchar + if (ntodo .gt. 0)go to 10 + +C now overwrite the old fill data with zeros + do 20 i=1,5760 + buff(i)=char(0) +20 continue + + jpoint=dtstrt(ibuff)+theap(ibuff)+scount(ibuff)-nbytes + call ftmbyt(ounit,jpoint,.false.,status) + + ntodo=nbytes +30 nchar=min(ntodo,5760) + call ftpcbf(ounit,0,nchar,buff,status) + ntodo=ntodo-nchar + if (ntodo .gt. 0)go to 30 + end if + +C update the heap starting address + theap(ibuff)=theap(ibuff)-nbytes + +C try updating the keyword value, if it exists + tstat=status + call ftmkyj(ounit,'THEAP',theap(ibuff),'&',status) + if (status .eq. 202)status=tstat + end diff --git a/pkg/tbtables/fitsio/fti1i1.f b/pkg/tbtables/fitsio/fti1i1.f new file mode 100644 index 00000000..ba2f70a5 --- /dev/null +++ b/pkg/tbtables/fitsio/fti1i1.f @@ -0,0 +1,129 @@ +C---------------------------------------------------------------------- + subroutine fti1i1(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output i*1 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval c*1 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + character*1 input(*),chkval + character*1 output(*),setval + integer n,i,chktyp,status,itemp + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=(itemp-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti1i2.f b/pkg/tbtables/fitsio/fti1i2.f new file mode 100644 index 00000000..b7a2df09 --- /dev/null +++ b/pkg/tbtables/fitsio/fti1i2.f @@ -0,0 +1,140 @@ +C---------------------------------------------------------------------- + subroutine fti1i2(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output i*2 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval i*2 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i*2 returned array of values +C status i output error status (0 = ok) + + character*1 input(*),chkval + integer*2 output(*),setval,mini2,maxi2 + integer n,i,chktyp,status,itemp + double precision scale,zero,dval,i2max,i2min + logical tofits,flgray(*),anynul,noscal + + parameter (maxi2=32767) + parameter (mini2=-32768) + parameter (i2max=3.276749D+04) + parameter (i2min=-3.276849D+04) + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=(itemp-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti1i4.f b/pkg/tbtables/fitsio/fti1i4.f new file mode 100644 index 00000000..12b26153 --- /dev/null +++ b/pkg/tbtables/fitsio/fti1i4.f @@ -0,0 +1,141 @@ +C---------------------------------------------------------------------- + subroutine fti1i4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output i*4 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval i value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i returned array of values +C status i output error status (0 = ok) + + character*1 input(*),chkval + integer output(*),setval + integer n,i,chktyp,status,itemp + double precision scale,zero,dval,i4max,i4min + logical tofits,flgray(*),anynul,noscal + parameter (i4max=2.14748364749D+09) + parameter (i4min=-2.14748364849D+09) + integer maxi4,mini4 + parameter (maxi4=2147483647) +C work around for bug in the DEC Alpha VMS compiler + mini4=-2147483647 - 1 + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=(itemp-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + dval=itemp*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti1r4.f b/pkg/tbtables/fitsio/fti1r4.f new file mode 100644 index 00000000..a94cc551 --- /dev/null +++ b/pkg/tbtables/fitsio/fti1r4.f @@ -0,0 +1,104 @@ +C---------------------------------------------------------------------- + subroutine fti1r4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output r*4 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output r returned array of values + + character*1 input(*),chkval + real output(*),setval + integer n,i,chktyp,status,itemp + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=(itemp-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti1r8.f b/pkg/tbtables/fitsio/fti1r8.f new file mode 100644 index 00000000..7e0cdd5a --- /dev/null +++ b/pkg/tbtables/fitsio/fti1r8.f @@ -0,0 +1,104 @@ +C---------------------------------------------------------------------- + subroutine fti1r8(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*1 values to output r*8 values, doing optional +C scaling and checking for null values + +C input c*1 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval c*1 value in the input array that is used to indicated nulls +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output d returned array of values + + character*1 input(*),chkval + double precision output(*),setval + integer n,i,chktyp,status,itemp + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +10 continue + else + do 20 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=(itemp-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp +30 continue + else + do 40 i=1,n + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + itemp=ichar(input(i)) + if (itemp .lt. 0)itemp=itemp+256 + output(i)=itemp*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti2c.f b/pkg/tbtables/fitsio/fti2c.f new file mode 100644 index 00000000..7ab4ac52 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2c.f @@ -0,0 +1,15 @@ +C---------------------------------------------------------------------- + subroutine fti2c(ival,cval,status) +C convert an integer value to a C*20 character string, right justified + integer ival,status + character*20 cval + + if (status .gt. 0)return + + write(cval,1000,err=900)ival +1000 format(i20) + if (cval(1:1) .eq. '*')go to 900 + return +900 status=401 + call ftpmsg('Error in FTI2C converting integer to C*20 string.') + end diff --git a/pkg/tbtables/fitsio/fti2i1.f b/pkg/tbtables/fitsio/fti2i1.f new file mode 100644 index 00000000..6555f168 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2i1.f @@ -0,0 +1,156 @@ +C---------------------------------------------------------------------- + subroutine fti2i1(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*2 values to output i*1 values, doing optional +C scaling and checking for null values + +C input i*2 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i*2 value in the input array that is used to indicated nulls +C setval c*1 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + integer*2 input(*),chkval + character*1 output(*),setval + integer n,i,chktyp,itemp,status + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C have to use a temporary variable because of IBM mainframe + itemp=input(i) +C trap any values that overflow the I*1 range + if (itemp.le. 255 .and. itemp.ge. 0)then + output(i)=char(itemp) + else if (itemp .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C have to use a temporary variable because of IBM mainframe + itemp=input(i) +C trap any values that overflow the I*1 range + if (itemp.le. 255 .and. itemp.ge. 0)then + output(i)=char(itemp) + else if (itemp .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C have to use a temporary variable because of IBM mainframe + itemp=input(i) +C trap any values that overflow the I*1 range + if (itemp.le. 255 .and. itemp.ge. 0)then + output(i)=char(itemp) + else if (itemp .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti2i2.f b/pkg/tbtables/fitsio/fti2i2.f new file mode 100644 index 00000000..bab0b1a3 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2i2.f @@ -0,0 +1,136 @@ +C---------------------------------------------------------------------- + subroutine fti2i2(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*2 values to output i*2 values, doing optional +C scaling and checking for null values + +C input i*2 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i*2 value in the input array that is used to indicated nulls +C setval i*2 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i*2 returned array of values +C status i output error status (0 = ok) + + integer*2 input(*),output(*),chkval,setval,j,mini2,maxi2 + integer n,i,chktyp,status + double precision scale,zero,dval,i2max,i2min + logical tofits,flgray(*),anynul,noscal + + parameter (maxi2=32767) + parameter (mini2=-32768) + parameter (i2max=3.276749D+04) + parameter (i2min=-3.276849D+04) + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits)then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C Have to use internal variable j to work around +C a bug in the Microsoft v5.0 compiler on IBM PCs + j=input(i) + output(i)=j +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C Have to use internal variable j to work around +C a bug in the Microsoft v5.0 compiler on IBM PCs + j=input(i) + output(i)=j +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C Have to use internal variable j to work around +C a bug in the Microsoft v5.0 compiler on IBM PCs + j=input(i) + output(i)=j + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti2i4.f b/pkg/tbtables/fitsio/fti2i4.f new file mode 100644 index 00000000..80bd1642 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2i4.f @@ -0,0 +1,129 @@ +C---------------------------------------------------------------------- + subroutine fti2i4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*2 values to output i*4 values, doing optional +C scaling and checking for null values + +C input i*2 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i*2 value in the input array that is used to indicated nulls +C setval i value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i returned array of values +C status i output error status (0 = ok) + + integer*2 input(*),chkval + integer output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval,i4max,i4min + logical tofits,flgray(*),anynul,noscal + parameter (i4max=2.14748364749D+09) + parameter (i4min=-2.14748364849D+09) + integer maxi4,mini4 + parameter (maxi4=2147483647) +C work around for bug in the DEC Alpha VMS compiler + mini4=-2147483647 - 1 + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti2r4.f b/pkg/tbtables/fitsio/fti2r4.f new file mode 100644 index 00000000..1c334358 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2r4.f @@ -0,0 +1,92 @@ +C---------------------------------------------------------------------- + subroutine fti2r4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*2 values to output r*4 values, doing optional +C scaling and checking for null values + +C input i*2 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i*2 value in the input array that is used to indicated nulls +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output r returned array of values + + integer*2 input(*),chkval + real output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti2r8.f b/pkg/tbtables/fitsio/fti2r8.f new file mode 100644 index 00000000..98d17ed1 --- /dev/null +++ b/pkg/tbtables/fitsio/fti2r8.f @@ -0,0 +1,92 @@ +C---------------------------------------------------------------------- + subroutine fti2r8(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*2 values to output r*8 values, doing optional +C scaling and checking for null values + +C input i*2 input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i*2 value in the input array that is used to indicated nulls +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output d returned array of values + + integer*2 input(*),chkval + double precision output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti4i1.f b/pkg/tbtables/fitsio/fti4i1.f new file mode 100644 index 00000000..2aef2654 --- /dev/null +++ b/pkg/tbtables/fitsio/fti4i1.f @@ -0,0 +1,151 @@ +C---------------------------------------------------------------------- + subroutine fti4i1(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*4 values to output i*1 values, doing optional +C scaling and checking for null values + +C input i input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i value in the input array that is used to indicated nulls +C setval c*1 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + integer input(*),chkval + character*1 output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*1 range + if (input(i).le. 255 .and. input(i).ge. 0)then + output(i)=char(input(i)) + else if (input(i) .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*1 range + if (input(i).le. 255 .and. input(i).ge. 0)then + output(i)=char(input(i)) + else if (input(i) .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*1 range + if (input(i).le. 255 .and. + & input(i).ge. 0)then + output(i)=char(input(i)) + else if (input(i) .gt. 255)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(int(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti4i2.f b/pkg/tbtables/fitsio/fti4i2.f new file mode 100644 index 00000000..5d3b9873 --- /dev/null +++ b/pkg/tbtables/fitsio/fti4i2.f @@ -0,0 +1,157 @@ +C---------------------------------------------------------------------- + subroutine fti4i2(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*4 values to output i*2 values, doing optional +C scaling and checking for null values + +C input i input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i value in the input array that is used to indicated nulls +C setval i*2 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i*2 returned array of values +C status i output error status (0 = ok) + + integer input(*),chkval + integer*2 output(*),setval + integer n,i,chktyp,status,maxi2,mini2 + double precision scale,zero,dval,i2max,i2min + logical tofits,flgray(*),anynul,noscal + parameter (i2max=3.276749D+04) + parameter (i2min=-3.276849D+04) + parameter (maxi2=32767) + parameter (mini2=-32768) + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=input(i) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=input(i) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=input(i) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=dval + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti4i4.f b/pkg/tbtables/fitsio/fti4i4.f new file mode 100644 index 00000000..26807092 --- /dev/null +++ b/pkg/tbtables/fitsio/fti4i4.f @@ -0,0 +1,129 @@ +C---------------------------------------------------------------------- + subroutine fti4i4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*4 values to output i*4 values, doing optional +C scaling and checking for null values + +C input i input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i value in the input array that is used to indicated nulls +C setval i value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i returned array of values +C status i output error status (0 = ok) + + integer input(*),chkval + integer output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval,i4max,i4min + logical tofits,flgray(*),anynul,noscal + parameter (i4max=2.14748364749D+09) + parameter (i4min=-2.14748364849D+09) + integer maxi4,mini4 + parameter (maxi4=2147483647) +C work around for bug in the DEC Alpha VMS compiler + mini4=-2147483647 - 1 + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=dval + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti4r4.f b/pkg/tbtables/fitsio/fti4r4.f new file mode 100644 index 00000000..1b6a4291 --- /dev/null +++ b/pkg/tbtables/fitsio/fti4r4.f @@ -0,0 +1,92 @@ +C---------------------------------------------------------------------- + subroutine fti4r4(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*4 values to output r*4 values, doing optional +C scaling and checking for null values + +C input i input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i value in the input array that is used to indicated nulls +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output r returned array of values + + integer input(*),chkval + real output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/fti4r8.f b/pkg/tbtables/fitsio/fti4r8.f new file mode 100644 index 00000000..62b1b76d --- /dev/null +++ b/pkg/tbtables/fitsio/fti4r8.f @@ -0,0 +1,92 @@ +C---------------------------------------------------------------------- + subroutine fti4r8(input,n,scale,zero,tofits, + & chktyp,chkval,setval,flgray,anynul,output,status) + +C copy input i*4 values to output r*8 values, doing optional +C scaling and checking for null values + +C input i input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C chkval i value in the input array that is used to indicated nulls +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output d returned array of values + + integer input(*),chkval + double precision output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (input(i) .eq. chkval)then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftibin.f b/pkg/tbtables/fitsio/ftibin.f new file mode 100644 index 00000000..ad35abf3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftibin.f @@ -0,0 +1,108 @@ +C-------------------------------------------------------------------------- + subroutine ftibin(ounit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + +C insert an binary table extension following the current HDU + +C ounit i fortran output unit number +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) (optional) +C tform c format of each field (array) +C tunit c units of each field (array) (optional) +C extnam c name of table extension (optional) +C pcount i size of special data area following the table (usually = 0) +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nrows,nfield,pcount,status + character*(*) ttype(*),tform(*),tunit(*),extnam + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,nhdu,i,savstr,nblock,hsize,nkey + + if (status .gt. 0)return + ibuff=bufnum(ounit) + +C close the current HDU to make sure END and fill values are written + call ftchdu(ounit,status) + if (status .gt. 0)return + +C save the starting address of the next HDU + nhdu=chdu(ibuff)+1 + savstr=hdstrt(ibuff,nhdu) + +C count number of optional TUNITS keywords to be written + nkey=0 + do 5 i=1,nfield + if (tunit(i) .ne. ' ')nkey=nkey+1 +5 continue + if (extnam .ne. ' ')nkey=nkey+1 + +C calc min size of header + nblock=(9 + 2*nfield + nkey +35)/36 + hsize=nblock*2880 + +C define a fake CHDU with a minimum header + dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize + +C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) + call ftbdef(ounit,nfield,tform,pcount,nrows,status) + +C use start of next HDU to calc. how big this new HDU is + nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 + +C reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C insert the required number of blocks at the end of the real CHDU +C (first define hdutyp so that the correct fill value will be used) + hdutyp(ibuff)=2 + call ftiblk(ounit,nblock,1,status) + if (status .gt. 0)return + +C increment the number of HDUs in the file and their starting address + maxhdu(ibuff)=maxhdu(ibuff)+1 + do 10 i=maxhdu(ibuff),nhdu,-1 + hdstrt(ibuff,i+1)=hdstrt(ibuff,i) +10 continue + +C again, reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C flush the buffers holding data for the old HDU + call ftflsh(ibuff,status) + +C recover common block space containing column descriptors for old HDU + call ftfrcl(ounit,status) + +C move to the new (empty) HDU + chdu(ibuff)=nhdu + +C set parameters describing an empty header + hdutyp(ibuff)=2 + nxthdr(ibuff)=hdstrt(ibuff,nhdu) + hdend(ibuff)= hdstrt(ibuff,nhdu) + dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize + +C write the header keywords + call ftphbn(ounit,nrows,nfield,ttype,tform,tunit,extnam, + & pcount,status) + +C define the structure of the new HDU + call ftbdef(ounit,nfield,tform,pcount,nrows,status) + end diff --git a/pkg/tbtables/fitsio/ftiblk.f b/pkg/tbtables/fitsio/ftiblk.f new file mode 100644 index 00000000..9c61fd12 --- /dev/null +++ b/pkg/tbtables/fitsio/ftiblk.f @@ -0,0 +1,189 @@ +C-------------------------------------------------------------------------- + subroutine ftiblk(ounit,nblock,hdrdat,status) + +C insert a 2880-byte block at the end of the current header or data. + +C ounit i fortran output unit number +C nblock i number of blocks to insert +C hdrdat i insert space in header (0) or data (1) +C status i returned error status (0=ok) + + integer ounit,nblock,hdrdat,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(2880,2) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,ipoint,jpoint,i,tstat,thdu,nshift,in,out,tin + character*1 cfill + + if (status .gt. 0)return + tstat=status + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + +C set the appropriate fill value + if (hdrdat .eq. 0 .or. hdutyp(ibuff) .eq. 1)then +C fill header or ASCII table with space + cfill=char(32) + else +C fill with Null (0) in image or bintable data area + cfill=char(0) + end if + +C find position in file to insert new block + if (hdrdat .eq. 0)then + ipoint=dtstrt(ibuff) + else + ipoint=hdstrt(ibuff,chdu(ibuff)+1) + end if + + + if (nblock .eq. 1 .and. hdrdat .eq. 0)then +C****************************************************************** +C Don't use this algoritm, even though it may be faster (but initial +C tests showed it didn't make any difference on a SUN) because it is +C less safe than the other more general algorithm. If there is +C not enough disk space available for the added block, this faster +C algorithm won't fail until it tries to move the last block, thus leaving +C the FITS file in a corrupted state. The other more general +C algorithm tries to add a new empty block to the file as the +C first step. If this fails, it still leaves the current FITS +C file unmodified, which is better for the user. +C****************************************************************** +C (Note added later:) +C Will use this algorithm anyway when inserting one block in a FITS +C header because the more general algorithm results in a status=252 error +C in cases where the number of rows in a table has not yet been defined +C****************************************************************** +C use this more efficient algorithm if just adding a single block +C initialize the first buffer + do 5 i=1,2880 + buff(i,1)=cfill +5 continue + + in=2 + out=1 + +C move to the read start position +10 call ftmbyt(ounit,ipoint,.false.,status) + +C read one 2880-byte FITS logical record into the input buffer + call ftgcbf(ounit,0,2880,buff(1,in),status) + +C check for End-Of-File + if (status .eq. 107)go to 20 + +C move back to the write start postion + call ftmbyt(ounit,ipoint,.false.,status) + +C write the 2880-byte FITS logical record stored in the output buffer + call ftpcbf(ounit,0,2880,buff(1,out),status) + +C check for error during write (the file may not have write access) + if (status .gt. 0)return + +C swap the input and output buffer pointers and move to next block + tin=in + in=out + out=tin + ipoint=ipoint+2880 + +C now repeat the process until we reach the End-Of-File + go to 10 + +C we have reached the end of file; now append the last block +20 status=tstat + +C move back to the write start postion + call ftmbyt(ounit,ipoint,.true.,status) + +C write the 2880-byte FITS logical record stored in the output buffer + call ftpcbf(ounit,0,2880,buff(1,out),status) + + else +C use this general algorithm for adding arbitrary number of blocks + +C first, find the end of file + thdu=chdu(ibuff) + +30 call ftmahd(ounit,maxhdu(ibuff)+1,i,status) + + if (status .eq. 107)then + status=tstat +C move back to the current extension + call ftmahd(ounit,thdu,i,status) + go to 100 + else if (status .le. 0)then + go to 30 + else + call ftpmsg('Error while seeking End of File (FTIBLK)') + return + end if + +C calculate number of 2880-byte blocks that have to be shifted down +100 continue + nshift=(hdstrt(ibuff,maxhdu(ibuff)+1)-ipoint)/2880 + jpoint=hdstrt(ibuff,maxhdu(ibuff)+1)-2880 + +C move all the blocks, one at a time, starting at end of file and +C working back to the insert position + do 110 i=1,nshift + +C move to the read start position + call ftmbyt(ounit,jpoint,.false.,status) + +C read one 2880-byte FITS logical record + call ftgcbf(ounit,0,2880,buff,status) + +C move forward to the write start postion + call ftmbyt(ounit,jpoint+nblock*2880,.true.,status) + +C write the 2880-byte FITS logical record + call ftpcbf(ounit,0,2880,buff,status) + +C check for error + if (status .gt. 0)then + call ftpmsg('Error inserting empty FITS block(s) '// + & '(FTIBLK)') + return + end if + jpoint=jpoint-2880 +110 continue + + do 120 i=1,2880 + buff(i,1)=cfill +120 continue + +C move back to the write start postion + call ftmbyt(ounit,ipoint,.true.,status) + + do 130 i=1,nblock +C write the 2880-byte FITS logical record + call ftpcbf(ounit,0,2880,buff,status) +130 continue + end if + + if (hdrdat .eq. 0)then +C recalculate the starting location of the current data unit + dtstrt(ibuff)=dtstrt(ibuff)+2880*nblock + end if + +C recalculate the starting location of all subsequent HDUs + do 140 i=chdu(ibuff)+1,maxhdu(ibuff)+1 + hdstrt(ibuff,i)=hdstrt(ibuff,i)+2880*nblock +140 continue + if (status .gt. 0)then + call ftpmsg('Error inserting FITS block(s) (FTIBLK)') + end if + end diff --git a/pkg/tbtables/fitsio/fticol.f b/pkg/tbtables/fitsio/fticol.f new file mode 100644 index 00000000..33582ea9 --- /dev/null +++ b/pkg/tbtables/fitsio/fticol.f @@ -0,0 +1,154 @@ +C-------------------------------------------------------------------------- + subroutine fticol(iunit,numcol,ttype,tform,status) + +C insert a new column into an existing table + +C iunit i Fortran I/O unit number +C numcol i number (position) for the new column; 1 = first column +C any existing columns will be moved up one position +C ttype c name of column (value for TTYPEn keyword) +C tform c column format (value for TFORMn keyword) +C status i returned error status (0=ok) + + integer iunit,numcol,status + character*(*) ttype,tform + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,colnum,typhdu,datcod,repeat,width,decims,delbyt + integer naxis1,naxis2,size,freesp,nblock,tflds,tbc,fstbyt,i + character comm*70,tfm*30,keynam*8 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C test that the CHDU is an ASCII table or BINTABLE + typhdu=hdutyp(ibuff) + if (typhdu .ne. 1 .and. typhdu .ne. 2)then + status=235 + call ftpmsg('Can only append column to TABLE or '// + & 'BINTABLE extension (FTICOL)') + return + end if + +C check that the column number is valid + tflds=tfield(ibuff) + if (numcol .lt. 1)then + status=302 + return + else if (numcol .gt. tflds)then + colnum=tflds+1 + else + colnum=numcol + end if + +C parse the tform value and calc number of bytes to add to each row +C make sure format characters are in upper case: + tfm=tform + call ftupch(tfm) + + if (typhdu .eq. 1)then + call ftasfm(tfm,datcod,width,decims,status) +C add one space between the columns + delbyt=width+1 + else + call ftbnfm(tfm,datcod,repeat,width,status) + if (datcod .eq. 1)then +C bit column; round up to a multiple of 8 bits + delbyt=(repeat+7)/8 + else if (datcod .eq. 16)then +C ASCII string column + delbyt=repeat + else +C numerical data type + delbyt=(datcod/10)*repeat + end if + end if + +C quit on error, or if column is zero byte wide (repeat=0) + if (status .gt. 0 .or. delbyt .eq. 0)return + +C get current size of the table + naxis1=rowlen(ibuff) + call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) + +C Calculate how many more FITS blocks (2880 bytes) need to be added + size=theap(ibuff)+scount(ibuff) + freesp=(delbyt*naxis2) - ((size+2879)/2880)*2880 + size + nblock=(freesp+2879)/2880 + +C insert the needed number of new FITS blocks at the end of the HDU + if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status) + +C shift the heap down, and update pointers to start of heap + size=delbyt*naxis2 + call fthpdn(iunit,size,status) + +C calculate byte position in the row where to insert the new column + if (colnum .gt. tflds)then + fstbyt=naxis1 + else + fstbyt=tbcol(colnum+tstart(ibuff)) + end if + +C insert DELBYT bytes in every row, at byte position FSTBYT + call ftcins(iunit,naxis1,naxis2,delbyt,fstbyt,status) + + if (typhdu .eq. 1)then +C adjust the TBCOL values of the existing columns + do 10 i=1,tflds + call ftkeyn('TBCOL',i,keynam,status) + call ftgkyj(iunit,keynam,tbc,comm,status) + if (tbc .gt. fstbyt)then + tbc=tbc+delbyt + call ftmkyj(iunit,keynam,tbc,'&',status) + end if +10 continue + end if + +C update the mandatory keywords + call ftmkyj(iunit,'TFIELDS',tflds+1,'&',status) + call ftmkyj(iunit,'NAXIS1',naxis1+delbyt,'&',status) + +C increment the index value on any existing column keywords + call ftkshf(iunit,colnum,tflds,1,status) + +C add the required keywords for the new column + comm='label for field' + call ftpkns(iunit,'TTYPE',colnum,1,ttype,comm,status) + + comm='format of field' + call ftpkns(iunit,'TFORM',colnum,1,tfm,comm,status) + + if (typhdu .eq. 1)then + comm='beginning column of field ' + if (colnum .eq. tflds+1)then +C allow for the space between preceding column + tbc=fstbyt+2 + else + tbc=fstbyt+1 + end if + call ftpknj(iunit,'TBCOL',colnum,1,tbc,comm,status) + end if + +C parse the header to initialize the new table structure + call ftrdef(iunit,status) + end diff --git a/pkg/tbtables/fitsio/ftiimg.f b/pkg/tbtables/fitsio/ftiimg.f new file mode 100644 index 00000000..b8952d76 --- /dev/null +++ b/pkg/tbtables/fitsio/ftiimg.f @@ -0,0 +1,87 @@ +C-------------------------------------------------------------------------- + subroutine ftiimg(ounit,bitpix,naxis,naxes,status) + +C insert an IMAGE extension following the current HDU + +C ounit i fortran output unit number +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C status i returned error status (0=ok) + + integer ounit,bitpix,naxis,naxes(*),status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,nhdu,i,savstr,nblock + + if (status .gt. 0)return + ibuff=bufnum(ounit) + +C close the current HDU to make sure END and fill values are written + call ftchdu(ounit,status) + if (status .gt. 0)return + +C save the starting address of the next HDU + nhdu=chdu(ibuff)+1 + savstr=hdstrt(ibuff,nhdu) + +C define a fake CHDU with a one block header + dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+2880 + +C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) + call ftpdef(ounit,bitpix,naxis,naxes,0,1,status) + +C use start of next HDU to calc. how big this new HDU is + nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 + +C reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C insert the required number of blocks at the end of the real CHDU +C (first define hdutyp so that the correct fill value will be used) + hdutyp(ibuff)=0 + call ftiblk(ounit,nblock,1,status) + if (status .gt. 0)return + +C increment the number of HDUs in the file and their starting address + maxhdu(ibuff)=maxhdu(ibuff)+1 + do 10 i=maxhdu(ibuff),nhdu,-1 + hdstrt(ibuff,i+1)=hdstrt(ibuff,i) +10 continue + +C again, reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C flush the buffers holding data for the old HDU + call ftflsh(ibuff,status) + +C recover common block space containing column descriptors for old HDU + call ftfrcl(ounit,status) + +C move to the new (empty) HDU + chdu(ibuff)=nhdu + +C set parameters describing an empty 1 block header + hdutyp(ibuff)=0 + nxthdr(ibuff)=hdstrt(ibuff,nhdu) + hdend(ibuff)= hdstrt(ibuff,nhdu) + dtstrt(ibuff)=hdstrt(ibuff,nhdu)+2888 + +C write the header keywords + call ftphpr(ounit,.true.,bitpix,naxis,naxes,0,1,.true.,status) + +C define the structure of the new HDU + call ftpdef(ounit,bitpix,naxis,naxes,0,1,status) + end diff --git a/pkg/tbtables/fitsio/ftikyd.f b/pkg/tbtables/fitsio/ftikyd.f new file mode 100644 index 00000000..b1d8940f --- /dev/null +++ b/pkg/tbtables/fitsio/ftikyd.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftikyd(ounit,keywrd,dval,decim,comm,status) + +C insert a double E keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status,decim + double precision dval + + character value*35,key*8,com*47 + character*80 record + integer nkeys,keypos,vlen + + if (status .gt. 0)return + +C convert double to F format character string and construct the record + call ftd2e(dval,decim,value,vlen,status) + key=keywrd + com=comm + record=key//'= '//value(1:vlen)//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikye.f b/pkg/tbtables/fitsio/ftikye.f new file mode 100644 index 00000000..dfdf5ab3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftikye.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftikye(ounit,keywrd,rval,decim,comm,status) + +C insert a real*4 E keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status,decim + real rval + + character value*20,key*8,com*47 + character*80 record + integer nkeys,keypos + + if (status .gt. 0)return + +C convert real to F format character string and construct the full record + call ftr2e(rval,decim,value,status) + key=keywrd + com=comm + record=key//'= '//value//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikyf.f b/pkg/tbtables/fitsio/ftikyf.f new file mode 100644 index 00000000..a587b37c --- /dev/null +++ b/pkg/tbtables/fitsio/ftikyf.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftikyf(ounit,keywrd,rval,decim,comm,status) + +C insert a real*4 F keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status,decim + real rval + + character value*20,key*8,com*47 + character*80 record + integer nkeys,keypos + + if (status .gt. 0)return + +C convert real to F format character string and construct the full record + call ftr2f(rval,decim,value,status) + key=keywrd + com=comm + record=key//'= '//value//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikyg.f b/pkg/tbtables/fitsio/ftikyg.f new file mode 100644 index 00000000..7c448066 --- /dev/null +++ b/pkg/tbtables/fitsio/ftikyg.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftikyg(ounit,keywrd,dval,decim,comm,status) + +C insert a double F keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status,decim + double precision dval + + character value*20,key*8,com*47 + character*80 record + integer nkeys,keypos + + if (status .gt. 0)return + +C convert double to F format character string and construct the record + call ftd2f(dval,decim,value,status) + key=keywrd + com=comm + record=key//'= '//value//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikyj.f b/pkg/tbtables/fitsio/ftikyj.f new file mode 100644 index 00000000..0dd2d23b --- /dev/null +++ b/pkg/tbtables/fitsio/ftikyj.f @@ -0,0 +1,32 @@ +C-------------------------------------------------------------------------- + subroutine ftikyj(ounit,keywrd,intval,comm,status) + +C insert an integer keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C intval i keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status,intval + + character value*20,key*8,com*47 + character*80 record + integer nkeys,keypos + + if (status .gt. 0)return + +C convert integer to character string and construct the full record + call fti2c(intval,value,status) + key=keywrd + com=comm + record=key//'= '//value//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikyl.f b/pkg/tbtables/fitsio/ftikyl.f new file mode 100644 index 00000000..22b48d4b --- /dev/null +++ b/pkg/tbtables/fitsio/ftikyl.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftikyl(ounit,keywrd,logval,comm,status) + +C insert a logical keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C logval l keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 + + character*(*) keywrd,comm + integer ounit,status + logical logval + + character value*20,key*8,com*47 + character*80 record + integer nkeys,keypos + + if (status .gt. 0)return + +C convert logical to character string and construct the full record + call ftl2c(logval,value,status) + key=keywrd + com=comm + record=key//'= '//value//' / '//com + + call ftghps(ounit,nkeys,keypos,status) + call ftirec(ounit,keypos,record,status) + end diff --git a/pkg/tbtables/fitsio/ftikys.f b/pkg/tbtables/fitsio/ftikys.f new file mode 100644 index 00000000..7247cd2f --- /dev/null +++ b/pkg/tbtables/fitsio/ftikys.f @@ -0,0 +1,71 @@ +C-------------------------------------------------------------------------- + subroutine ftikys(ounit,keywrd,strval,comm,status) + +C insert a string keyword into the header at the current position +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C strval c keyword value +C comm c keyword comment +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, March 1993 +C Modifed 9/94 to call FTPKLS, supporting the OGIP long string convention + + character*(*) keywrd,comm,strval + integer ounit,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + integer lenval,length,i,nspace,ibuff,nexthd,endhd,nkeys,keypos + + if (status .gt. 0)return + +C find how many keywords are required to write the string, in case it +C cannot fit onto one keyword and has to be continued on multiple lines. + + lenval=len(strval) + length=0 + do 10 i=lenval,1,-1 + if (strval(i:i) .ne. ' ')then + length=i + go to 20 + end if +10 continue +20 nspace=max(1,(length-2)/67+1) + +C save current pointer values + ibuff=bufnum(ounit) + endhd=hdend(ibuff) + nexthd=nxthdr(ibuff) + +C insert enough spaces in the header at the current location + call ftghps(ounit,nkeys,keypos,status) + + do 30 i=1,nspace + call ftirec(ounit,keypos,' ',status) +30 continue + +C temporarily reset position of the end of header to force keyword +C to be written at the current header position. + hdend(ibuff)=nexthd + +C write the keyword (supporting the OGIP long string convention) + call ftpkls(ounit,keywrd,strval,comm,status) + +C reset the next keyword pointer to follow the inserted keyword + nxthdr(ibuff)=nexthd+80*nspace + +C reset the end-of-header pointer to its real location + hdend(ibuff)=endhd+80*nspace + end diff --git a/pkg/tbtables/fitsio/ftinit.f b/pkg/tbtables/fitsio/ftinit.f new file mode 100644 index 00000000..712638f9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftinit.f @@ -0,0 +1,43 @@ +C-------------------------------------------------------------------------- + subroutine ftinit(funit,fname,block,status) + +C open a new FITS file with write access +C +C funit i Fortran I/O unit number +C fname c name of file to be opened +C block i input record length blocking factor +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer funit,status,block,strlen,i + character*(*) fname + + if (status .gt. 0)return + +C ignore any leading blanks in the file name + strlen=len(fname) + do 10 i=1,strlen + if (fname(i:i) .ne. ' ')then + +C call the machine dependent routine which creates the file + call ftopnx(funit,fname(i:),1,1,block,status) + if (status .gt. 0)then + call ftpmsg('FTINIT failed to create the following new file:') + call ftpmsg(fname) + return + end if + +C set column descriptors as undefined + call ftfrcl(funit,-999) + +C set current column name buffer as undefined + call ftrsnm + return + end if +10 continue + +C if we got here, then the input filename was all blanks + status=105 + call ftpmsg('FTINIT: Name of file to create is blank.') + end diff --git a/pkg/tbtables/fitsio/ftirec.f b/pkg/tbtables/fitsio/ftirec.f new file mode 100644 index 00000000..a3c47d85 --- /dev/null +++ b/pkg/tbtables/fitsio/ftirec.f @@ -0,0 +1,72 @@ +C-------------------------------------------------------------------------- + subroutine ftirec(ounit,pos,record,status) + +C insert a 80-char keyword record into the header at the pos-th keyword +C position (i.e., immediately before the current keyword at position POS. +C +C ounit i fortran output unit number +C pos i keyword will be inserted at this position (1 = 1st keyword) +C record c*80 keyword record +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Jan 1995 + + character*(*) record + integer ounit,pos,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + character*80 outrec, inrec + integer ibuff, fkey, lkey, i, nexthd, nkey + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + +C calculate number of existing keywords + nkey=(hdend(ibuff)-hdstrt(ibuff,chdu(ibuff)))/80 + + if (pos .eq. nkey+1)then +C simply append the record to the header + call ftprec(ounit,record,status) + return + else if (pos .lt. 1 .or. pos .gt. nkey)then + status=203 + return + end if + + outrec=record + +C move to the insert position + nexthd=hdstrt(ibuff,chdu(ibuff))+(pos-1)*80 + call ftmbyt(ounit,nexthd,.false.,status) + nxthdr(ibuff)=nexthd + +C calculated the first and last keyword to be rewritten + fkey=pos + lkey=fkey + (hdend(ibuff)-nexthd)/80 - 1 + +C now sequentially read each keyword and overwrite it with the previous + do 10 i=fkey,lkey + call ftgrec(ounit,i,inrec,status) + call ftmodr(ounit,outrec,status) + outrec=inrec +10 continue + +C finally, write the last keyword + call ftprec(ounit,outrec,status) + +C reset the next keyword pointer to follow the inserted keyword + nxthdr(ibuff)=nexthd+80 + end diff --git a/pkg/tbtables/fitsio/ftirow.f b/pkg/tbtables/fitsio/ftirow.f new file mode 100644 index 00000000..66ef08e9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftirow.f @@ -0,0 +1,92 @@ +C-------------------------------------------------------------------------- + subroutine ftirow(iunit,frow,nrows,status) + +C insert NROWS blank rows immediated after row FROW + +C iunit i Fortran I/O unit number +C frow i row number after which the new rows will be inserted. +C Specify 0 to add rows to the beginning of the table. +C nrows i number of rows to add to the table (must be greater than 0) +C status i returned error status (0=ok) + + integer iunit,frow,nrows,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,naxis1,naxis2,size,freesp,nblock + character comm*8 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C test that the CHDU is an ASCII table or BINTABLE + if (hdutyp(ibuff) .ne. 1 .and. hdutyp(ibuff) .ne. 2)then + status=235 + call ftpmsg('Can only add rows to TABLE or BINTABLE '// + & 'extension (FTIROW)') + return + end if + + if (nrows .lt. 0)then + status=306 + call ftpmsg('Cannot insert negative number of ' // + & 'rows in the table (FTIROW)') + return + else if (nrows .eq. 0)then + return + end if + +C get current size of the table + call ftgkyj(iunit,'NAXIS1',naxis1,comm,status) + call ftgkyj(iunit,'NAXIS2',naxis2,comm,status) + + if (frow .gt. naxis2)then + status=307 + call ftpmsg('Insert position is greater than the '// + & 'number of rows in the table (FTIROW)') + return + else if (frow .lt. 0)then + status=307 + call ftpmsg('Insert starting row number is less than 0' + & //' (FTIROW)') + return + end if + +C Calculate how many more FITS blocks (2880 bytes) need to be added + size=theap(ibuff)+scount(ibuff) + freesp=((size+2879)/2880)*2880 - size + size=naxis1*nrows-freesp + nblock=(size+2879)/2880 + +C insert the needed number of new FITS blocks + if (nblock .gt. 0)call ftiblk(iunit,nblock,1,status) + +C shift the heap down, and update pointers to start of heap + size=naxis1*nrows + call fthpdn(iunit,size,status) + +C shift the rows down + call ftrwdn(iunit,frow,naxis2,nrows,status) + +C update the NAXIS2 keyword + naxis2=naxis2+nrows + call ftmkyj(iunit,'NAXIS2',naxis2,'&',status) + end diff --git a/pkg/tbtables/fitsio/ftitab.f b/pkg/tbtables/fitsio/ftitab.f new file mode 100644 index 00000000..18e209cf --- /dev/null +++ b/pkg/tbtables/fitsio/ftitab.f @@ -0,0 +1,108 @@ +C-------------------------------------------------------------------------- + subroutine ftitab(ounit,rowlen,nrows,nfield,ttype,tbcol, + & tform,tunit,extnam,status) + +C insert an ASCII table extension following the current HDU + +C ounit i fortran output unit number +C rowlen i width of a row, in characters +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) (optional) +C tform c format of each field (array) +C tunit c units of each field (array) (optional) +C extnam c name of table extension (optional) +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,rowlen,nrows,nfield,tbcol(*),status + character*(*) ttype(*),tform(*),tunit(*),extnam + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS:------------------------------------ + + integer ibuff,nhdu,i,savstr,nblock,hsize,nkey + + if (status .gt. 0)return + ibuff=bufnum(ounit) + +C close the current HDU to make sure END and fill values are written + call ftchdu(ounit,status) + if (status .gt. 0)return + +C save the starting address of the next HDU + nhdu=chdu(ibuff)+1 + savstr=hdstrt(ibuff,nhdu) + +C count number of optional TUNITS keywords to be written + nkey=0 + do 5 i=1,nfield + if (tunit(i) .ne. ' ')nkey=nkey+1 +5 continue + if (extnam .ne. ' ')nkey=nkey+1 + +C calc min size of header + nblock=(9 + 3*nfield + nkey +35)/36 + hsize=nblock*2880 + +C define a fake CHDU with minimum header + dtstrt(ibuff)=hdstrt(ibuff,chdu(ibuff))+hsize + +C define the size of the new HDU (this modifies hdstrt(ibuff,nhdu)) + call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status) + +C use start of next HDU to calc. how big this new HDU is + nblock=(hdstrt(ibuff,nhdu)-hdstrt(ibuff,nhdu-1))/2880 + +C reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C insert the required number of blocks at the end of the real CHDU +C (first define hdutyp so that the correct fill value will be used) + hdutyp(ibuff)=1 + call ftiblk(ounit,nblock,1,status) + if (status .gt. 0)return + +C increment the number of HDUs in the file and their starting address + maxhdu(ibuff)=maxhdu(ibuff)+1 + do 10 i=maxhdu(ibuff),nhdu,-1 + hdstrt(ibuff,i+1)=hdstrt(ibuff,i) +10 continue + +C again, reset the start of the next HDU back to it original value + hdstrt(ibuff,nhdu)=savstr + +C flush the buffers holding data for the old HDU + call ftflsh(ibuff,status) + +C recover common block space containing column descriptors for old HDU + call ftfrcl(ounit,status) + +C move to the new (empty) HDU + chdu(ibuff)=nhdu + +C set parameters describing an empty header + hdutyp(ibuff)=1 + nxthdr(ibuff)=hdstrt(ibuff,nhdu) + hdend(ibuff)= hdstrt(ibuff,nhdu) + dtstrt(ibuff)=hdstrt(ibuff,nhdu)+hsize + +C write the header keywords + call ftphtb(ounit,rowlen,nrows,nfield,ttype,tbcol,tform,tunit, + & extnam,status) + +C define the structure of the new HDU + call ftadef(ounit,rowlen,nfield,tbcol,tform,nrows,status) + end diff --git a/pkg/tbtables/fitsio/ftkeyn.f b/pkg/tbtables/fitsio/ftkeyn.f new file mode 100644 index 00000000..8f020b94 --- /dev/null +++ b/pkg/tbtables/fitsio/ftkeyn.f @@ -0,0 +1,70 @@ +C-------------------------------------------------------------------------- + subroutine ftkeyn(keywrd,nseq,keyout,status) + +C Make a keyword name by concatinating the root name and a +C sequence number + +C keywrd c root keyword name +C nseq i sequence number +C OUTPUT PARAMETERS: +C keyout c output concatinated keyword name +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, February 1991 + + character*(*) keywrd + integer nseq,status,nspace,i + character keyout*8,value*20 + + keyout=keywrd + +C find end of keyword string + nspace=1 + do 10 i=1,8 + if (keyout(i:i) .eq. ' ')go to 15 + nspace=nspace+1 +10 continue +15 continue + +C append sequence number to keyword root only if there is room + if (nseq .lt. 0)then +C illegal value + go to 900 + else if (nseq .lt. 10 .and. nspace .le. 8)then + write(keyout(nspace:nspace),1001,err=900)nseq + else if (nseq .lt. 100 .and. nspace .le. 7)then + write(keyout(nspace:nspace+1),1002,err=900)nseq + else if (nseq .lt. 1000 .and. nspace .le. 6)then + write(keyout(nspace:nspace+2),1003,err=900)nseq + else if (nseq .lt. 10000 .and. nspace .le. 5)then + write(keyout(nspace:nspace+3),1004,err=900)nseq + else if (nseq .lt. 100000 .and. nspace .le. 4)then + write(keyout(nspace:nspace+4),1005,err=900)nseq + else if (nseq .lt. 1000000 .and. nspace .le. 3)then + write(keyout(nspace:nspace+5),1006,err=900)nseq + else if (nseq .lt. 10000000 .and. nspace .le. 2)then + write(keyout(nspace:nspace+6),1007,err=900)nseq + else +C number too big to fit in keyword + go to 900 + end if + +1001 format(i1) +1002 format(i2) +1003 format(i3) +1004 format(i4) +1005 format(i5) +1006 format(i6) +1007 format(i7) + + return +C come here if error concatinating the seq. no. to the root string +900 continue + + if (status .gt. 0)return + status=206 + write(value,1008)nseq +1008 format(i20) + call ftpmsg('Could not concatinate the integer '//value// + & ' to the root keyword named: '//keyout) + end diff --git a/pkg/tbtables/fitsio/ftkshf.f b/pkg/tbtables/fitsio/ftkshf.f new file mode 100644 index 00000000..2e40aef8 --- /dev/null +++ b/pkg/tbtables/fitsio/ftkshf.f @@ -0,0 +1,118 @@ +C-------------------------------------------------------------------------- + subroutine ftkshf(iunit,colmin,colmax,incre,status) + +C shift the index value on any existing column keywords +C This routine will modify the name of any keyword that begins with 'T' +C and has an index number in the range COLMIN - COLMAX, inclusive. + +C if incre is positive, then the index values will be incremented. +C if incre is negative, then the kewords with index = COLMIN +C will be deleted and the index of higher numbered keywords will +C be decremented. + +C iunit i Fortran I/O unit number +C colmin i starting column number to be incremented +C colmax i maximum column number to be increment +C incre i amount by which the index value should be shifted +C status i returned error status (0=ok) + + integer iunit,colmin,colmax,incre,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,typhdu,tflds,nkeys,nmore,nrec,ival,tstat,i1 + character rec*80,newkey*8,q*4 + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C test that the CHDU is an ASCII table or BINTABLE + typhdu=hdutyp(ibuff) + if (typhdu .ne. 1 .and. typhdu .ne. 2)then + status=235 + call ftpmsg('Can only operate on TABLE or '// + & 'BINTABLE extension (FTKSHF)') + return + end if + +C test column number limits + tflds=tfield(ibuff) + if (colmin .lt. 1 .or. colmax .lt. 1)then + status=302 + return + else if (colmin .gt. colmax .or. colmin .gt. tflds)then + return + end if + +C get the number of keywords in the header + call ftghsp(iunit,nkeys,nmore,status) + +C go thru header starting with the 9th keyword looking for 'TxxxxNNN' + + nrec=9 +100 call ftgrec(iunit,nrec,rec,status) + + if (rec(1:1) .eq. 'T')then + q=rec(2:5) + i1=6 + +C search list of 5-character 'official' indexed keywords + if ( q .eq. 'BCOL' .or. q .eq. 'FORM' .or. q .eq. 'TYPE' + & .or. q .eq. 'UNIT' .or. q .eq. 'NULL' .or. q .eq. 'SCAL' + & .or. q .eq. 'ZERO' .or. q .eq. 'DISP')go to 20 + +C search list of 5-character 'local' indexed keywords + if ( q .eq. 'LMIN' .or. q .eq. 'LMAX' .or. q .eq. 'DMIN' + & .or. q .eq. 'DMAX' .or. q .eq. 'CTYP' .or. q .eq. 'CRPX' + & .or. q .eq. 'CRVL' .or. q .eq. 'CDLT' .or. q .eq. 'CROT' + & .or. q .eq. 'CUNI')go to 20 + + q=rec(1:4) + i1=5 +C search list of 4-character 'official' indexed keywords + if (q .eq. 'TDIM')go to 20 + +C no match so go on to next keyword + go to 90 + +20 continue +C try reading the index number suffix + tstat=0 + call ftc2ii(rec(i1:8),ival,tstat) + if (tstat .eq. 0 .and. ival .ge. colmin .and. + & ival .le. colmax)then + if (incre .le. 0 .and. ival .eq. colmin)then +C delete keyword related to this column + call ftdrec(iunit,nrec,status) + nkeys=nkeys-1 + nrec=nrec-1 + else + ival=ival+incre + i1=i1-1 + call ftkeyn(rec(1:i1),ival,newkey,status) + rec(1:8)=newkey +C modify the index number of this keyword + call ftmrec(iunit,nrec,rec,status) + end if + end if + end if + +90 nrec=nrec+1 + if (nrec .le. nkeys)go to 100 + end diff --git a/pkg/tbtables/fitsio/ftl2c.f b/pkg/tbtables/fitsio/ftl2c.f new file mode 100644 index 00000000..f919e021 --- /dev/null +++ b/pkg/tbtables/fitsio/ftl2c.f @@ -0,0 +1,15 @@ +C---------------------------------------------------------------------- + subroutine ftl2c(lval,cval,status) +C convert a logical value to a C*20 right justified character string + integer status + logical lval + character*20 cval + + if (status .gt. 0)return + + if (lval)then + cval=' T' + else + cval=' F' + end if + end diff --git a/pkg/tbtables/fitsio/ftmahd.f b/pkg/tbtables/fitsio/ftmahd.f new file mode 100644 index 00000000..58e45342 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmahd.f @@ -0,0 +1,73 @@ +C---------------------------------------------------------------------- + subroutine ftmahd(iunit,extno,xtend,status) + +C Move to Absolute Header Data unit +C move the i/o pointer to the specified HDU and initialize all +C the common block parameters which describe the extension + +C iunit i fortran unit number +C extno i number of the extension to point to. +C xtend i returned type of extension: 0 = the primary HDU +C 1 = an ASCII table +C 2 = a binary table +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,extno,xtend,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,movto,tstat + + if (status .gt. 0)then + return + else if (extno .le. 0 .or. extno .ge. ne)then + status=301 + return + end if + + ibuff=bufnum(iunit) + +C check if we are already positioned to the correct HDU + if (extno .eq. chdu(ibuff))then +C just return the type of extension + xtend=hdutyp(ibuff) + else + +C now move to the extension, or the highest one we know about +10 movto=min(extno,maxhdu(ibuff)+1) + +C before closing out the CHDU, make sure the new extension exists + call ftmbyt(iunit,hdstrt(ibuff,movto),.false.,status) + if (status .gt. 0)return + +C close out the current HDU before moving to the new one + call ftchdu(iunit,status) + if (status .gt. 0)then + call ftpmsg('FTMAHD could not close the'// + & ' current HDU before moving to the new HDU.') + return + end if + + call ftgext(iunit,movto,xtend,status) + if (status .gt. 0)then +C failed to move to new extension, so restore previous extension + tstat=0 + call ftrhdu(iunit,movto,tstat) + return + end if + +C continue reading extensions until we get to the one we want + if (movto .lt. extno)go to 10 + end if + end diff --git a/pkg/tbtables/fitsio/ftmcom.f b/pkg/tbtables/fitsio/ftmcom.f new file mode 100644 index 00000000..b455344b --- /dev/null +++ b/pkg/tbtables/fitsio/ftmcom.f @@ -0,0 +1,41 @@ +C-------------------------------------------------------------------------- + subroutine ftmcom(ounit,keywrd,comm,status) + +C modify a the comment string in a header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C comm c new keyword comment (max of 72 characters long) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + character*(*) keywrd,comm + integer ounit,status,lenval,ncomm + character value*80,knam*8,cmnt*72 + + if (status .gt. 0)return + + knam=keywrd + +C find the old keyword + value string + call ftgcrd(ounit,knam,value,status) + if (status .eq. 202)then + call ftpmsg('FTMCOM Could not find the '//knam//' keyword.') + return + end if + + call ftprsv(value,lenval,status) + + cmnt=comm + +C find amount of space left for comment string (3 spaces needed for ' / ') + ncomm=77-lenval + +C write the keyword record if there is space + if (ncomm .gt. 0)then + call ftmodr(ounit, + & value(1:lenval)//' / '//cmnt(1:ncomm),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftmcrd.f b/pkg/tbtables/fitsio/ftmcrd.f new file mode 100644 index 00000000..67567b55 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmcrd.f @@ -0,0 +1,35 @@ +C-------------------------------------------------------------------------- + subroutine ftmcrd(ounit,keywrd,card,status) + +C modify (overwrite) a given header record specified by keyword name. +C This can be used to overwrite the name of the keyword as well as +C the value and comment fields. +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C card c new 80-character card image to be written +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + character*(*) keywrd,card + integer ounit,status + character value*80 + + if (status .gt. 0)return + +C find the old keyword string + call ftgcrd(ounit,keywrd,value,status) + + value=card + +C make sure new keyword name is in upper case + call ftupch(value(1:8)) + +C test that keyword name contains only legal characters + call fttkey(value(1:8),status) + +C write the new keyword record + call ftmodr(ounit,value,status) + end diff --git a/pkg/tbtables/fitsio/ftmkey.f b/pkg/tbtables/fitsio/ftmkey.f new file mode 100644 index 00000000..b7d05c26 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkey.f @@ -0,0 +1,28 @@ +C-------------------------------------------------------------------------- + subroutine ftmkey(ounit,keywrd,value,comm,status) + +C modify an existing simple FITS keyword record with format: +C "KEYWORD = VALUE / COMMENT" +C VALUE is assumed to be 20 characters long +C COMMENT is assumed to be 47 characters long +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C value c keyword value (20 characters, cols. 11-30) +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,value,comm + integer ounit,status + character key*8, val*20, com*47 + + key=keywrd + val=value + com=comm + +C overwrite the preceeding 80 characters to the output buffer: + call ftmodr(ounit,key//'= '//val//' / '//com,status) + end diff --git a/pkg/tbtables/fitsio/ftmkyd.f b/pkg/tbtables/fitsio/ftmkyd.f new file mode 100644 index 00000000..77012ab3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkyd.f @@ -0,0 +1,38 @@ +C-------------------------------------------------------------------------- + subroutine ftmkyd(ounit,keywrd,dval,decim,comm,status) + +C modify a double precision value header record in E format +C If it will fit, the value field will be 20 characters wide; +C otherwise it will be expanded to up to 35 characters, left +C justified. +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (max. 47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim,vlen + character value*35,key*8,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + + key=keywrd +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert double precision to E format character string + call ftd2e(dval,decim,value,vlen,status) + +C write the keyword record + call ftmodr(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkye.f b/pkg/tbtables/fitsio/ftmkye.f new file mode 100644 index 00000000..5d75ca9b --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkye.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftmkye(ounit,keywrd,rval,decim,comm,status) + +C modify a real*4 value header record in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim + character value*20,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert real to E format character string + call ftr2e(rval,decim,value,status) + +C modify the keyword record + call ftmkey(ounit,keywrd,value,cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkyf.f b/pkg/tbtables/fitsio/ftmkyf.f new file mode 100644 index 00000000..9b655665 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkyf.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftmkyf(ounit,keywrd,rval,decim,comm,status) + +C modify a real*4 value header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim + character value*20,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert real to F format character string + call ftr2f(rval,decim,value,status) + +C write the keyword record + call ftmkey(ounit,keywrd,value,cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkyg.f b/pkg/tbtables/fitsio/ftmkyg.f new file mode 100644 index 00000000..b0db38f5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkyg.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftmkyg(ounit,keywrd,dval,decim,comm,status) + +C modify a double precision value header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim + character value*20,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert double precision to F format character string + call ftd2f(dval,decim,value,status) + +C modify the keyword record + call ftmkey(ounit,keywrd,value,cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkyj.f b/pkg/tbtables/fitsio/ftmkyj.f new file mode 100644 index 00000000..4e117241 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkyj.f @@ -0,0 +1,32 @@ +C-------------------------------------------------------------------------- + subroutine ftmkyj(ounit,keywrd,intval,comm,status) + +C modify an integer value header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C intval i keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer ounit,status,intval + character value*20,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert integer to character string + call fti2c(intval,value,status) + +C modify the keyword record + call ftmkey(ounit,keywrd,value,cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkyl.f b/pkg/tbtables/fitsio/ftmkyl.f new file mode 100644 index 00000000..e7395b90 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkyl.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftmkyl(ounit,keywrd,logval,comm,status) + +C modify a logical value header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C logval l keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer ounit,status + logical logval + character value*20,cmnt*48 + +C find the old keyword + call ftgkey(ounit,keywrd,value,cmnt,status) + +C check for special symbol indicating that comment should not be changed + if (comm .ne. '&')then + cmnt=comm + end if + +C convert logical to character string + call ftl2c(logval,value,status) + +C modify the keyword record + call ftmkey(ounit,keywrd,value,cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftmkys.f b/pkg/tbtables/fitsio/ftmkys.f new file mode 100644 index 00000000..82b3ec1a --- /dev/null +++ b/pkg/tbtables/fitsio/ftmkys.f @@ -0,0 +1,121 @@ +C-------------------------------------------------------------------------- + subroutine ftmkys(ounit,keywrd,strval,comm,status) + +C modify a character string value header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C strval c keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C modifed 7/93 to support string keywords continued over multiple cards +C modified 9/94 to support the OGIP long string convention + + character*(*) keywrd,strval,comm + integer ounit,status + + integer clen,i,nvalue,ncomm + character keynam*8,value*70,cmnt*48,bslash + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + if (status .gt. 0)return + +C check if the new value is too long to fit in a single 'card image' + clen=len(strval) + if (clen .le. 68)go to 20 + + do 10 i=clen,69,-1 + if (strval(i:i) .ne. ' ')go to 100 +10 continue + +C now check that the old keyword is not continued over multiple cards +C read the (first line) of the existing keyword + +20 call ftgkey(ounit,keywrd,value,cmnt,status) + if (status .gt. 0)go to 900 + +C is last character of the value a backslash or & ? +C have to use 2 \\'s because the SUN compiler treats 1 \ as an escape + bslash='\\' + do 30 i=70,1,-1 + if (value(i:i) .ne. ' '.and. value(i:i).ne.'''')then + if (value(i:i) .eq. bslash .or. + & value(i:i) .eq. '&')then +C backspace the current header pointer by one record + nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-80 + go to 100 + else + go to 40 + end if + end if +30 continue + +C OK, we can simply overwrite the old keyword with the new +40 continue + +C overwrite the old comment unless user supplied the magic value + if (comm .ne. '&')then + cmnt=comm + end if +C convert string to quoted character string (max length = 70 characters) + call fts2c(strval,value,clen,status) + if (status .gt. 0)go to 900 + +C find amount of space left for comment string +C (assume 10 char. for 'keyword = ', and 3 between value and comment) +C which leaves 67 spaces for the value string + comment string + nvalue=max(20,clen) + ncomm=67-nvalue + +C write the keyword record + keynam=keywrd + if (ncomm .gt. 0)then +C there is space for a comment + call ftmodr(ounit, + & keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status) + else +C no room for a comment + call ftmodr(ounit, + & keynam//'= '//value(1:nvalue)//' ',status) + end if + go to 900 + +100 continue + +C Either the old or new keyword is continued over multiple +C header card images, so have to use a less efficient way to modify +C the keyword by completely deleting the old and inserting the new. + +C read the old comment, if we need to preserve it + if (comm .eq. '&')then + call ftgkys(ounit,keywrd,value,cmnt,status) + if (status .gt. 0)go to 900 +C reset the current header pointer by 2 records to make +C it faster (usually) to find and delete the keyword + nxthdr(bufnum(ounit))=nxthdr(bufnum(ounit))-160 + else + cmnt=comm + end if + +C delete the old keyword + call ftdkey(ounit,keywrd,status) + if (status .gt. 0)go to 900 + +C insert the new keyword + call ftikys(ounit,keywrd,strval,cmnt,status) + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftmnam.f b/pkg/tbtables/fitsio/ftmnam.f new file mode 100644 index 00000000..02774a69 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmnam.f @@ -0,0 +1,34 @@ +C-------------------------------------------------------------------------- + subroutine ftmnam(ounit,oldkey,newkey,status) + +C modify (overwrite) the name of an existing keyword, preserving +C the current value and comment fields +C +C ounit i fortran output unit number +C oldkey c old keyword name ( 8 characters, cols. 1- 8) +C newkey c new keyword name to be written +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + character*(*) oldkey,newkey + integer ounit,status + character card*80 + + if (status .gt. 0)return + +C find the old keyword string + call ftgcrd(ounit,oldkey,card,status) + + card(1:8)=newkey + +C make sure new keyword name is in upper case + call ftupch(card(1:8)) + +C test that keyword name contains only legal characters + call fttkey(card(1:8),status) + +C write the new keyword record + call ftmodr(ounit,card,status) + end diff --git a/pkg/tbtables/fitsio/ftmodr.f b/pkg/tbtables/fitsio/ftmodr.f new file mode 100644 index 00000000..97336703 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmodr.f @@ -0,0 +1,46 @@ +C-------------------------------------------------------------------------- + subroutine ftmodr(ounit,record,status) + +C modify the preceeding 80 character record in the FITS header +C +C ounit i fortran output unit number +C record c input 80 character header record +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) record + character*80 rec + integer ounit,status,ibuff + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + rec=record + +C make sure keyword name is in upper case + call ftupch(rec(1:8)) + +C test that keyword name contains only legal characters + call fttkey(rec(1:8),status) + +C move the I/O pointer back to the beginning of the preceeding keyword + call ftmbyt(ounit,nxthdr(ibuff)-80,.false.,status) + +C overwrite the 80 characters to the output buffer: + call ftpcbf(ounit,1,80,rec,status) + end diff --git a/pkg/tbtables/fitsio/ftmrec.f b/pkg/tbtables/fitsio/ftmrec.f new file mode 100644 index 00000000..aee11a60 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmrec.f @@ -0,0 +1,25 @@ +C-------------------------------------------------------------------------- + subroutine ftmrec(ounit,nkey,record,status) + +C modify the nth keyword in the CHU, by replacing it with the +C input 80 character string. +C +C ounit i fortran output unit number +C nkey i sequence number (starting with 1) of the keyword to read +C record c 80-character string to replace the record with +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nkey,status + character*(*) record + character rec*80 + +C find the old keyword; just use REC as a temporary variable + call ftgrec(ounit,nkey,rec,status) + + rec=record +C overwrite the keyword with the new record + call ftmodr(ounit,rec,status) + end diff --git a/pkg/tbtables/fitsio/ftmrhd.f b/pkg/tbtables/fitsio/ftmrhd.f new file mode 100644 index 00000000..c84d04c9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftmrhd.f @@ -0,0 +1,39 @@ +C---------------------------------------------------------------------- + subroutine ftmrhd(iunit,extmov,xtend,status) + +C Move Relative Header Data unit +C move the i/o pointer to the specified HDU and initialize all +C the common block parameters which describe the extension + +C iunit i fortran unit number +C extmov i number of the extension to point to, relative to the CHDU +C xtend i returned type of extension: 0 = the primary HDU +C 1 = an ASCII table +C 2 = a binary table +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1991 + + integer iunit,extmov,xtend,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,extno + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C calculate the absolute HDU number, then move to it + extno=chdu(ibuff)+extmov + call ftmahd(iunit,extno,xtend,status) + end diff --git a/pkg/tbtables/fitsio/ftnkey.f b/pkg/tbtables/fitsio/ftnkey.f new file mode 100644 index 00000000..365d509e --- /dev/null +++ b/pkg/tbtables/fitsio/ftnkey.f @@ -0,0 +1,70 @@ +C-------------------------------------------------------------------------- + subroutine ftnkey(nseq,keywrd,keyout,status) + +C Make a keyword name by concatinating a sequence number and +C the root name. (Sequence number is prepended to the name) + +C nseq i sequence number +C keywrd c root keyword name +C OUTPUT PARAMETERS: +C keyout c output concatinated keyword name +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Aug 1994 + + character*(*) keywrd + integer nseq,status,nspace,i + character keyout*8,value*20,work*8 + + work=keywrd + +C find end of keyword string + nspace=0 + do 10 i=8,1,-1 + if (work(i:i) .ne. ' ')go to 15 + nspace=nspace+1 +10 continue +15 continue + +C prepend sequence number to keyword root only if there is room + if (nseq .lt. 0)then +C illegal value + go to 900 + else if (nseq .lt. 10 .and. nspace .ge. 1)then + write(keyout,1001,err=900)nseq,work(1:7) + else if (nseq .lt. 100 .and. nspace .ge. 2)then + write(keyout,1002,err=900)nseq,work(1:6) + else if (nseq .lt. 1000 .and. nspace .ge. 3)then + write(keyout,1003,err=900)nseq,work(1:5) + else if (nseq .lt. 10000 .and. nspace .ge. 4)then + write(keyout,1004,err=900)nseq,work(1:4) + else if (nseq .lt. 100000 .and. nspace .ge. 5)then + write(keyout,1005,err=900)nseq,work(1:3) + else if (nseq .lt. 1000000 .and. nspace .ge. 6)then + write(keyout,1006,err=900)nseq,work(1:2) + else if (nseq .lt. 10000000 .and. nspace .ge. 7)then + write(keyout,1007,err=900)nseq,work(1:1) + else +C number too big to fit in keyword + go to 900 + end if + +1001 format(i1,a7) +1002 format(i2,a6) +1003 format(i3,a5) +1004 format(i4,a4) +1005 format(i5,a3) +1006 format(i6,a2) +1007 format(i7,a1) + + return +C come here if error concatinating the seq. no. to the root string +900 continue + + if (status .gt. 0)return + status=206 + write(value,1008)nseq +1008 format(i20) + call ftpmsg('Could not concatinate the integer '//value// + & ' and the root keyword named: '//work) + end diff --git a/pkg/tbtables/fitsio/ftnulc.f b/pkg/tbtables/fitsio/ftnulc.f new file mode 100644 index 00000000..bb07ffd4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftnulc.f @@ -0,0 +1,78 @@ +C-------------------------------------------------------------------------- + subroutine ftnulc(input,np,chktyp,setval,flgray,anynul, + & scaled,scale,zero) + +C check input complex array for nulls and apply scaling +C if chktyp=1 then set the undefined pixel = SETVAL +C if chktyp=2 then set the corresponding FLGRAY = .true. + +C When scaling complex data values, both the real and imaginary +C components of the value are scaled by SCALE, but the offset +C given by ZERO is only applied to the real part of the complex number + +C input r input array of values +C np i number of pairs of values +C chktyp i type of null value checking to be done if TOFITS=.false. +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C scaled l does data need to be scaled? +C scale d scale factor +C zero d offset + + real input(*),setval(2) + integer np,i,chktyp,j + double precision scale,zero + logical flgray(*),anynul,scaled + logical fttrnn + external fttrnn + + if (chktyp .eq. 2)then +C initialize the null flag values + do 5 i=1,np + flgray(i)=.false. +5 continue + end if + + j=1 + do 10 i=1,np +C do the real part of the complex number + if (chktyp .ne. 0 .and. fttrnn(input(j)))then + anynul=.true. + if (chktyp .eq. 1)then +C set both parts of the complex number to the +C specified special value + input(j)=setval(1) + input(j+1)=setval(2) + else +C set the corresponding flag value to true + flgray(i)=.true. + end if + j=j+2 + else if (scaled)then + input(j)=input(j)*scale+zero + j=j+1 + +C do the imaginary part of the complex number + if (chktyp .ne. 0 .and. fttrnn(input(j)))then + anynul=.true. + if (chktyp .eq. 1)then +C set both parts of the complex number to the +C specified special value + input(j-1)=setval(1) + input(j)=setval(2) + else +C set the corresponding flag value to true + flgray(i)=.true. + end if + else if (scaled)then + input(j)=input(j)*scale + end if + j=j+1 + else + j=j+2 + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftnulm.f b/pkg/tbtables/fitsio/ftnulm.f new file mode 100644 index 00000000..c3aa7461 --- /dev/null +++ b/pkg/tbtables/fitsio/ftnulm.f @@ -0,0 +1,78 @@ +C-------------------------------------------------------------------------- + subroutine ftnulm(input,np,chktyp,setval,flgray,anynul, + & scaled,scale,zero) + +C check input double complex array for nulls and apply scaling +C if chktyp=1 then set the undefined pixel = SETVAL +C if chktyp=2 then set the corresponding FLGRAY = .true. + +C When scaling complex data values, both the real and imaginary +C components of the value are scaled by SCALE, but the offset +C given by ZERO is only applied to the real part of the complex number + +C input d input array of values +C np i number of pairs of values +C chktyp i type of null value checking to be done if TOFITS=.false. +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C scaled l does data need to be scaled? +C scale d scale factor +C zero d offset + + double precision input(*),setval(2) + integer np,i,chktyp,j + double precision scale,zero + logical flgray(*),anynul,scaled + logical fttdnn + external fttdnn + + if (chktyp .eq. 2)then +C initialize the null flag values + do 5 i=1,np + flgray(i)=.false. +5 continue + end if + + j=1 + do 10 i=1,np +C do the real part of the complex number + if (chktyp .ne. 0 .and. fttdnn(input(j)))then + anynul=.true. + if (chktyp .eq. 1)then +C set both parts of the complex number to the +C specified special value + input(j)=setval(1) + input(j+1)=setval(2) + else +C set the corresponding flag value to true + flgray(i)=.true. + end if + j=j+2 + else if (scaled)then + input(j)=input(j)*scale+zero + j=j+1 + +C do the imaginary part of the complex number + if (chktyp .ne. 0 .and. fttdnn(input(j)))then + anynul=.true. + if (chktyp .eq. 1)then +C set both parts of the complex number to the +C specified special value + input(j-1)=setval(1) + input(j)=setval(2) + else +C set the corresponding flag value to true + flgray(i)=.true. + end if + else if (scaled)then + input(j)=input(j)*scale + end if + j=j+1 + else + j=j+2 + end if +10 continue + end diff --git a/pkg/tbtables/fitsio/ftopen.f b/pkg/tbtables/fitsio/ftopen.f new file mode 100644 index 00000000..c1c78a04 --- /dev/null +++ b/pkg/tbtables/fitsio/ftopen.f @@ -0,0 +1,58 @@ +C-------------------------------------------------------------------------- + subroutine ftopen(funit,fname,rwmode,block,status) + +C open an existing FITS file with readonly or read/write access +C +C funit i Fortran I/O unit number +C fname c name of file to be opened +C rwmode i file access mode: 0 = readonly; else = read and write +C block i returned record length blocking factor +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer funit,rwmode,block,status,strlen,i,xtend + character*(*) fname + + if (status .gt. 0)return + +C ignore any leading blanks in the file name + strlen=len(fname) + do 10 i=1,strlen + if (fname(i:i) .ne. ' ')then + +C call the machine dependent routine which opens the file + call ftopnx(funit,fname(i:),0,rwmode,block,status) + if (status .gt. 0)then + call ftpmsg('FTOPEN failed to Find and/or Open'// + & ' the following file:') + call ftpmsg(fname) + return + end if + +C set column descriptors as undefined + call ftfrcl(funit,-999) + +C determine the structure and size of the primary HDU + call ftrhdu(funit,xtend,status) + if (status .gt. 0)then + call ftpmsg('FTOPEN could not interpret primary ' + & //'array header keywords of file:') + call ftpmsg(fname) + if (status .eq. 252)then + call ftpmsg('Is this a FITS file??') + end if + end if + +C set current column name buffer as undefined + call ftrsnm + return + end if +10 continue + +C if we got here, then the input filename was all blanks + status=104 + call ftpmsg('FTOPEN: Name of file to open is blank.') + return + + end diff --git a/pkg/tbtables/fitsio/ftp2db.f b/pkg/tbtables/fitsio/ftp2db.f new file mode 100644 index 00000000..d09670a5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp2db.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftp2db(ounit,group,dim1,nx,ny,array,status) + +C Write a 2-d image of byte values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array c*1 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + character*1 array(dim1,*) + integer fpixel,row + + fpixel=1 + do 10 row = 1,ny + call ftpprb(ounit,group,fpixel,nx,array(1,row),status) + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftp2dd.f b/pkg/tbtables/fitsio/ftp2dd.f new file mode 100644 index 00000000..359e70b9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp2dd.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftp2dd(ounit,group,dim1,nx,ny,array,status) + +C Write a 2-d image of r*8 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array d the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + double precision array(dim1,*) + integer fpixel,row + + fpixel=1 + do 10 row = 1,ny + call ftpprd(ounit,group,fpixel,nx,array(1,row),status) + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftp2de.f b/pkg/tbtables/fitsio/ftp2de.f new file mode 100644 index 00000000..f5ef23cf --- /dev/null +++ b/pkg/tbtables/fitsio/ftp2de.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftp2de(ounit,group,dim1,nx,ny,array,status) + +C Write a 2-d image of r*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array r the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + real array(dim1,*) + integer fpixel,row + + fpixel=1 + do 10 row = 1,ny + call ftppre(ounit,group,fpixel,nx,array(1,row),status) + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftp2di.f b/pkg/tbtables/fitsio/ftp2di.f new file mode 100644 index 00000000..5c59e2b5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp2di.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftp2di(ounit,group,dim1,nx,ny,array,status) + +C Write a 2-d image of i*2 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array i*2 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + integer*2 array(dim1,*) + integer fpixel,row + + fpixel=1 + do 10 row = 1,ny + call ftppri(ounit,group,fpixel,nx,array(1,row),status) + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftp2dj.f b/pkg/tbtables/fitsio/ftp2dj.f new file mode 100644 index 00000000..5d0f6e25 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp2dj.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftp2dj(ounit,group,dim1,nx,ny,array,status) + +C Write a 2-d image of i*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C nx i size of the image in the x direction +C ny i size of the image in the y direction +C array i the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,nx,ny,status + integer array(dim1,*) + integer fpixel,row + + fpixel=1 + do 10 row = 1,ny + call ftpprj(ounit,group,fpixel,nx,array(1,row),status) + fpixel=fpixel+nx +10 continue + + end diff --git a/pkg/tbtables/fitsio/ftp3db.f b/pkg/tbtables/fitsio/ftp3db.f new file mode 100644 index 00000000..bf38e6f6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp3db.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftp3db(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +C Write a 3-d cube of byte values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array c*1 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + character*1 array(dim1,dim2,*) + integer fpixel,row,band + + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftpprb(ounit,group,fpixel,nx,array(1,row,band),status) + fpixel=fpixel+nx +10 continue +20 continue + + end diff --git a/pkg/tbtables/fitsio/ftp3dd.f b/pkg/tbtables/fitsio/ftp3dd.f new file mode 100644 index 00000000..469fbfc3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp3dd.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftp3dd(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +C Write a 3-d cube of r*8 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array r*8 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + double precision array(dim1,dim2,*) + integer fpixel,row,band + + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftpprd(ounit,group,fpixel,nx,array(1,row,band),status) + fpixel=fpixel+nx +10 continue +20 continue + + end diff --git a/pkg/tbtables/fitsio/ftp3de.f b/pkg/tbtables/fitsio/ftp3de.f new file mode 100644 index 00000000..6bcb9cd3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp3de.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftp3de(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +C Write a 3-d cube of r*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array r the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + real array(dim1,dim2,*) + integer fpixel,row,band + + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftppre(ounit,group,fpixel,nx,array(1,row,band),status) + fpixel=fpixel+nx +10 continue +20 continue + + end diff --git a/pkg/tbtables/fitsio/ftp3di.f b/pkg/tbtables/fitsio/ftp3di.f new file mode 100644 index 00000000..0f1e8eea --- /dev/null +++ b/pkg/tbtables/fitsio/ftp3di.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftp3di(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +C Write a 3-d cube of i*2 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array i*2 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + integer*2 array(dim1,dim2,*) + integer fpixel,row,band + + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftppri(ounit,group,fpixel,nx,array(1,row,band),status) + fpixel=fpixel+nx +10 continue +20 continue + + end diff --git a/pkg/tbtables/fitsio/ftp3dj.f b/pkg/tbtables/fitsio/ftp3dj.f new file mode 100644 index 00000000..3c191672 --- /dev/null +++ b/pkg/tbtables/fitsio/ftp3dj.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftp3dj(ounit,group,dim1,dim2,nx,ny,nz,array,status) + +C Write a 3-d cube of i*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C dim1 i actual first dimension of ARRAY +C dim2 i actual second dimension of ARRAY +C nx i size of the cube in the x direction +C ny i size of the cube in the y direction +C nz i size of the cube in the z direction +C array i the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,dim1,dim2,nx,ny,nz,status + integer array(dim1,dim2,*) + integer fpixel,row,band + + fpixel=1 + do 20 band=1,nz + do 10 row = 1,ny + call ftpprj(ounit,group,fpixel,nx,array(1,row,band),status) + fpixel=fpixel+nx +10 continue +20 continue + + end diff --git a/pkg/tbtables/fitsio/ftpbit.f b/pkg/tbtables/fitsio/ftpbit.f new file mode 100644 index 00000000..793a8509 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpbit.f @@ -0,0 +1,111 @@ +C---------------------------------------------------------------------- + subroutine ftpbit(setbit,wrbit,buffer) + +C encode the individual bits within the byte as specified by +C the input logical array. The corresponding bit is set to +C 1 if the logical array element is true. Only the bits +C between begbit and endbit, inclusive, are set or reset; +C the remaining bits, if any, remain unchanged. + +C setbit l input array of logical data values corresponding +C to the bits to be set in the output buffer +C TRUE means corresponding bit is to be set. +C wrbit l input array of logical values indicating which +C bits in the byte are to be modified. If FALSE, +C then the corresponding bit should remain unchanged. +C buffer i output integer containing the encoded byte +C +C written by Wm Pence, HEASARC/GSFC, May 1992 + + integer buffer,tbuff,outbit + logical setbit(8),wrbit(8) + + outbit=0 + tbuff=buffer + +C test each of the 8 bits, starting with the most significant + if (tbuff .gt. 127)then +C the bit is currently set in the word + if (wrbit(1) .and. (.not.setbit(1)))then +C only in this case do we reset the bit + else +C in all other cases we want the bit to be set + outbit=outbit+128 + end if + tbuff=tbuff-128 + else +C bit is currently not set; set it only if requested to + if (wrbit(1) .and. setbit(1))outbit=outbit+128 + end if + + if (tbuff .gt. 63)then + if (wrbit(2) .and. (.not.setbit(2)))then + else + outbit=outbit+64 + end if + tbuff=tbuff-64 + else + if (wrbit(2) .and. setbit(2))outbit=outbit+64 + end if + + if (tbuff .gt. 31)then + if (wrbit(3) .and. (.not.setbit(3)))then + else + outbit=outbit+32 + end if + tbuff=tbuff-32 + else + if (wrbit(3) .and. setbit(3))outbit=outbit+32 + end if + + if (tbuff .gt. 15)then + if (wrbit(4) .and. (.not.setbit(4)))then + else + outbit=outbit+16 + end if + tbuff=tbuff-16 + else + if (wrbit(4) .and. setbit(4))outbit=outbit+16 + end if + + if (tbuff .gt. 7)then + if (wrbit(5) .and. (.not.setbit(5)))then + else + outbit=outbit+8 + end if + tbuff=tbuff-8 + else + if (wrbit(5) .and. setbit(5))outbit=outbit+8 + end if + + if (tbuff .gt. 3)then + if (wrbit(6) .and. (.not.setbit(6)))then + else + outbit=outbit+4 + end if + tbuff=tbuff-4 + else + if (wrbit(6) .and. setbit(6))outbit=outbit+4 + end if + + if (tbuff .gt. 1)then + if (wrbit(7) .and. (.not.setbit(7)))then + else + outbit=outbit+2 + end if + tbuff=tbuff-2 + else + if (wrbit(7) .and. setbit(7))outbit=outbit+2 + end if + + if (tbuff .eq. 1)then + if (wrbit(8) .and. (.not.setbit(8)))then + else + outbit=outbit+1 + end if + else + if (wrbit(8) .and. setbit(8))outbit=outbit+1 + end if + + buffer=outbit + end diff --git a/pkg/tbtables/fitsio/ftpbnh.f b/pkg/tbtables/fitsio/ftpbnh.f new file mode 100644 index 00000000..ed03adff --- /dev/null +++ b/pkg/tbtables/fitsio/ftpbnh.f @@ -0,0 +1,12 @@ +C---------------------------------------------------------------------- + subroutine ftpbnh(ounit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + +C OBSOLETE routine: should call ftphbn instead + + integer ounit,nrows,nfield,pcount,status + character*(*) ttype(*),tform(*),tunit(*),extnam + + call ftphbn(ounit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + end diff --git a/pkg/tbtables/fitsio/ftpcks.f b/pkg/tbtables/fitsio/ftpcks.f new file mode 100644 index 00000000..f09bbdd6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcks.f @@ -0,0 +1,170 @@ +C---------------------------------------------------------------------- + subroutine ftpcks(iunit,status) + +C Create or update the checksum keywords in the CHU. These keywords +C provide a checksum verification of the FITS HDU based on the ASCII +C coded 1's complement checksum algorithm developed by Rob Seaman at NOAO. + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Sept, 1994 + + integer iunit,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nf = 3000) + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + double precision sum,dsum,odsum + integer ibuff,nrec,dd,mm,yy,dummy,i,tstat + character datstr*8,string*16,comm*40,oldcks*16,datsum*20 + logical complm + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C generate current date string to put into the keyword comment + call ftgsdt(dd,mm,yy,status) + if (status .gt. 0)return + + datstr=' / / ' + write(datstr(1:2),1001)dd + write(datstr(4:5),1001)mm + write(datstr(7:8),1001)yy +1001 format(i2) + +C replace blank with leading 0 in each field if required + if (datstr(1:1) .eq. ' ')datstr(1:1)='0' + if (datstr(4:4) .eq. ' ')datstr(4:4)='0' + if (datstr(7:7) .eq. ' ')datstr(7:7)='0' + +C get the checksum keyword, if it exists, otherwise initialize it + tstat=status + call ftgkys(iunit,'CHECKSUM',oldcks,comm,status) + if (status .eq. 202)then + status=tstat + oldcks=' ' + comm='encoded HDU checksum updated on '//datstr + call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status) + end if + +C get the DATASUM keyword and convert it to a double precision value +C if it exists, otherwise initialize it + tstat=status + call ftgkys(iunit,'DATASUM',datsum,comm,status) + if (status .eq. 202)then + status=tstat + odsum=0. +C set the CHECKSUM keyword as undefined + oldcks=' ' + comm='data unit checksum updated on '//datstr + call ftpkys(iunit,'DATASUM',' 0',comm,status) + else +C decode the datasum into a double precision variable + do 10 i=1,20 + if (datsum(i:i) .ne. ' ')then + call ftc2dd(datsum(i:20),odsum,status) + if (status .eq. 409)then +C couldn't read the keyword; assume it is out of date + status=tstat + odsum=-1. + end if + go to 15 + end if +10 continue + odsum=0. + end if + +C rewrite the header END card, and following blank fill +15 call ftwend(iunit,status) + if (status .gt. 0)return + +C now re-read the required keywords to determine the structure + call ftrhdu(iunit,dummy,status) + +C write the correct data fill values, if they are not already correct + call ftpdfl(iunit,status) + +C calc. checksum of the data records; first, calc number of data records + nrec=(hdstrt(ibuff,chdu(ibuff)+1)-dtstrt(ibuff))/2880 + dsum=0. + + if (nrec .gt. 0)then +C move to the start of the data + call ftmbyt(iunit,dtstrt(ibuff),.true.,status) + +C accumulate the 32-bit 1's complement checksum + call ftcsum(iunit,nrec,dsum,status) + end if + + if (dsum .ne. odsum)then +C modify the DATASUM keyword with the correct value + comm='data unit checksum updated on '//datstr +C write the datasum into an I10 integer string + write(datsum,2000)dsum +2000 format(f11.0) + call ftmkys(iunit,'DATASUM',datsum(1:10),comm,status) +C set the CHECKSUM keyword as undefined + oldcks=' ' + end if + +C if DATASUM was correct, check if CHECKSUM is still OK + if (oldcks .ne. ' ')then + +C move to the start of the header + call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) + +C accumulate the header checksum into the previous data checksum + nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 + sum=dsum + call ftcsum(iunit,nrec,sum,status) + +C encode the COMPLEMENT of the checksum into a 16-character string + complm=.true. + call ftesum(sum,complm,string) + +C return if the checksum is correct + if (string .eq. '0000000000000000')then + return + else if (oldcks .eq. '0000000000000000')then +C update the CHECKSUM keyword value with the checksum string + call ftmkys(iunit,'CHECKSUM',string,'&',status) + return + end if + end if + +C Zero the checksum and compute the new value + comm='encoded HDU checksum updated on '//datstr + call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status) + +C move to the start of the header + call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) + +C accumulate the header checksum into the previous data checksum + nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 + sum=dsum + call ftcsum(iunit,nrec,sum,status) + +C encode the COMPLEMENT of the checksum into a 16-character string + complm=.true. + call ftesum(sum,complm,string) + +C update the CHECKSUM keyword value with the checksum string + call ftmkys(iunit,'CHECKSUM',string,'&',status) + end diff --git a/pkg/tbtables/fitsio/ftpclb.f b/pkg/tbtables/fitsio/ftpclb.f new file mode 100644 index 00000000..f8f045ec --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclb.f @@ -0,0 +1,318 @@ +C---------------------------------------------------------------------- + subroutine ftpclb(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of unsigned byte data values to the +C specified column of the table. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array i array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + character*1 array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + double precision scale,zero,dval + real rval + character sval*40,wform*10,crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,lval,descrp + integer*2 i2val + character*1 i1val + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLB).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) +C the data are being scaled from internal format to FITS: + tofits=.true. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) + maxpix=bufdim/bytpix*4 + +C incre is the byte offset between consecutive pixels + incre=0 + if (tcode .eq. 16)then +C this is an ASCII table; table elements cannot be vectors + repeat=1 + estart=0 + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLB).') + return + else + estart=felem-1 + end if + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLB).') + return + end if + + if (repeat .eq. 1 .and. nelem .gt. 1)then +C write multiple rows of data at one time + incre=rowlen(ibuff) + repeat=maxpix + estart=0 + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + end if + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C copy data to buffer, doing scaling and datatype conversion, if required + if (tcode .eq. 11)then +C column data type is B (byte) + call fti1i1(array(i1),itodo,scale,zero,tofits, + & ival,i1val,i1val,lval,lval,chbuff,status) +C do any machine dependent conversion and write the byte data + call ftpi1b(ounit,itodo,incre,chbuff,status) + else if (tcode .eq. 21)then +C column data type is I (I*2) + call fti1i2(array(i1),itodo,scale,zero,tofits, + & ival,i1val,i2val,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*2 data + call ftpi2b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 41)then +C column data type is J (I*4) + call fti1i4(array(i1),itodo,scale,zero,tofits, + & ival,i1val,ival,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*4 data + call ftpi4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 42)then +C column data type is E (R*4) + call fti1r4(array(i1),itodo,scale,zero,tofits, + & ival,i1val,rval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*4 data + call ftpr4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 82)then +C column data type is D (R*8) + call fti1r8(array(i1),itodo,scale,zero,tofits, + & ival,i1val,dval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*8 data + call ftpr8b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column + wform='( )' + wform(2:9)=cform(colnum+tstart(ibuff)) + if (cform(colnum+tstart(ibuff))(1:1) .eq. 'I')then +C column data type is integer + call fti1i4(array(i1),itodo,scale,zero,tofits, + & ival,i1val,ival,lval,lval,ival,status) +C create the formated character string + write(sval,wform,err=900)ival +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'F' + & .or. cform(colnum+tstart(ibuff))(1:1) .eq. 'E')then +C column data type is real + call fti1r4(array(i1),itodo,scale,zero,tofits, + & ival,i1val,rval,lval,lval,rval,status) +C create the formated character string + write(sval,wform,err=900)rval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'D')then +C column data type is double precision + call fti1r8(array(i1),itodo,scale,zero,tofits, + & ival,i1val,dval,lval,lval,dval,status) +C create the formated character string + write(sval,wform,err=900)dval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot write byte (I*1) values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLB).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot write byte (I*1) values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLB).') + return + end if + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing pixels'//cp1//' to'//cp2 + & // ' to the FITS image array (FTPCLB).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLB.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLB).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLB).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + if (incre .eq. 0)then + rstart=rstart+1 + else + rstart=rstart+repeat + end if + end if + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred writing '// + & 'Byte data to FITS file.') + end if + return + +900 continue +C error writing formatted data value to ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error writing colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to write value'// + & '" with format '//wform//' (FTPCLB).') + status=313 + end diff --git a/pkg/tbtables/fitsio/ftpclc.f b/pkg/tbtables/fitsio/ftpclc.f new file mode 100644 index 00000000..a83af536 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclc.f @@ -0,0 +1,188 @@ +C---------------------------------------------------------------------- + subroutine ftpclc(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of single precision complex data values to the +C specified column of the table. +C The binary table column being written to must have datatype 'C' +C and no datatype conversion will be perform if it is not. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array cmp array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status +C the input array is really complex data type + real array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 200) + integer bytpix,bstart,tcode + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix + real buffer(bufdim) + double precision scale,zero + logical descrp,scaled + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLC).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + i1=1 +C multiply by 2, because the complex data type has pairs of values + ntodo=nelem*2 + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + if (scale .eq. 1. .and. zero .eq. 0.)then + scaled=.false. + else + scaled=.true. + end if + tcode=tdtype(colnum+tstart(ibuff)) + + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLC).') + return + else +C multiply by 2 because the complex data type has pairs of values + estart=(felem-1)*2 + end if + +C calculate the maximum number of column pixels which fit in buffer + bytpix=4 + maxpix=bufdim/bytpix*4 + + if (tcode .eq. 83)then + repeat=trept(colnum+tstart(ibuff))*2 + if (felem*2 .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLC).') + return + end if + descrp=.false. + else if (tcode .eq. -83)then +C this is a variable length descriptor column + descrp=.true. + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) + repeat=repeat*2 +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + else +C error illegal table data type code + status=312 + return + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C scale data into buffer, + call ftuscc(array(i1),itodo,scaled,scale,zero,buffer) + +C do any machine dependent data conversion and write the R*4 data + call ftpr4b(ounit,itodo,0,buffer,status) + + if (status .gt. 0)then + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLC.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLC).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLC).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftpcld.f b/pkg/tbtables/fitsio/ftpcld.f new file mode 100644 index 00000000..83a47f11 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcld.f @@ -0,0 +1,320 @@ +C---------------------------------------------------------------------- + subroutine ftpcld(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of double precision data values to the specified column +C of the table. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array d array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + double precision array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,incre + double precision dbuffr(50) + equivalence (buffer,dbuffr) + + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + real rval + double precision scale,zero,dval + character sval*40,wform*10,crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,lval,descrp + integer*2 i2val + character*1 i1val + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLD).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) +C the data are being scaled from internal format to FITS: + tofits=.true. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) + maxpix=bufdim/bytpix*4 + +C incre is the byte offset between consecutive pixels + incre=0 + if (tcode .eq. 16)then +C this is an ASCII table; table elements cannot be vectors + repeat=1 + estart=0 + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLD).') + return + else + estart=felem-1 + end if + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLD).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C write multiple rows of data at one time + incre=rowlen(ibuff) + repeat=maxpix + estart=0 + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + end if + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C copy data to buffer, doing scaling and datatype conversion, if required + if (tcode .eq. 21)then +C column data type is I (I*2) + call ftr8i2(array(i1),itodo,scale,zero,tofits, + & ival,i2val,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*2 data + call ftpi2b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 41)then +C column data type is J (I*4) + call ftr8i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*4 data + call ftpi4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 42)then +C column data type is E (R*4) + call ftr8r4(array(i1),itodo,scale,zero,tofits, + & ival,rval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*4 data + call ftpr4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 82)then +C column data type is D (R*8) + call ftr8r8(array(i1),itodo,scale,zero,tofits, + & ival,dval,lval,lval,dbuffr,status) +C do any machine dependent conversion and write the R*8 data + call ftpr8b(ounit,itodo,incre,dbuffr,status) + else if (tcode .eq. 11)then +C column data type is B (byte) + call ftr8i1(array(i1),itodo,scale,zero,tofits, + & ival,i1val,lval,lval,chbuff,status) +C do any machine dependent data conversion and write the byte data + call ftpi1b(ounit,itodo,incre,chbuff,status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column + wform='( )' + wform(2:9)=cform(colnum+tstart(ibuff)) + if (cform(colnum+tstart(ibuff))(1:1) .eq. 'I')then +C column data type is integer + call ftr8i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,lval,lval,ival,status) +C create the formated character string + write(sval,wform,err=900)ival +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'F' + & .or. cform(colnum+tstart(ibuff))(1:1) .eq. 'E')then +C column data type is real + call ftr8r4(array(i1),itodo,scale,zero,tofits, + & ival,rval,lval,lval,rval,status) +C create the formated character string + write(sval,wform,err=900)rval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'D')then +C column data type is double precision + call ftr8r8(array(i1),itodo,scale,zero,tofits, + & ival,dval,lval,lval,dval,status) +C create the formated character string + write(sval,wform,err=900)dval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot write Double values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLD).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot write Double values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLD).') + return + end if + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing pixels'//cp1//' to'//cp2 + & // ' to the FITS image array (FTPCLD).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLD.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLD).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLD).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + if (incre .eq. 0)then + rstart=rstart+1 + else + rstart=rstart+repeat + end if + end if + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred writing '// + & 'Real*8 data to FITS file.') + end if + return + +900 continue +C error writing formatted data value to ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error writing colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to write value'// + & '" with format '//wform//' (FTPCLE).') + status=313 + end diff --git a/pkg/tbtables/fitsio/ftpcle.f b/pkg/tbtables/fitsio/ftpcle.f new file mode 100644 index 00000000..47649460 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcle.f @@ -0,0 +1,317 @@ +C---------------------------------------------------------------------- + subroutine ftpcle(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of real data values to the specified column of +C the table. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array r array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + real array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + real rval + double precision scale,zero,dval + character sval*40,wform*10,crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,lval,descrp + integer*2 i2val + character*1 i1val + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLE).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) +C the data are being scaled from internal format to FITS: + tofits=.true. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) + maxpix=bufdim/bytpix*4 + +C incre is the byte offset between consecutive pixels + incre=0 + if (tcode .eq. 16)then +C this is an ASCII table; table elements cannot be vectors + repeat=1 + estart=0 + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLE).') + return + else + estart=felem-1 + end if + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLE).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C write multiple rows of data at one time + incre=rowlen(ibuff) + repeat=maxpix + estart=0 + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + end if + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C copy data to buffer, doing scaling and datatype conversion, if required + if (tcode .eq. 21)then +C column data type is I (I*2) + call ftr4i2(array(i1),itodo,scale,zero,tofits, + & ival,i2val,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*2 data + call ftpi2b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 41)then +C column data type is J (I*4) + call ftr4i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*4 data + call ftpi4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 42)then +C column data type is E (R*4) + call ftr4r4(array(i1),itodo,scale,zero,tofits, + & ival,rval,lval,lval,buffer,status) +C do any machine dependent conversion and write the R*4 data + call ftpr4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 82)then +C column data type is D (R*8) + call ftr4r8(array(i1),itodo,scale,zero,tofits, + & ival,dval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*8 data + call ftpr8b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 11)then +C column data type is B (byte) + call ftr4i1(array(i1),itodo,scale,zero,tofits, + & ival,i1val,lval,lval,chbuff,status) +C do any machine dependent data conversion and write the byte data + call ftpi1b(ounit,itodo,incre,chbuff,status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column + wform='( )' + wform(2:9)=cform(colnum+tstart(ibuff)) + if (cform(colnum+tstart(ibuff))(1:1) .eq. 'I')then +C column data type is integer + call ftr4i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,lval,lval,ival,status) +C create the formated character string + write(sval,wform,err=900)ival +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'F' + & .or. cform(colnum+tstart(ibuff))(1:1) .eq. 'E')then +C column data type is real + call ftr4r4(array(i1),itodo,scale,zero,tofits, + & ival,rval,lval,lval,rval,status) +C create the formated character string + write(sval,wform,err=900)rval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'D')then +C column data type is double precision + call ftr4r8(array(i1),itodo,scale,zero,tofits, + & ival,dval,lval,lval,dval,status) +C create the formated character string + write(sval,wform,err=900)dval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot write Real values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLE).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot write Real values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLE).') + return + end if + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing pixels'//cp1//' to'//cp2 + & // ' to the FITS image array (FTPCLE).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLE.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLE).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLE).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + if (incre .eq. 0)then + rstart=rstart+1 + else + rstart=rstart+repeat + end if + end if + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred writing '// + & 'Real*4 data to FITS file.') + end if + return + +900 continue +C error writing formatted data value to ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error writing colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to write value'// + & '" with format '//wform//' (FTPCLE).') + status=313 + end diff --git a/pkg/tbtables/fitsio/ftpcli.f b/pkg/tbtables/fitsio/ftpcli.f new file mode 100644 index 00000000..cbed853a --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcli.f @@ -0,0 +1,316 @@ +C---------------------------------------------------------------------- + subroutine ftpcli(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of integer*2 data values to the specified column of +C the table. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array i*2 array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + integer*2 array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + real rval + double precision scale,zero,dval + character sval*40,wform*10,crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,lval,descrp + integer*2 i2val + character*1 i1val + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLI).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) +C the data are being scaled from internal format to FITS: + tofits=.true. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) + maxpix=bufdim/bytpix*4 + +C incre is the byte offset between consecutive pixels + incre=0 + if (tcode .eq. 16)then +C this is an ASCII table; table elements cannot be vectors + repeat=1 + estart=0 + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLI).') + return + else + estart=felem-1 + end if + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLI).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C write multiple rows of data at one time + incre=rowlen(ibuff) + repeat=maxpix + estart=0 + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + end if + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C copy data to buffer, doing scaling and datatype conversion, if required + if (tcode .eq. 21)then + call fti2i2(array(i1),itodo,scale,zero,tofits, + & ival,i2val,i2val,lval,lval,buffer,status) +C do any machine dependent conversion and write the I*2 data + call ftpi2b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 41)then +C column data type is J (I*4) + call fti2i4(array(i1),itodo,scale,zero,tofits, + & ival,i2val,ival,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*4 data + call ftpi4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 42)then +C column data type is E (R*4) + call fti2r4(array(i1),itodo,scale,zero,tofits, + & ival,i2val,rval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*4 data + call ftpr4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 82)then +C column data type is D (R*8) + call fti2r8(array(i1),itodo,scale,zero,tofits, + & ival,i2val,dval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*8 data + call ftpr8b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 11)then +C column data type is B (byte) + call fti2i1(array(i1),itodo,scale,zero,tofits, + & ival,i2val,i1val,lval,lval,chbuff,status) +C do any machine dependent data conversion and write the byte data + call ftpi1b(ounit,itodo,incre,chbuff,status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column + wform='( )' + wform(2:9)=cform(colnum+tstart(ibuff)) + if (cform(colnum+tstart(ibuff))(1:1) .eq. 'I')then +C column data type is integer + call fti2i4(array(i1),itodo,scale,zero,tofits, + & ival,i2val,ival,lval,lval,ival,status) +C create the formated character string + write(sval,wform,err=900)ival +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'F' + & .or. cform(colnum+tstart(ibuff))(1:1) .eq. 'E')then +C column data type is real + call fti2r4(array(i1),itodo,scale,zero,tofits, + & ival,i2val,rval,lval,lval,rval,status) +C create the formated character string + write(sval,wform,err=900)rval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'D')then +C column data type is double precision + call fti2r8(array(i1),itodo,scale,zero,tofits, + & ival,i2val,dval,lval,lval,dval,status) +C create the formated character string + write(sval,wform,err=900)dval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot write Integer*2 values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLI).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot write Integer*2 values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLI).') + return + end if + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing pixels'//cp1//' to'//cp2 + & // ' to the FITS image array (FTPCLI).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLI.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLI).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLI).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + if (incre .eq. 0)then + rstart=rstart+1 + else + rstart=rstart+repeat + end if + end if + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred writing '// + & 'Integer*2 data to FITS file.') + end if + return + +900 continue +C error writing formatted data value to ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error writing colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to write value'// + & '" with format '//wform//' (FTPCLI).') + status=313 + end diff --git a/pkg/tbtables/fitsio/ftpclj.f b/pkg/tbtables/fitsio/ftpclj.f new file mode 100644 index 00000000..a3c86a61 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclj.f @@ -0,0 +1,320 @@ +C---------------------------------------------------------------------- + subroutine ftpclj(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of integer data values to the specified column of +C the table. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array i array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + integer array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character*1 chbuff(400),xdummy(5360) + common/ftheap/chbuff,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bufdim + parameter (bufdim = 100) + integer buffer(bufdim),bytpix,bstart,tcode,incre + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix,ival + real rval + double precision scale,zero,dval,align + character sval*40,wform*10,crow*9,cp1*9,cp2*9,ccol*4 + logical tofits,lval,descrp + integer*2 i2val + character*1 i1val +C the following equivalence is required for the HP/UX PA-RISC complier +C to force the buffer to be double word aligned. + equivalence (align,buffer(1)) + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLJ).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + descrp=.false. + i1=1 + ntodo=nelem + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + tcode=tdtype(colnum+tstart(ibuff)) +C the data are being scaled from internal format to FITS: + tofits=.true. + +C calculate the maximum number of column pixels which fit in buffer + bytpix=max(abs(tcode)/10,1) + maxpix=bufdim/bytpix*4 + +C incre is the byte offset between consecutive pixels + incre=0 + if (tcode .eq. 16)then +C this is an ASCII table; table elements cannot be vectors + repeat=1 + estart=0 + else +C this is a binary table + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLJ).') + return + else + estart=felem-1 + end if + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLJ).') + return + end if + if (repeat .eq. 1 .and. nelem .gt. 1)then +C write multiple rows of data at one time + incre=rowlen(ibuff) + repeat=maxpix + estart=0 + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + end if + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C copy data to buffer, doing scaling and datatype conversion, if required + if (tcode .eq. 21)then +C column data type is I (I*2) + call fti4i2(array(i1),itodo,scale,zero,tofits, + & ival,ival,i2val,lval,lval,buffer,status) +C do any machine dependent data conversion and write the I*2 data + call ftpi2b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 41)then +C column data type is J (I*4) + call fti4i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,ival,lval,lval,buffer,status) +C do any machine dependent conversion and write the I*4 data + call ftpi4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 42)then +C column data type is E (R*4) + call fti4r4(array(i1),itodo,scale,zero,tofits, + & ival,ival,rval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*4 data + call ftpr4b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 82)then +C column data type is D (R*8) + call fti4r8(array(i1),itodo,scale,zero,tofits, + & ival,ival,dval,lval,lval,buffer,status) +C do any machine dependent data conversion and write the R*8 data + call ftpr8b(ounit,itodo,incre,buffer,status) + else if (tcode .eq. 11)then +C column data type is B (byte) + call fti4i1(array(i1),itodo,scale,zero,tofits, + & ival,ival,i1val,lval,lval,chbuff,status) +C do any machine dependent data conversion and write the byte data + call ftpi1b(ounit,itodo,incre,chbuff,status) + else if (tcode .eq. 16 .and. hdutyp(ibuff) .eq. 1)then +C this is an ASCII table column + wform='( )' + wform(2:9)=cform(colnum+tstart(ibuff)) + if (cform(colnum+tstart(ibuff))(1:1) .eq. 'I')then +C column data type is integer + call fti4i4(array(i1),itodo,scale,zero,tofits, + & ival,ival,ival,lval,lval,ival,status) +C create the formated character string + write(sval,wform,err=900)ival +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'F' + & .or. cform(colnum+tstart(ibuff))(1:1) .eq. 'E')then +C column data type is real + call fti4r4(array(i1),itodo,scale,zero,tofits, + & ival,ival,rval,lval,lval,rval,status) +C create the formated character string + write(sval,wform,err=900)rval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else if (cform(colnum+tstart(ibuff))(1:1) .eq. 'D')then +C column data type is double precision + call fti4r8(array(i1),itodo,scale,zero,tofits, + & ival,ival,dval,lval,lval,dval,status) +C create the formated character string + write(sval,wform,err=900)dval +C write the character string to the FITS file + call ftpcbf(ounit,1,tnull(colnum+tstart(ibuff)),sval, + & status) + else +C error: illegal ASCII table format code + status=311 + write(ccol,2001)colnum + call ftpmsg('Cannot write Integer*4 values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLJ).') + return + end if + else +C error illegal binary table data type code + status=312 + write(ccol,2001)colnum + call ftpmsg('Cannot write Integer*4 values to column'//ccol + & //' with TFORM = '//cform(colnum+tstart(ibuff))//' (FTPCLJ).') + return + end if + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing pixels'//cp1//' to'//cp2 + & // ' to the FITS image array (FTPCLJ).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLJ.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLJ).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLJ).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + if (incre .eq. 0)then + rstart=rstart+1 + else + rstart=rstart+repeat + end if + end if + go to 20 + end if + +C check for any overflows + if (status .eq. -11)then + status=412 + call ftpmsg('Numeric overflow error occurred writing '// + & 'Integer*4 data to FITS file.') + end if + return + +900 continue +C error writing formatted data value to ASCII table + write(ccol,2001)colnum + write(cp1,2000)rstart+1 + call ftpmsg('Error writing colunm'//ccol//', row'//cp1// + & ' of the ASCII Table.') + call ftpmsg('Tried to write value'// + & '" with format '//wform//' (FTPCLJ).') + status=313 + end diff --git a/pkg/tbtables/fitsio/ftpcll.f b/pkg/tbtables/fitsio/ftpcll.f new file mode 100644 index 00000000..43209d90 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcll.f @@ -0,0 +1,162 @@ +C---------------------------------------------------------------------- + subroutine ftpcll(ounit,colnum,frow,felem,nelem,lray,status) + +C write an array of logical values to the specified column of the table. +C The binary table column being written to must have datatype 'L' +C and no datatype conversion will be perform if it is not. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C lray l array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + logical lray(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,maxpix,i + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,tcode + character*1 buffer(80) + character crow*9,cp1*9,cp2*9,ccol*4 + logical descrp + + if (status .gt. 0)return + +C check for zero length array + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLL).') + return + end if + + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLL).') + return + else + estart=felem-1 + end if + + ibuff=bufnum(ounit) +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + i1=1 + ntodo=nelem + rstart=frow-1 + maxpix=80 + +C column must be logical data type + tcode=tdtype(colnum+tstart(ibuff)) + if (tcode .eq. 14)then + descrp=.false. + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLL).') + return + end if + else if (tcode .eq. -14)then + descrp=.true. + repeat=nelem+estart +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat + else +C error illegal data type code + status=310 + return + end if + +C process as many contiguous pixels as possible +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + call ftmbyt(ounit,bstart,.true.,status) + end if + +C create the buffer of logical bytes + do 10 i=1,itodo + if (lray(i1))then + buffer(i)='T' + else + buffer(i)='F' + end if + i1=i1+1 +10 continue + +C write out the buffer + call ftpcbf(ounit,1,itodo,buffer,status) + + if (status .gt. 0)then + write(cp1,2000)i1 + write(cp2,2000)i1+itodo-1 + call ftpmsg('Error while writing values'//cp1//' to'//cp2) + write(ccol,2001)colnum +2001 format(i4) + write(cp1,2000)frow + write(cp2,2000)felem + if (felem .eq. 1)then + call ftpmsg('of column'//ccol//', starting at row'//cp1 + & //' (FTPCLL).') + else + call ftpmsg('of column'//ccol//', starting at row'//cp1 + & //', element'//cp2//' (FTPCLL).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftpclm.f b/pkg/tbtables/fitsio/ftpclm.f new file mode 100644 index 00000000..6508bf98 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclm.f @@ -0,0 +1,186 @@ +C---------------------------------------------------------------------- + subroutine ftpclm(ounit,colnum,frow,felem,nelem,array,status) + +C write an array of double precision complex data values to the +C specified column of the table. +C The binary table column being written to must have datatype 'M' +C and no datatype conversion will be perform if it is not. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array dcmp array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status +C array is really double precison complex + double precision array(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + double precision buffer(100) + integer bytpix,bstart,tcode + integer ibuff,i1,ntodo,itodo,repeat,rstart,estart,maxpix + double precision scale,zero + logical descrp,scaled + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array or bad first row number + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLM).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + i1=1 +C multiply by 2, because the complex data type has pairs of values + ntodo=nelem*2 + rstart=frow-1 + scale=tscale(colnum+tstart(ibuff)) + zero=tzero(colnum+tstart(ibuff)) + if (scale .eq. 1. .and. zero .eq. 0.)then + scaled=.false. + else + scaled=.true. + end if + tcode=tdtype(colnum+tstart(ibuff)) + + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLM).') + return + else +C multiply by 2 because the complex data type has pairs of values + estart=(felem-1)*2 + end if + +C calculate the maximum number of column pixels which fit in buffer + bytpix=8 + maxpix=100 + + if (tcode .eq. 163)then + repeat=trept(colnum+tstart(ibuff))*2 + if (felem*2 .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLM).') + return + end if + descrp=.false. + else if (tcode .eq. -163)then +C this is a variable length descriptor column + descrp=.true. + repeat=nelem+felem-1 +C write the number of elements and the starting offset: + call ftpdes(ounit,colnum,frow,repeat, + & nxheap(ibuff),status) + repeat=repeat*2 +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+nxheap(ibuff)+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+repeat*bytpix + else +C error illegal binary table data type code + status=312 + return + end if + +C process as many contiguous pixels as possible, up to buffer size +20 itodo=min(ntodo,repeat-estart,maxpix) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C scale data into buffer, + call ftuscm(array(i1),itodo,scaled,scale,zero,buffer) + +C do any machine dependent data conversion and write the R*8 data + call ftpr8b(ounit,itodo,0,buffer,status) + + if (status .gt. 0)then + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem+i1-1 + write(cp2,2000)felem+i1+itodo-2 + call ftpmsg('Error writing elements'//cp1//' to'//cp2 + & //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLM.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow+i1-1 + write(cp2,2000)frow+i1+itodo-2 + call ftpmsg('Error writing rows'//cp1//' to'//cp2 + & //' of column'//ccol//' (FTPCLM).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLM).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+itodo + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftpcls.f b/pkg/tbtables/fitsio/ftpcls.f new file mode 100644 index 00000000..0588b780 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcls.f @@ -0,0 +1,196 @@ +C---------------------------------------------------------------------- + subroutine ftpcls(ounit,colnum,frow,felem,nelem,sray,status) + +C write an array of character string values to the specified column of +C the table. +C The binary or ASCII table column being written to must have datatype 'A' + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C sray c array of data values to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + character*(*) sray(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,strlen,c1,c2,repeat,twidth + integer ibuff,i1,ntodo,rstart,estart,nchars,clen,tcode + character sbuff*80,blank*80,crow*9,cp1*9,cp2*9,ccol*4 + logical small,fill + + if (status .gt. 0)return + +C check for zero length array + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLS).') + return + end if + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLS).') + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + blank=' ' + i1=1 + +C column must be character string data type + tcode=tdtype(colnum+tstart(ibuff)) + if (tcode .eq. 16)then +C for ASCII columns, TNULL actually stores the field width + twidth=tnull(colnum+tstart(ibuff)) + ntodo=nelem + rstart=frow-1 + repeat=trept(colnum+tstart(ibuff)) + estart=felem-1 + if (estart .ge. repeat)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLS).') + return + end if + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*twidth + else if (tcode .eq. -16)then +C this is a variable length descriptor field +C the length of the output string is defined by nelem + twidth=nelem + ntodo=1 + repeat=1 +C write the number of string length and the starting offset: + call ftpdes(ounit,colnum,frow,twidth, + & nxheap(ibuff),status) +C calc the i/o pointer position for the start of the string + bstart=dtstrt(ibuff)+nxheap(ibuff)+theap(ibuff) +C increment the empty heap starting address: + nxheap(ibuff)=nxheap(ibuff)+twidth + else +C error: not a character string column + status=309 + return + end if + +C move the i/o pointer to the start of the sequence of pixels + call ftmbyt(ounit,bstart,.true.,status) + +C is the input string short enough to completely fit in buffer? + strlen=len(sray(1)) + if (strlen .gt. 80 .and. twidth .gt. 80)then + small=.false. + else + small=.true. + end if + +C do we need to pad the FITS string field with trailing blanks? + if (twidth .gt. strlen)then + fill=.true. + else + fill=.false. + end if + +C process one string at a time +20 continue + nchars=min(strlen,twidth) + if (small)then +C the whole input string fits in the temporary buffer + sbuff=sray(i1) +C output the string + call ftpcbf(ounit,1,nchars,sbuff,status) + else +C have to write the string in several pieces + c1=1 + c2=80 +30 sbuff=sray(i1)(c1:c2) +C output the string + clen=c2-c1+1 + call ftpcbf(ounit,1,clen,sbuff,status) + nchars=nchars-clen + if (nchars .gt. 0)then + c1=c1+80 + c2=min(c2+80,c1+nchars-1) + go to 30 + end if + end if + +C pad any remaining space in the column with blanks + if (fill)then + nchars=twidth-strlen +40 clen=min(nchars,80) + call ftpcbf(ounit,1,clen,blank,status) + nchars=nchars-80 + if (nchars .gt. 0)go to 40 + end if + + if (status .gt. 0)then + write(cp1,2000)i1 + call ftpmsg('Error while writing ASCII string to ') + write(ccol,2001)colnum +2001 format(i4) + write(cp1,2000)rstart+1 + write(cp2,2000)estart+1 + if (felem .eq. 1)then + call ftpmsg('column'//ccol//', row'//cp1 + & //' (FTPCLS).') + else + call ftpmsg('column'//ccol//', row'//cp1 + & //', element'//cp2//' (FTPCLS).') + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-1 + if (ntodo .gt. 0)then +C increment the pointers + i1=i1+1 + estart=estart+1 + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff)) +C move the i/o pointer + call ftmbyt(ounit,bstart,.true.,status) + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftpclu.f b/pkg/tbtables/fitsio/ftpclu.f new file mode 100644 index 00000000..84e8f5f6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclu.f @@ -0,0 +1,279 @@ +C---------------------------------------------------------------------- + subroutine ftpclu(ounit,colnum,frow,felem,nelem,status) + +C set elements of a table to be undefined + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,frow,felem,nelem,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) + character snull*500 + character*1 xdummy(5260) + common/ftheap/snull,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bytpix,bstart,i4null,tcode,nchars,i,offset,nulval + integer ibuff,ntodo,itodo,repeat,rstart,estart + integer*2 i2null,l1null + real r4null + double precision r8null + logical descrp + character*1 i1null + character crow*9,cp1*9,cp2*9,ccol*4 + + if (status .gt. 0)return + +C check for zero length array + if (nelem .le. 0)return + if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLU).') + return + end if + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + + tcode=tdtype(colnum+tstart(ibuff)) + bytpix=max(abs(tcode)/10,1) + + descrp=.false. + ntodo=nelem + rstart=frow-1 + + if (felem .lt. 1)then +C illegal element number + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLU).') + return + else + estart=felem-1 + end if + + if (tcode .eq. 16)then +C this is an ASCII field + repeat=trept(colnum+tstart(ibuff)) + if (felem .gt. repeat)then + status=308 + write(crow,2000)felem + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLU).') + return + end if + + if (cnull(colnum+tstart(ibuff))(1:1) .eq. char(1))then +C error: null value has not been defined + status=314 + call ftpmsg('Null value string for ASCII table'// + & ' column has not yet been defined (FTPCLU).') + return + end if +C the TNULL parameter stores the width of the character field + bytpix=tnull(colnum+tstart(ibuff)) + else +C this is a binary table + nulval=tnull(colnum+tstart(ibuff)) + + if (tcode .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C if this is a primary array or image extension, then +C set repeat as large as needed to write all +C the pixels. This prevents an error message if +C array size is not yet known. The actual array +C dimension must be defined by the NAXISn keywords +C before closing this HDU. + repeat=estart+nelem + else + repeat=trept(colnum+tstart(ibuff)) + end if + + if (felem .gt. repeat)then +C illegal element number + status=308 + return + end if + else +C this is a variable length descriptor column + descrp=.true. + tcode=-tcode +C read the number of elements and the starting offset: + call ftgdes(ounit,colnum,frow,repeat, + & offset,status) + if (ntodo+estart .gt. repeat)then +C error: tried to write past end of record + status=319 + return + end if + +C move the i/o pointer to the start of the pixel sequence + bstart=dtstrt(ibuff)+offset+ + & theap(ibuff)+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + + if (tcode.eq.11 .or. tcode.eq.21 .or. tcode.eq.41)then + if (nulval .eq. 123454321)then +C error: null value has not been defined + status=314 + call ftpmsg('Null value for integer'// + & ' column has not yet been defined (FTPCLU).') + return + end if + else +C set the floating point Not-a-Number values + call ftsrnn(r4null) + call ftsdnn(r8null) + end if + + end if + +C process as many contiguous pixels as possible +20 itodo=min(ntodo,repeat-estart) + + if (.not. descrp)then +C move the i/o pointer to the start of the sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff))+estart*bytpix + call ftmbyt(ounit,bstart,.true.,status) + end if + +C write the appropriate null value to the pixels + if (tcode .eq. 21)then +C column data type is I (I*2) + do 5 i=1,itodo + i2null=nulval + call ftpi2b(ounit,1,0,i2null,status) +5 continue + else if (tcode .eq. 41)then +C column data type is J (I*4) + do 15 i=1,itodo + i4null=nulval + call ftpi4b(ounit,1,0,i4null,status) +15 continue + else if (tcode .eq. 42)then +C column data type is E (R*4) + do 25 i=1,itodo + call ftpbyt(ounit,4,r4null,status) +25 continue + else if (tcode .eq. 82 .or. tcode .eq. 83)then +C column data type is D (R*8), or C complex 2 x R*4 + do 35 i=1,itodo + call ftpbyt(ounit,8,r8null,status) +35 continue + else if (tcode .eq. 16)then +C this is an ASCII table column + snull=cnull(colnum+tstart(ibuff)) +C write up to 500 characters in the column, remainder unchanged +C (500 is the maximum size string allowed in IBM AIX compiler) + nchars=min(bytpix,500) + do 45 i=1,itodo + call ftpcbf(ounit,1,nchars,snull,status) +45 continue + else if (tcode .eq. 11)then +C column data type is B (byte) + i1null=char(nulval) + do 55 i=1,itodo + call ftpcbf(ounit,0,1,i1null,status) +55 continue + else if (tcode .eq. 163)then +C column data type is double complex (M) + do 65 i=1,itodo*2 + call ftpbyt(ounit,8,r8null,status) +65 continue + else if (tcode .eq. 14)then +C column data type is logical (L) + l1null=0 + do 85 i=1,itodo + call ftpbyt(ounit,1,l1null,status) +85 continue + end if + + + if (status .gt. 0)then + if (hdutyp(ibuff) .eq. 0)then +C this is a primary array or image extension + write(cp1,2000)felem+nelem-ntodo + write(cp2,2000)felem+nelem-ntodo+itodo-1 + call ftpmsg('Error writing Nulls to pixels' + & //cp1//' to'//cp2//' in the FITS array (FTPCLU).') + if (frow .ne. 1)then + write(cp1,2000)frow + call ftpmsg('Error while writing group'//cp1// + & ' of the multigroup primary array.') + end if + else + write(ccol,2001)colnum +2001 format(i4) + if (descrp)then +C this is a variable length descriptor column + write(crow,2000)frow + write(cp1,2000)felem + write(cp2,2000)felem+nelem-1 + call ftpmsg('Error writing Nulls to elements'//cp1// + & ' to'//cp2 //' in row'//crow) + call ftpmsg(' of variable length vector column'//ccol + & //' (FTPCLU.') + else if (trept(colnum+tstart(ibuff)) .eq. 1)then +C this is not a vector column (simple case) + write(cp1,2000)frow + write(cp2,2000)frow+nelem-1 + call ftpmsg('Error writing Nulls to rows'//cp1//' to' + & //cp2//' of column'//ccol//' (FTPCLU).') + else +C this is a vector column (more complicated case) + write(crow,2000)rstart+1 + write(cp1,2000)estart+1 + write(cp2,2000)itodo + call ftpmsg('Error writing'//cp2//' Null elements to' + & //' column'//ccol) + call ftpmsg(' starting at row'//crow + & //', element'//cp1//' (FTPCLU).') + end if + end if + return + end if + +C find number of pixels left to do, and quit if none left + ntodo=ntodo-itodo + if (ntodo .gt. 0)then +C increment the pointers + estart=estart+itodo + if (estart .eq. repeat)then + estart=0 + rstart=rstart+1 + end if + go to 20 + end if + end diff --git a/pkg/tbtables/fitsio/ftpclx.f b/pkg/tbtables/fitsio/ftpclx.f new file mode 100644 index 00000000..67b82e27 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpclx.f @@ -0,0 +1,189 @@ +C---------------------------------------------------------------------- + subroutine ftpclx(iunit,colnum,frow,fbit,nbit,lray,status) + +C write an array of logical values to a specified bit or byte +C column of the binary table. If the LRAY parameter is .true., +C then the corresponding bit is set to 1, otherwise it is set +C to 0. +C The binary table column being written to must have datatype 'B' +C or 'X'. + +C iunit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C fbit i first bit within the row to write +C nbit i number of bits to write +C lray l array of logical data values corresponding to the bits +C to be written +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Mar 1992 +C modified by Wm Pence May 1992 to remove call to system dependent +C bit testing and setting routines. + + integer iunit,colnum,frow,fbit,nbit,status + logical lray(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer bstart,offset,tcode,fbyte,bitloc,ndone,tstat + integer ibuff,i,ntodo,repeat,rstart,estart,buffer + logical descrp,wrbit(8),setbit(8) + character*1 cbuff + character crow*9 + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + tcode=tdtype(colnum+tstart(ibuff)) + +C check input parameters + if (nbit .le. 0)then + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + write(crow,2000)frow +2000 format(i9) + call ftpmsg('Starting row number for table write '// + & 'request is out of range:'//crow//' (FTPCLX).') + return + else if (fbit .lt. 1)then +C illegal element number + status=308 + write(crow,2000)fbit + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLX).') + return + end if + + fbyte=(fbit+7)/8 + bitloc=fbit-(fbit-1)/8*8 + ndone=0 + ntodo=nbit + rstart=frow-1 + estart=fbyte-1 + + if (tcode .eq. 11)then + descrp=.false. +C N.B: REPEAT is the number of bytes, not number of bits + repeat=trept(colnum+tstart(ibuff)) + if (fbyte .gt. repeat)then +C illegal element number + status=308 + write(crow,2000)fbit + call ftpmsg('Starting element number for write '// + & 'request is out of range:'//crow//' (FTPCLX).') + return + end if +C calc the i/o pointer location to start of sequence of pixels + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + else if (tcode .eq. -11)then +C this is a variable length descriptor column + descrp=.true. +C only bit arrays (tform = 'X') are supported for variable +C length arrays. REPEAT is the number of BITS in the array. + repeat=estart+ntodo + offset=nxheap(ibuff) +C write the number of elements and the starting offset: + call ftpdes(iunit,colnum,frow,repeat, + & offset,status) +C calc the i/o pointer location to start of sequence of pixels + bstart=dtstrt(ibuff)+offset+ + & theap(ibuff)+estart +C increment the empty heap starting address (in bytes): + repeat=(repeat+7)/8 + nxheap(ibuff)=nxheap(ibuff)+repeat + else +C column must be byte or bit data type + status=310 + return + end if + +C move the i/o pointer to the start of the pixel sequence + call ftmbyt(iunit,bstart,.true.,status) + tstat=0 + +C read the next byte (we may only be modifying some of the bits) +20 call ftgcbf(iunit,0,1,cbuff,status) + if (status .eq. 107)then +C hit end of file trying to read the byte, so just set byte = 0 + status=tstat + cbuff=char(0) + end if + + buffer=ichar(cbuff) + if (buffer .lt. 0)buffer=buffer+256 +C move back, to be able to overwrite the byte + call ftmbyt(iunit,bstart,.true.,status) + +C reset flags indicating which bits are to be set + wrbit(1)=.false. + wrbit(2)=.false. + wrbit(3)=.false. + wrbit(4)=.false. + wrbit(5)=.false. + wrbit(6)=.false. + wrbit(7)=.false. + wrbit(8)=.false. + +C flag the bits that are to be set + do 10 i=bitloc,8 + wrbit(i)=.true. + ndone=ndone+1 + if(lray(ndone))then + setbit(i)=.true. + else + setbit(i)=.false. + end if + if (ndone .eq. ntodo)go to 100 +10 continue + +C set or reset the bits within the byte + call ftpbit(setbit,wrbit,buffer) + +C write the new byte + cbuff=char(buffer) + call ftpcbf(iunit,0,1,cbuff,status) + +C not done, so get the next byte + bstart=bstart+1 + if (.not. descrp)then + estart=estart+1 + if (estart .eq. repeat)then +C move the i/o pointer to the next row of pixels + estart=0 + rstart=rstart+1 + bstart=dtstrt(ibuff)+rstart*rowlen(ibuff)+ + & tbcol(colnum+tstart(ibuff))+estart + call ftmbyt(iunit,bstart,.true.,status) + end if + end if + bitloc=1 + go to 20 + +100 continue +C set or reset the bits within the byte + call ftpbit(setbit,wrbit,buffer) + +C write the new byte + cbuff=char(buffer) + call ftpcbf(iunit,0,1,cbuff,status) + end diff --git a/pkg/tbtables/fitsio/ftpcnb.f b/pkg/tbtables/fitsio/ftpcnb.f new file mode 100644 index 00000000..89c965da --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcnb.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + subroutine ftpcnb(ounit,colnum,frow,felem,nelem,array,nulval, + & status) + +C write array of character*1 (byte) pixels to the specified column +C of a table. Any input pixels equal to the value of NULVAL will +C be replaced by the appropriate null value in the output FITS file. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array c*1 array of data values to be written +C nulval c*1 pixel value used to represent an undefine pixel +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,colnum,frow,felem,nelem,status + character*1 array(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C get the column repeat count and calculate the absolute position within +C the column of the first element to be written + repeat=trept(colnum+tstart(ibuff)) + first=(frow-1)*repeat+felem-1 + + ngood=0 + nbad=0 + do 10 i=1,nelem + if (array(i) .ne. nulval)then + ngood=ngood+1 + if (nbad .gt. 0)then +C write the previous consecutive set of null pixels + fstelm=i-nbad+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + nbad=0 + end if + else + nbad=nbad+1 + if (ngood .gt. 0)then +C write the previous consecutive set of good pixels + fstelm=i-ngood+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclb(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + ngood=0 + end if + end if +10 continue + +C finished; now just write the last set of pixels + if (nbad .gt. 0)then +C write the consecutive set of null pixels + fstelm=i-nbad+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + else +C write the consecutive set of good pixels + fstelm=i-ngood+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclb(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpcnd.f b/pkg/tbtables/fitsio/ftpcnd.f new file mode 100644 index 00000000..f390a8ca --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcnd.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + subroutine ftpcnd(ounit,colnum,frow,felem,nelem,array,nulval, + & status) + +C write array of double precision pixels to the specified column +C of a table. Any input pixels equal to the value of NULVAL will +C be replaced by the appropriate null value in the output FITS file. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array d array of data values to be written +C nulval d pixel value used to represent an undefine pixel +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,colnum,frow,felem,nelem,status + double precision array(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C get the column repeat count and calculate the absolute position within +C the column of the first element to be written + repeat=trept(colnum+tstart(ibuff)) + first=(frow-1)*repeat+felem-1 + + ngood=0 + nbad=0 + do 10 i=1,nelem + if (array(i) .ne. nulval)then + ngood=ngood+1 + if (nbad .gt. 0)then +C write the previous consecutive set of null pixels + fstelm=i-nbad+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + nbad=0 + end if + else + nbad=nbad+1 + if (ngood .gt. 0)then +C write the previous consecutive set of good pixels + fstelm=i-ngood+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcld(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + ngood=0 + end if + end if +10 continue + +C finished; now just write the last set of pixels + if (nbad .gt. 0)then +C write the consecutive set of null pixels + fstelm=i-nbad+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + else +C write the consecutive set of good pixels + fstelm=i-ngood+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcld(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpcne.f b/pkg/tbtables/fitsio/ftpcne.f new file mode 100644 index 00000000..d30031af --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcne.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + subroutine ftpcne(ounit,colnum,frow,felem,nelem,array,nulval, + & status) + +C write array of floating point pixels to the specified column +C of a table. Any input pixels equal to the value of NULVAL will +C be replaced by the appropriate null value in the output FITS file. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array r array of data values to be written +C nulval r pixel value used to represent an undefine pixel +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,colnum,frow,felem,nelem,status + real array(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C get the column repeat count and calculate the absolute position within +C the column of the first element to be written + repeat=trept(colnum+tstart(ibuff)) + first=(frow-1)*repeat+felem-1 + + ngood=0 + nbad=0 + do 10 i=1,nelem + if (array(i) .ne. nulval)then + ngood=ngood+1 + if (nbad .gt. 0)then +C write the previous consecutive set of null pixels + fstelm=i-nbad+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + nbad=0 + end if + else + nbad=nbad+1 + if (ngood .gt. 0)then +C write the previous consecutive set of good pixels + fstelm=i-ngood+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcle(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + ngood=0 + end if + end if +10 continue + +C finished; now just write the last set of pixels + if (nbad .gt. 0)then +C write the consecutive set of null pixels + fstelm=i-nbad+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + else +C write the consecutive set of good pixels + fstelm=i-ngood+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcle(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpcni.f b/pkg/tbtables/fitsio/ftpcni.f new file mode 100644 index 00000000..408fdfa7 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcni.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + subroutine ftpcni(ounit,colnum,frow,felem,nelem,array,nulval, + & status) + +C write array of integer*2 pixels to the specified column +C of a table. Any input pixels equal to the value of NULVAL will +C be replaced by the appropriate null value in the output FITS file. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array i*2 array of data values to be written +C nulval i*2 pixel value used to represent an undefine pixel +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,colnum,frow,felem,nelem,status + integer*2 array(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C get the column repeat count and calculate the absolute position within +C the column of the first element to be written + repeat=trept(colnum+tstart(ibuff)) + first=(frow-1)*repeat+felem-1 + + ngood=0 + nbad=0 + do 10 i=1,nelem + if (array(i) .ne. nulval)then + ngood=ngood+1 + if (nbad .gt. 0)then +C write the previous consecutive set of null pixels + fstelm=i-nbad+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + nbad=0 + end if + else + nbad=nbad+1 + if (ngood .gt. 0)then +C write the previous consecutive set of good pixels + fstelm=i-ngood+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcli(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + ngood=0 + end if + end if +10 continue + +C finished; now just write the last set of pixels + if (nbad .gt. 0)then +C write the consecutive set of null pixels + fstelm=i-nbad+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + else +C write the consecutive set of good pixels + fstelm=i-ngood+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpcli(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpcnj.f b/pkg/tbtables/fitsio/ftpcnj.f new file mode 100644 index 00000000..45d8ea1c --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcnj.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + subroutine ftpcnj(ounit,colnum,frow,felem,nelem,array,nulval, + & status) + +C write array of integer pixels to the specified column +C of a table. Any input pixels equal to the value of NULVAL will +C be replaced by the appropriate null value in the output FITS file. + +C ounit i fortran unit number +C colnum i number of the column to write to +C frow i first row to write +C felem i first element within the row to write +C nelem i number of elements to write +C array i array of data values to be written +C nulval i pixel value used to represent an undefine pixel +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,colnum,frow,felem,nelem,status + integer array(*),nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,repeat,first,ngood,nbad,i,fstelm,fstrow + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C get the column repeat count and calculate the absolute position within +C the column of the first element to be written + repeat=trept(colnum+tstart(ibuff)) + first=(frow-1)*repeat+felem-1 + + ngood=0 + nbad=0 + do 10 i=1,nelem + if (array(i) .ne. nulval)then + ngood=ngood+1 + if (nbad .gt. 0)then +C write the previous consecutive set of null pixels + fstelm=i-nbad+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + nbad=0 + end if + else + nbad=nbad+1 + if (ngood .gt. 0)then +C write the previous consecutive set of good pixels + fstelm=i-ngood+first +C calculate the row and element of the first pixel to write + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclj(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + ngood=0 + end if + end if +10 continue + +C finished; now just write the last set of pixels + if (nbad .gt. 0)then +C write the consecutive set of null pixels + fstelm=i-nbad+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclu(ounit,colnum,fstrow,fstelm,nbad,status) + else +C write the consecutive set of good pixels + fstelm=i-ngood+first + fstrow=(fstelm-1)/repeat+1 + fstelm=fstelm-(fstrow-1)*repeat + call ftpclj(ounit,colnum,fstrow,fstelm,ngood, + & array(i-ngood),status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpcom.f b/pkg/tbtables/fitsio/ftpcom.f new file mode 100644 index 00000000..f056eea2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpcom.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftpcom(ounit,commnt,status) + +C write a COMMENT record to the FITS header +C +C ounit i fortran output unit number +C commnt c input comment string +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,status,strlen,actlen,i,nkeys,c1,c2 + character*(*) commnt + character*80 rec + + if (status .gt. 0)return + +C find the length of the string, and write it out 70 characters at a time + nkeys=1 + strlen=len(commnt) + actlen=strlen + do 10 i=strlen,1,-1 + if (commnt(i:i) .ne. ' ')then + actlen=i + go to 20 + end if +10 continue + +20 c1=1 + c2=min(actlen,70) + nkeys=(actlen-1)/70+1 + do 30 i=1,nkeys + rec='COMMENT '//commnt(c1:c2) + call ftprec(ounit,rec,status) + c1=c1+70 + c2=min(actlen,c2+70) +30 continue + end diff --git a/pkg/tbtables/fitsio/ftpdat.f b/pkg/tbtables/fitsio/ftpdat.f new file mode 100644 index 00000000..091922d4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpdat.f @@ -0,0 +1,33 @@ +C-------------------------------------------------------------------------- + subroutine ftpdat(ounit,status) + +C write the current date to the DATE keyword in the ounit CHU +C +C ounit i fortran output unit number +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Jan 1992 + + integer ounit,status,dd,mm,yy + character datstr*8 + +C call the system dependent routine to get the current date + call ftgsdt(dd,mm,yy,status) + if (status .gt. 0)return + + datstr=' / / ' + write(datstr(1:2),1001)dd + write(datstr(4:5),1001)mm + write(datstr(7:8),1001)yy +1001 format(i2) + +C replace blank with leading 0 in each field if required + if (datstr(1:1) .eq. ' ')datstr(1:1)='0' + if (datstr(4:4) .eq. ' ')datstr(4:4)='0' + if (datstr(7:7) .eq. ' ')datstr(7:7)='0' + +C update the DATE keyword + call ftukys(ounit,'DATE',datstr, + & 'FITS file creation date (dd/mm/yy)',status) + end diff --git a/pkg/tbtables/fitsio/ftpdef.f b/pkg/tbtables/fitsio/ftpdef.f new file mode 100644 index 00000000..a8ebb140 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpdef.f @@ -0,0 +1,156 @@ +C-------------------------------------------------------------------------- + subroutine ftpdef(ounit,bitpix,naxis,naxes,pcount,gcount, + & status) + +C Primary data DEFinition +C define the structure of the primary data unit or an IMAGE extension +C +C ounit i Fortran I/O unit number +C bitpix i bits per pixel value +C naxis i number of data axes +C naxes i length of each data axis (array) +C pcount i number of group parameters +C gcount i number of 'random groups' +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,ttype,bytlen,npix,i,pcnt,gcnt + character caxis*20 + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + + if (dtstrt(ibuff) .lt. 0)then +C freeze the header at its current size + call fthdef(ounit,0,status) + if (status .gt. 0)return + end if + +C check for error conditions + if (naxis .lt. 0)then + status=212 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPDEF ' + & //'is illegal.') + + else if (pcount .lt. 0)then + status=214 + else if (gcount .lt. 0)then + status=215 + else + go to 5 + end if + return + +C test that bitpix has a legal value and set the datatype code value +5 if (bitpix .eq. 8)then + ttype=11 + bytlen=1 + else if (bitpix .eq. 16)then + ttype=21 + bytlen=2 + else if (bitpix .eq. 32)then + ttype=41 + bytlen=4 + else if (bitpix .eq. -32)then + ttype=42 + bytlen=4 + else if (bitpix .eq. -64)then + ttype=82 + bytlen=8 + else +C illegal value of bitpix + status=211 + return + end if + +C calculate the number of pixels in the array + if (naxis .eq. 0)then +C no data + npix=0 + gcnt=0 + pcnt=0 + else +C make sure that the gcount is not zero + gcnt=max(gcount,1) + pcnt=pcount + npix=1 + do 10 i=1,naxis + if (naxes(i) .ge. 0)then +C The convension used by 'random groups' with NAXIS1 = 0 is not +C directly supported here. If one wants to write a 'random group' +C FITS file, then one should call FTPDEF with naxes(1) = 1, but +C then write the required header keywords (with FTPHPR) with +C naxes(1) = 0. + npix=npix*naxes(i) + else if (naxes(i) .lt. 0)then + status=213 + return + end if +10 continue + end if +C the next HDU begins in the next logical block after the data + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880 + +C the primary array is actually interpreted as a binary table. There +C are two columns: the first column contains the +C group parameters, if any, and the second column contains the +C primary array of data. Each group is a separate row in the table. +C The scaling and null values are set to the default values. + + hdutyp(ibuff)=0 + tfield(ibuff)=2 + + if (nxtfld + 2 .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + else + tstart(ibuff)=nxtfld + nxtfld=nxtfld+2 + tdtype(1+tstart(ibuff))=ttype + tdtype(2+tstart(ibuff))=ttype + trept(1+tstart(ibuff))=pcnt + trept(2+tstart(ibuff))=npix +C choose a special value to represent the absence of a blank value + tnull(1+tstart(ibuff))=123454321 + tnull(2+tstart(ibuff))=123454321 + tscale(1+tstart(ibuff))=1. + tscale(2+tstart(ibuff))=1. + tzero(1+tstart(ibuff))=0. + tzero(2+tstart(ibuff))=0. + tbcol(1+tstart(ibuff))=0 + tbcol(2+tstart(ibuff))=pcnt*bytlen + rowlen(ibuff)=(pcnt+npix)*bytlen + end if + +C initialize the fictitious heap starting address (immediately following +C the array data) and a zero length heap. This is used to find the +C end of the data when checking the fill values in the last block. + scount(ibuff)=0 + theap(ibuff)=(pcnt+npix)*bytlen*gcnt + nxheap(ibuff)=0 + end diff --git a/pkg/tbtables/fitsio/ftpdes.f b/pkg/tbtables/fitsio/ftpdes.f new file mode 100644 index 00000000..f81c79bf --- /dev/null +++ b/pkg/tbtables/fitsio/ftpdes.f @@ -0,0 +1,63 @@ +C---------------------------------------------------------------------- + subroutine ftpdes(ounit,colnum,rownum,nelem,offset,status) + +C write the descriptor values to a binary table. This is only +C used for column which have TFORMn = 'P', i.e., for variable +C length arrays. + +C ounit i fortran unit number +C colnum i number of the column to write to +C rownum i number of the row to write +C nelem i input number of elements +C offset i input byte offset of the first element +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Nov 1991 + + integer ounit,colnum,rownum,nelem,offset,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart,iray(2) + + if (status .gt. 0)return + if (rownum .lt. 1)then +C error: illegal row number + status=307 + return + end if + + ibuff=bufnum(ounit) + +C check that this is really a 'P' type column + if (tdtype(colnum+tstart(ibuff)) .ge. 0)then + status=317 + return + end if + +C move to the specified column and row: + bstart=dtstrt(ibuff)+(rownum-1)*rowlen(ibuff) + & +tbcol(colnum+tstart(ibuff)) + call ftmbyt(ounit,bstart,.true.,status) + +C now write the number of elements and the offset to the table: + iray(1)=nelem + iray(2)=offset + call ftpi4b(ounit,2,0,iray,status) + end diff --git a/pkg/tbtables/fitsio/ftpdfl.f b/pkg/tbtables/fitsio/ftpdfl.f new file mode 100644 index 00000000..33d7eeec --- /dev/null +++ b/pkg/tbtables/fitsio/ftpdfl.f @@ -0,0 +1,94 @@ +C---------------------------------------------------------------------- + subroutine ftpdfl(iunit,status) + +C Write the Data Unit Fill values if they are not already correct +C Fill the data unit with zeros or blanks depending on the type of HDU +C from the end of the data to the end of the current FITS 2880 byte block + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, June, 1994 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nf = 3000) + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 chbuff(2880),chfill,xdummy(2879) + common/ftheap/chbuff,chfill,xdummy +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,filpos,nfill,i,tstat + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check if the data unit is null + + if (theap(ibuff) .eq. 0)return + + filpos=dtstrt(ibuff)+theap(ibuff)+scount(ibuff) + nfill=(filpos+2879)/2880*2880-filpos + +C return if there are no fill bytes + if (nfill .eq. 0)return + +C set the correct fill value to be checked + if (hdutyp(ibuff) .eq. 1)then +C this is an ASCII table; should be filled with blanks + chfill=char(32) + else + chfill=char(0) + end if + +C move to the beginning of the fill bytes and read them + tstat=status + call ftmbyt(iunit,filpos,.true.,status) + call ftgcbf(iunit,0,nfill,chbuff,status) + + if (status .gt. 0)then +C fill bytes probably haven't been written yet so have to write them + status=tstat + go to 100 + end if + +C check if all the fill values are correct + do 10 i=1,nfill + if (chbuff(i) .ne. chfill)go to 100 +10 continue + +C fill bytes were correct, so just return + return + +100 continue + +C fill the buffer with the correct fill value + do 20 i=1,nfill + chbuff(i)=chfill +20 continue + +C move to the beginning of the fill bytes + call ftmbyt(iunit,filpos,.true.,status) + +C write all the fill bytes + call ftpcbf(iunit,0,nfill,chbuff,status) + + if (status .gt. 0)then + call ftpmsg('Error writing Data Unit fill bytes (FTPDFL).') + end if + end diff --git a/pkg/tbtables/fitsio/ftpgpb.f b/pkg/tbtables/fitsio/ftpgpb.f new file mode 100644 index 00000000..2cc4ffef --- /dev/null +++ b/pkg/tbtables/fitsio/ftpgpb.f @@ -0,0 +1,28 @@ +C---------------------------------------------------------------------- + subroutine ftpgpb(ounit,group,fparm,nparm,array,status) + +C Write an array of group parmeters into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C fparm i the first group parameter to be written (starting with 1) +C nparm i number of group parameters to be written +C array b the array of group parameters to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,fparm,nparm,status,row + + character*1 array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpclb(ounit,1,row,fparm,nparm,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpgpd.f b/pkg/tbtables/fitsio/ftpgpd.f new file mode 100644 index 00000000..186df96c --- /dev/null +++ b/pkg/tbtables/fitsio/ftpgpd.f @@ -0,0 +1,27 @@ +C---------------------------------------------------------------------- + subroutine ftpgpd(ounit,group,fparm,nparm,array,status) + +C Write an array of group parmeters into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C fparm i the first group parameter to be written (starting with 1) +C nparm i number of group parameters to be written +C array d the array of group parameters to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,fparm,nparm,status,row + double precision array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcld(ounit,1,row,fparm,nparm,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpgpe.f b/pkg/tbtables/fitsio/ftpgpe.f new file mode 100644 index 00000000..506c238d --- /dev/null +++ b/pkg/tbtables/fitsio/ftpgpe.f @@ -0,0 +1,27 @@ +C---------------------------------------------------------------------- + subroutine ftpgpe(ounit,group,fparm,nparm,array,status) + +C Write an array of group parmeters into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C fparm i the first group parameter to be written (starting with 1) +C nparm i number of group parameters to be written +C array r the array of group parameters to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,fparm,nparm,status,row + real array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcle(ounit,1,row,fparm,nparm,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpgpi.f b/pkg/tbtables/fitsio/ftpgpi.f new file mode 100644 index 00000000..c07a7294 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpgpi.f @@ -0,0 +1,27 @@ +C---------------------------------------------------------------------- + subroutine ftpgpi(ounit,group,fparm,nparm,array,status) + +C Write an array of group parmeters into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C fparm i the first group parameter to be written (starting with 1) +C nparm i number of group parameters to be written +C array i*2 the array of group parameters to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,fparm,nparm,status,row + integer*2 array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcli(ounit,1,row,fparm,nparm,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpgpj.f b/pkg/tbtables/fitsio/ftpgpj.f new file mode 100644 index 00000000..15dc670e --- /dev/null +++ b/pkg/tbtables/fitsio/ftpgpj.f @@ -0,0 +1,27 @@ +C---------------------------------------------------------------------- + subroutine ftpgpj(ounit,group,fparm,nparm,array,status) + +C Write an array of group parmeters into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C fparm i the first group parameter to be written (starting with 1) +C nparm i number of group parameters to be written +C array i the array of group parameters to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,fparm,nparm,status,row + integer array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpclj(ounit,1,row,fparm,nparm,array,status) + end diff --git a/pkg/tbtables/fitsio/ftphbn.f b/pkg/tbtables/fitsio/ftphbn.f new file mode 100644 index 00000000..712dd37c --- /dev/null +++ b/pkg/tbtables/fitsio/ftphbn.f @@ -0,0 +1,130 @@ +C---------------------------------------------------------------------- + subroutine ftphbn(ounit,nrows,nfield,ttype,tform,tunit, + & extnam,pcount,status) + +C write required standard header keywords for a binary table extension +C +C ounit i fortran output unit number +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) (optional) +C tform c format of each field (array) +C tunit c units of each field (array) (optional) +C extnam c name of table extension (optional) +C pcount i size of special data area following the table (usually = 0) +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,nrows,nfield,pcount,status + integer i,lenrow,dtype,rcount,xbcol,length,width + character*(*) ttype(*),tform(*),tunit(*),extnam + character comm*48,tfm*40 + + comm='binary table extension' + call ftpkys(ounit,'XTENSION','BINTABLE',comm,status) + + comm='8-bit bytes' + call ftpkyj(ounit,'BITPIX',8,comm,status) + + comm='2-dimensional binary table' + call ftpkyj(ounit,'NAXIS',2,comm,status) + + if (status .gt. 0)return + +C calculate the total width of each row, in bytes + lenrow=0 + do 10 i=1,nfield +C get the numerical datatype and repeat count of the field + call ftbnfm(tform(i),dtype,rcount,width,status) + if (dtype .eq. 1)then +C treat Bit datatype as if it were a Byte datatype + dtype=11 + rcount=(rcount+7)/8 + end if +C get the width of the field + call ftgtbc(1,dtype,rcount,xbcol,length,status) + lenrow=lenrow+length +10 continue + + comm='width of table in bytes' + call ftpkyj(ounit,'NAXIS1',lenrow,comm,status) + + if (status .gt. 0)return + + if (nrows .ge. 0)then + comm='number of rows in table' + call ftpkyj(ounit,'NAXIS2',nrows,comm,status) + else + status=218 + end if + + if (status .gt. 0)return + + if (pcount .ge. 0)then + comm='size of special data area' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + else + status=214 + end if + + comm='one data group (required keyword)' + call ftpkyj(ounit,'GCOUNT',1,comm,status) + + comm='number of fields in each row' + call ftpkyj(ounit,'TFIELDS',nfield,comm,status) + + if (status .gt. 0)return + + do 20 i=1,nfield + if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then + comm='label for field ' + write(comm(17:19),1000)i +1000 format(i3) + call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status) + end if + + comm='data format of the field' +C make sure format characters are in upper case: + tfm=tform(i) + call ftupch(tfm) + +C Add datatype to the comment string: + call ftbnfm(tfm,dtype,rcount,width,status) + if (dtype .eq. 21)then + comm(25:)=': 2-byte INTEGER' + else if(dtype .eq. 41)then + comm(25:)=': 4-byte INTEGER' + else if(dtype .eq. 42)then + comm(25:)=': 4-byte REAL' + else if(dtype .eq. 82)then + comm(25:)=': 8-byte DOUBLE' + else if(dtype .eq. 16)then + comm(25:)=': ASCII Character' + else if(dtype .eq. 14)then + comm(25:)=': 1-byte LOGICAL' + else if(dtype .eq. 11)then + comm(25:)=': BYTE' + else if(dtype .eq. 1)then + comm(25:)=': BIT' + else if(dtype .eq. 83)then + comm(25:)=': COMPLEX' + else if(dtype .eq. 163)then + comm(25:)=': DOUBLE COMPLEX' + end if + + call ftpkns(ounit,'TFORM',i,1,tfm,comm,status) + + if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then + comm='physical unit of field' + call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status) + end if + if (status .gt. 0)return +20 continue + + if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then + comm='name of this binary table extension' + call ftpkys(ounit,'EXTNAME',extnam,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftphis.f b/pkg/tbtables/fitsio/ftphis.f new file mode 100644 index 00000000..2ca86c88 --- /dev/null +++ b/pkg/tbtables/fitsio/ftphis.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftphis(ounit,histry,status) + +C write a HISTORY record to the FITS header +C +C ounit i fortran output unit number +C histry c input history string +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,status,strlen,actlen,i,nkeys,c1,c2 + character*(*) histry + character*80 rec + + if (status .gt. 0)return + +C find the length of the string, and write it out 70 characters at a time + nkeys=1 + strlen=len(histry) + actlen=strlen + do 10 i=strlen,1,-1 + if (histry(i:i) .ne. ' ')then + actlen=i + go to 20 + end if +10 continue + +20 c1=1 + c2=min(actlen,70) + nkeys=(actlen-1)/70+1 + do 30 i=1,nkeys + rec='HISTORY '//histry(c1:c2) + call ftprec(ounit,rec,status) + c1=c1+70 + c2=min(actlen,c2+70) +30 continue + end diff --git a/pkg/tbtables/fitsio/ftphpr.f b/pkg/tbtables/fitsio/ftphpr.f new file mode 100644 index 00000000..b6ac4340 --- /dev/null +++ b/pkg/tbtables/fitsio/ftphpr.f @@ -0,0 +1,122 @@ +C---------------------------------------------------------------------- + subroutine ftphpr(ounit,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + +C write required primary header keywords +C +C ounit i fortran output unit number +C simple l does file conform to FITS standard? +C bitpix i number of bits per data value +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C pcount i number of group parameters +C gcount i number of random groups +C extend l may extensions be present in the FITS file? +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status,i,ibuff + character comm*50,caxis*20,clen*3 + logical simple,extend + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + + if (chdu(ibuff) .eq. 1)then + if (simple)then + comm='file does conform to FITS standard' + else + comm='file does not conform to FITS standard' + end if + call ftpkyl(ounit,'SIMPLE',simple,comm,status) + else + comm='IMAGE extension' + call ftpkys(ounit,'XTENSION','IMAGE',comm,status) + end if + +C test for legal value of bitpix + call fttbit(bitpix,status) + comm='number of bits per data pixel' + call ftpkyj(ounit,'BITPIX',bitpix,comm,status) + if (status .gt. 0)go to 900 + + if (naxis .ge. 0 .and. naxis .le. 999)then + comm='number of data axes' + call ftpkyj(ounit,'NAXIS',naxis,comm,status) + else +C illegal value of naxis + status=212 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPHPR ' + & //'is illegal.') + go to 900 + end if + + comm='length of data axis' + do 10 i=1,naxis + if (naxes(i) .ge. 0)then + write(comm(21:23),1000)i +1000 format(i3) + call ftpknj(ounit,'NAXIS',i,1,naxes(i),comm, + & status) + else +C illegal NAXISnnn keyword value + status=213 + write(clen,1000)i + write(caxis,1001)naxes(i) + call ftpmsg('In call to FTPHPR, axis '//clen// + & ' has illegal negative size: '//caxis) + go to 900 + end if +10 continue + + if (chdu(ibuff) .eq. 1)then +C only write the EXTEND keyword to primary header if true + if (extend)then + comm='FITS dataset may contain extensions' + call ftpkyl(ounit,'EXTEND',extend,comm,status) + end if + +C write the PCOUNT and GCOUNT values if nonstandard + if (pcount .gt. 0 .or. gcount .gt. 1)then + comm='random group records are present' + call ftpkyl(ounit,'GROUPS',.true.,comm,status) + comm='number of random group parameters' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + comm='number of random groups' + call ftpkyj(ounit,'GCOUNT',gcount,comm,status) + end if + + call ftpcom(ounit,'FITS (Flexible Image Transport '// + & 'System) format defined in Astronomy and',status) + call ftpcom(ounit,'Astrophysics Supplement Series '// + & 'v44/p363, v44/p371, v73/p359, v73/p365.',status) + call ftpcom(ounit,'Contact the NASA Science '// + & 'Office of Standards and Technology for the',status) + call ftpcom(ounit,'FITS Definition document '// + & '#100 and other FITS information.',status) + + else + comm='number of random group parameters' + call ftpkyj(ounit,'PCOUNT',pcount,comm,status) + comm='number of random groups' + call ftpkyj(ounit,'GCOUNT',gcount,comm,status) + end if + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftphtb.f b/pkg/tbtables/fitsio/ftphtb.f new file mode 100644 index 00000000..febe1916 --- /dev/null +++ b/pkg/tbtables/fitsio/ftphtb.f @@ -0,0 +1,110 @@ +C---------------------------------------------------------------------- + subroutine ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol, + & tform,tunit,extnam,status) + +C write required standard header keywords for an ASCII table extension +C +C ounit i fortran output unit number +C ncols i number of columns in the table +C nrows i number of rows in the table +C nfield i number of fields in the table +C ttype c name of each field (array) (optional) +C tbcol i beginning column of each field (array) +C tform c Fortran-77 format of each field (array) +C tunit c units of each field (array) (optional) +C extnam c name of table extension (optional) +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,ncols,nrows,nfield,tbcol(*),status,i + character*(*) ttype(*),tform(*),tunit(*),extnam + character comm*48,tfm*20 + + comm='ASCII table extension' + call ftpkys(ounit,'XTENSION','TABLE',comm,status) + + comm='8-bit ASCII characters' + call ftpkyj(ounit,'BITPIX',8,comm,status) + + comm='2-dimensional ASCII table' + call ftpkyj(ounit,'NAXIS',2,comm,status) + + if (status .gt. 0)return + + if (ncols .ge. 0)then + comm='width of table in characters' + call ftpkyj(ounit,'NAXIS1',ncols,comm,status) + else +C illegal table width + status=217 + call ftpmsg('ASCII table has negative width (NAXIS1) in'// + & ' call to FTPHTB') + return + end if + + if (status .gt. 0)return + + if (nrows .ge. 0)then + comm='number of rows in table' + call ftpkyj(ounit,'NAXIS2',nrows,comm,status) + else +C illegal number of rows in table + status=218 + call ftpmsg('ASCII table has negative number of rows in'// + & ' call to FTPHTB') + end if + + if (status .gt. 0)return + + comm='no group parameters (required keyword)' + call ftpkyj(ounit,'PCOUNT',0,comm,status) + + comm='one data group (required)' + call ftpkyj(ounit,'GCOUNT',1,comm,status) + + if (status .gt. 0)return + + if (nfield .ge. 0)then + comm='number of fields in each row' + call ftpkyj(ounit,'TFIELDS',nfield,comm,status) + else +C illegal number of fields + status=216 + call ftpmsg('ASCII table has negative number of fields in'// + & ' call to FTPHTB') + end if + + if (status .gt. 0)return + + do 10 i=1,nfield + if (ttype(i) .ne. ' ' .and. ichar(ttype(i)(1:1)).ne.0)then + comm='label for field ' + write(comm(17:19),1000)i +1000 format(i3) + call ftpkns(ounit,'TTYPE',i,1,ttype(i),comm,status) + end if + + comm='beginning column of field ' + write(comm(27:29),1000)i + call ftpknj(ounit,'TBCOL',i,1,tbcol(i),comm,status) + + comm='Fortran-77 format of field' +C make sure format characters are in upper case: + tfm=tform(i) + call ftupch(tfm) + call ftpkns(ounit,'TFORM',i,1,tfm,comm,status) + + if (tunit(i) .ne. ' ' .and. ichar(tunit(i)(1:1)).ne.0)then + comm='physical unit of field' + call ftpkns(ounit,'TUNIT',i,1,tunit(i),comm,status) + end if + if (status .gt. 0)return +10 continue + + if (extnam .ne. ' ' .and. ichar(extnam(1:1)) .ne. 0)then + comm='name of this ASCII table extension' + call ftpkys(ounit,'EXTNAME',extnam,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpi1b.f b/pkg/tbtables/fitsio/ftpi1b.f new file mode 100644 index 00000000..dc97b8b4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpi1b.f @@ -0,0 +1,26 @@ +C---------------------------------------------------------------------- + subroutine ftpi1b(ounit,nvals,incre,chbuff,status) + +C Write an array of Integer*1 bytes to the output FITS file. + + integer nvals,incre,ounit,status,i,offset + character*1 chbuff(nvals) + +C ounit i fortran unit number +C nvals i number of pixels in the i2vals array +C incre i byte increment between values +C chbuff c*1 array of input byte values +C status i output error status + + if (incre .le. 1)then + call ftpcbf(ounit,0,nvals,chbuff,status) + else +C offset is the number of bytes to move between each value + offset=incre-1 + call ftpcbf(ounit,0,1,chbuff,status) + do 10 i=2,nvals + call ftmoff(ounit,offset,.true.,status) + call ftpcbf(ounit,0,1,chbuff(i),status) +10 continue + end if + end diff --git a/pkg/tbtables/fitsio/ftpini.f b/pkg/tbtables/fitsio/ftpini.f new file mode 100644 index 00000000..60b96438 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpini.f @@ -0,0 +1,167 @@ +C-------------------------------------------------------------------------- + subroutine ftpini(iunit,status) + +C initialize the parameters defining the structure of the primary data + +C iunit i Fortran I/O unit number +C OUTPUT PARAMETERS: +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bitpix,naxis,naxes(99),pcnt,gcnt,ttype + integer blank,bytlen,npix,i,nblank,tstat + double precision bscale,bzero + logical simple,extend,groups + character*8 comm + + if (status .gt. 0)return + groups=.false. + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C store the type of HDU (0=primary array or image extension) + hdutyp(ibuff)=0 + +C temporarily set the location of the end of the header to a huge number + hdend(ibuff)=2000000000 + hdstrt(ibuff,chdu(ibuff)+1)=2000000000 + +C get the standard header keywords + tstat=status + call ftgphx(iunit,99,simple,bitpix,naxis,naxes, + & pcnt,gcnt,extend,bscale,bzero,blank,nblank,status) + if (status .eq. 251)then +C ignore 'unknown extension type' error, and go on + status=tstat + else if (status .gt. 0)then + return + end if + + if (naxis .gt. 99)then +C the image array has too many dimensions for me to handle + status=111 + call ftpmsg('This FITS image has too many dimensions (FTPINI)') + return + end if + +C the 'END' record is 80 bytes before the current position, ignoring +C any trailing blank keywords just before the END keyword. + hdend(ibuff)=nxthdr(ibuff)-80*(nblank+1) + +C the data unit begins at the beginning of the next logical block + dtstrt(ibuff)=((nxthdr(ibuff)-80)/2880+1)*2880 + +C test for the presence of 'random groups' structure + if (naxis .gt. 0 .and. naxes(1) .eq. 0)then + tstat=status + call ftgkyl(iunit,'GROUPS',groups,comm,status) + if (status .gt. 0)then + status=tstat + groups=.false. + end if + end if + +C test bitpix and set the datatype code value + if (bitpix .eq. 8)then + ttype=11 + bytlen=1 + else if (bitpix .eq. 16)then + ttype=21 + bytlen=2 + else if (bitpix .eq. 32)then + ttype=41 + bytlen=4 + else if (bitpix .eq. -32)then + ttype=42 + bytlen=4 + else if (bitpix .eq. -64)then + ttype=82 + bytlen=8 + end if + +C calculate the size of the primary array + if (naxis .eq. 0)then + npix=0 + else + if (groups)then +C NAXIS1 = 0 is a special flag for 'random groups' + npix=1 + else + npix=naxes(1) + end if + + do 10 i=2,naxis + npix=npix*naxes(i) +10 continue + end if + +C now we know everything about the array; just fill in the parameters: +C the next HDU begins in the next logical block after the data + hdstrt(ibuff,chdu(ibuff)+1)= + & dtstrt(ibuff)+((pcnt+npix)*bytlen*gcnt+2879)/2880*2880 + +C initialize the fictitious heap starting address (immediately following +C the array data) and a zero length heap. This is used to find the +C end of the data when checking the fill values in the last block. + scount(ibuff)=0 + theap(ibuff)=(pcnt+npix)*bytlen*gcnt + nxheap(ibuff)=0 + +C quit if there is no data + if (naxis .eq. 0)then + tfield(ibuff)=0 + rowlen(ibuff)=0 + go to 900 + end if + +C the primary array is actually interpreted as a binary table. There +C are two columns: the first column contains the +C group parameters, if any, and the second column contains the +C primary array of data. Each group is in a separate row of the table. + + tfield(ibuff)=2 + if (nxtfld + 2 .gt. nf)then +C too many columns open at one time; exceeded array dimensions + status=111 + else + tstart(ibuff)=nxtfld + nxtfld=nxtfld+2 + tdtype(1+tstart(ibuff))=ttype + tdtype(2+tstart(ibuff))=ttype + trept(1+tstart(ibuff))=pcnt + trept(2+tstart(ibuff))=npix + tnull(1+tstart(ibuff))=blank + tnull(2+tstart(ibuff))=blank + tscale(1+tstart(ibuff))=1. + tscale(2+tstart(ibuff))=bscale + tzero(1+tstart(ibuff))=0. + tzero(2+tstart(ibuff))=bzero + tbcol(1+tstart(ibuff))=0 + tbcol(2+tstart(ibuff))=pcnt*bytlen + rowlen(ibuff)=(pcnt+npix)*bytlen + end if + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftpkey.f b/pkg/tbtables/fitsio/ftpkey.f new file mode 100644 index 00000000..b4ce180b --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkey.f @@ -0,0 +1,28 @@ +C-------------------------------------------------------------------------- + subroutine ftpkey(ounit,keywrd,value,comm,status) + +C write a simple FITS keyword record with format: +C "KEYWORD = VALUE / COMMENT" +C VALUE is assumed to be 20 characters long +C COMMENT is assumed to be 47 characters long +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C value c keyword value (20 characters, cols. 11-30) +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,value,comm + integer ounit,status + character key*8, val*20, com*47 + + key=keywrd + val=value + com=comm + +C append the 80 characters to the output buffer: + call ftprec(ounit,key//'= '//val//' / '//com,status) + end diff --git a/pkg/tbtables/fitsio/ftpkls.f b/pkg/tbtables/fitsio/ftpkls.f new file mode 100644 index 00000000..0e7d52c5 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkls.f @@ -0,0 +1,103 @@ +C-------------------------------------------------------------------------- + subroutine ftpkls(ounit,keywrd,strval,comm,status) + +C write a character string value to a header record, supporting +C the OGIP long string convention. If the keyword string value +C is longer than 68 characters (which is the maximum that will fit +C on a single 80 character keyword record) then the value string will +C be continued over multiple keywords. This OGIP convention uses the +C '&' character at the end of a string to indicate that it is continued +C on the next keyword. The name of all the continued keywords is +C 'CONTINUE'. +C +C The FTPLSW subroutine should be called prior to using this +C subroutine, to write a warning message in the header +C describing how the convention works. + +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C strval c keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Sept 1994 + + character*(*) keywrd,comm,strval + integer ounit,status,lenval,ncomm,nvalue + integer clen,i,strlen,nseg,c1,c2 + character value*70,keynam*10,cmnt*48 + + if (status .gt. 0)return + + keynam=keywrd + keynam(9:10)='= ' + cmnt=comm + +C find the number of characters in the input string + clen=len(strval) + do 10 i=clen,1,-1 + if (strval(i:i) .ne. ' ')then + strlen=i + go to 20 + end if +10 continue + strlen=1 + +C calculate the number of keywords needed to write the whole string +20 nseg=max(1,(strlen-2)/67+1) + + c1=1 + do 30 i=1,nseg + c2=min(c1+67,strlen) +C convert string to quoted character string + +C fts2c was modified on 29 Nov 1994, so this code is no longer needed +C (remember to declare character*70 ctemp if this code is used) +C if (i .gt. 1 .and. strval(c1:c1) .eq. ' ')then +CC have to preserve leading blanks on continuation cards +C ctemp='A'//strval(c1+1:c2) +C call fts2c(ctemp,value,lenval,status) +CC now reset the first character of the string back to a blank +C value(2:2)=' ' +C else + + call fts2c(strval(c1:c2),value,lenval,status) + +C end if + + if (i .ne. nseg .and. lenval .ne. 70)then +C if the string is continued, preserve trailing blanks + value(lenval:69)=' ' + value(70:70)='''' + lenval=70 + end if + +C overwrite last character with a '&' if string is continued. + if (i .lt. nseg)then + value(69:69)='&' + end if + +C find amount of space left for comment string (assume +C 10 char. for 'keyword = ', and 3 between value and comment) +C which leaves 67 spaces for the value + comment strings + + nvalue=max(20,lenval) + ncomm=67-nvalue + +C write the keyword record + if (ncomm .gt. 0)then +C there is space for a comment + call ftprec(ounit,keynam// + & value(1:nvalue)//' / '//cmnt(1:ncomm),status) + else +C no room for a comment + call ftprec(ounit,keynam// + & value(1:nvalue)//' ',status) + end if + +C initialize for the next segment of the string, if any + c1=c1+67 + keynam='CONTINUE ' +30 continue + end diff --git a/pkg/tbtables/fitsio/ftpknd.f b/pkg/tbtables/fitsio/ftpknd.f new file mode 100644 index 00000000..289fc370 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpknd.f @@ -0,0 +1,45 @@ +C-------------------------------------------------------------------------- + subroutine ftpknd(ounit,keywrd,nstart,nkey,dval,decim,comm, + & status) + +C write an array of real*8 values to header records in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C dval d array of keyword values +C decim i number of decimal places to display in the value field +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,decim,ounit,status,i,j + double precision dval(*) + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkyd(ounit,keynam,dval(i),decim,comm1,status) + else + call ftpkyd(ounit,keynam,dval(i),decim,comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpkne.f b/pkg/tbtables/fitsio/ftpkne.f new file mode 100644 index 00000000..36f13add --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkne.f @@ -0,0 +1,45 @@ +C-------------------------------------------------------------------------- + subroutine ftpkne(ounit,keywrd,nstart,nkey,rval,decim,comm, + & status) + +C write an array of real*4 values to header records in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C rval r array of keyword values +C decim i number of decimal places to display in the value field +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,decim,ounit,status,i,j + real rval(*) + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkye(ounit,keynam,rval(i),decim,comm1,status) + else + call ftpkye(ounit,keynam,rval(i),decim,comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpknf.f b/pkg/tbtables/fitsio/ftpknf.f new file mode 100644 index 00000000..89ffab7f --- /dev/null +++ b/pkg/tbtables/fitsio/ftpknf.f @@ -0,0 +1,45 @@ +C-------------------------------------------------------------------------- + subroutine ftpknf(ounit,keywrd,nstart,nkey,rval,decim,comm, + & status) + +C write an array of real*4 values to header records in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C rval r array of keyword values +C decim i number of decimal places to display in the value field +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,decim,ounit,status,i,j + real rval(*) + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkyf(ounit,keynam,rval(i),decim,comm1,status) + else + call ftpkyf(ounit,keynam,rval(i),decim,comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpkng.f b/pkg/tbtables/fitsio/ftpkng.f new file mode 100644 index 00000000..ad8f3592 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkng.f @@ -0,0 +1,45 @@ +C-------------------------------------------------------------------------- + subroutine ftpkng(ounit,keywrd,nstart,nkey,dval,decim,comm, + & status) + +C write an array of real*8 values to header records in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C dval d array of keyword values +C decim i number of decimal places to display in the value field +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,decim,ounit,status,i,j + double precision dval(*) + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkyg(ounit,keynam,dval(i),decim,comm1,status) + else + call ftpkyg(ounit,keynam,dval(i),decim,comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpknj.f b/pkg/tbtables/fitsio/ftpknj.f new file mode 100644 index 00000000..d6d23834 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpknj.f @@ -0,0 +1,43 @@ +C-------------------------------------------------------------------------- + subroutine ftpknj(ounit,keywrd,nstart,nkey,intval,comm, + & status) + +C write an array of integer values to header records +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C intval i array of keyword values +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,ounit,status,intval(*),i,j + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkyj(ounit,keynam,intval(i),comm1,status) + else + call ftpkyj(ounit,keynam,intval(i),comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpknl.f b/pkg/tbtables/fitsio/ftpknl.f new file mode 100644 index 00000000..d23350ac --- /dev/null +++ b/pkg/tbtables/fitsio/ftpknl.f @@ -0,0 +1,44 @@ +C-------------------------------------------------------------------------- + subroutine ftpknl(ounit,keywrd,nstart,nkey,logval,comm, + & status) + +C write an array of logical values to header records +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C logval l array of keyword values +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm(*) + integer nstart,nkey,ounit,status,i,j + logical logval(*) + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords +C (if the last non-blank character is '&', then it is to be repeated) + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkyl(ounit,keynam,logval(i),comm1,status) + else + call ftpkyl(ounit,keynam,logval(i),comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpkns.f b/pkg/tbtables/fitsio/ftpkns.f new file mode 100644 index 00000000..588a5738 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkns.f @@ -0,0 +1,42 @@ +C-------------------------------------------------------------------------- + subroutine ftpkns(ounit,keywrd,nstart,nkey,strval,comm, + & status) + +C write an array of character string values to header records +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C nstart i starting sequence number (usually 1) +C nkey i number of keywords to write +C strval c array of keyword values +C comm c array of keyword comments (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,strval(*),comm(*) + integer nstart,nkey,ounit,status,i,j + character keynam*8,comm1*48 + logical repeat + + if (status .gt. 0)return + +C check if the first comment string is to be repeated for all keywords + call ftcrep(comm(1),comm1,repeat) + + j=nstart + do 10 i=1,nkey +C construct keyword name: + call ftkeyn(keywrd,j,keynam,status) + +C write the keyword record + if (repeat)then + call ftpkys(ounit,keynam,strval(i),comm1,status) + else + call ftpkys(ounit,keynam,strval(i),comm(i),status) + end if + if (status .gt. 0)return + j=j+1 +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpkyd.f b/pkg/tbtables/fitsio/ftpkyd.f new file mode 100644 index 00000000..560222ea --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyd.f @@ -0,0 +1,32 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyd(ounit,keywrd,dval,decim,comm,status) + +C write a double precision value to a header record in E format +C If it will fit, the value field will be 20 characters wide; +C otherwise it will be expanded to up to 35 characters, left +C justified. +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (max. 47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim,vlen + character value*35,key*8,cmnt*48 + + key=keywrd + cmnt=comm + +C convert double precision to E format character string + call ftd2e(dval,decim,value,vlen,status) + +C write the keyword record + call ftprec(ounit,key//'= '//value(1:vlen)//' / '//cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftpkye.f b/pkg/tbtables/fitsio/ftpkye.f new file mode 100644 index 00000000..a74200b9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkye.f @@ -0,0 +1,26 @@ +C-------------------------------------------------------------------------- + subroutine ftpkye(ounit,keywrd,rval,decim,comm,status) + +C write a real*4 value to a header record in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim + character value*20 + +C convert real to E format character string + call ftr2e(rval,decim,value,status) + +C write the keyword record + call ftpkey(ounit,keywrd,value,comm,status) + end diff --git a/pkg/tbtables/fitsio/ftpkyf.f b/pkg/tbtables/fitsio/ftpkyf.f new file mode 100644 index 00000000..a67312bd --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyf.f @@ -0,0 +1,26 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyf(ounit,keywrd,rval,decim,comm,status) + +C write a real*4 value to a header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim + character value*20 + +C convert real to F format character string + call ftr2f(rval,decim,value,status) + +C write the keyword record + call ftpkey(ounit,keywrd,value,comm,status) + end diff --git a/pkg/tbtables/fitsio/ftpkyg.f b/pkg/tbtables/fitsio/ftpkyg.f new file mode 100644 index 00000000..b9ee55e2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyg.f @@ -0,0 +1,26 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyg(ounit,keywrd,dval,decim,comm,status) + +C write a double precision value to a header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim + character value*20 + +C convert double precision to F format character string + call ftd2f(dval,decim,value,status) + +C write the keyword record + call ftpkey(ounit,keywrd,value,comm,status) + end diff --git a/pkg/tbtables/fitsio/ftpkyj.f b/pkg/tbtables/fitsio/ftpkyj.f new file mode 100644 index 00000000..330d9447 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyj.f @@ -0,0 +1,24 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyj(ounit,keywrd,intval,comm,status) + +C write an integer value to a header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C intval i keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer ounit,status,intval + character value*20 + +C convert integer to character string + call fti2c(intval,value,status) + +C write the keyword record + call ftpkey(ounit,keywrd,value,comm,status) + end diff --git a/pkg/tbtables/fitsio/ftpkyl.f b/pkg/tbtables/fitsio/ftpkyl.f new file mode 100644 index 00000000..1cf1cb75 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyl.f @@ -0,0 +1,25 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyl(ounit,keywrd,logval,comm,status) + +C write a logical value to a header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C logval l keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) keywrd,comm + integer ounit,status + logical logval + character value*20 + +C convert logical to character string + call ftl2c(logval,value,status) + +C write the keyword record + call ftpkey(ounit,keywrd,value,comm,status) + end diff --git a/pkg/tbtables/fitsio/ftpkys.f b/pkg/tbtables/fitsio/ftpkys.f new file mode 100644 index 00000000..d68e5add --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkys.f @@ -0,0 +1,58 @@ +C-------------------------------------------------------------------------- + subroutine ftpkys(ounit,keywrd,strval,comm,status) + +C write a character string value to a header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C strval c keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C modified 6/93 to handle long string values by continuing the +C string onto subsequent comment keywords (with a blank keyword name) + +C Modified again in 9/94 to remove support for long string values; +C Now, one must call ftpkls to write a long string values. + + character*(*) keywrd,comm,strval + integer ounit,status,lenval,ncomm,nvalue + character strtmp*68,value*70,keynam*8,cmnt*48 + + if (status .gt. 0)return + + strtmp=strval + keynam=keywrd + cmnt=comm + +C convert string to quoted character string (max length = 70 characters) + call fts2c(strtmp,value,lenval,status) + + if (lenval .gt. 70)then +C truncate the string to 70 characters (if the input string contained +C apostrophies, then it could get expanded to more than 70 characters) + value(70:70)='''' + lenval=70 +C N.B. there could be a problem here if character 69 is also a '. +C Then the closing quote would be considered a literal appostrophy. + end if + +C find amount of space left for comment string +C (assume 10 char. for 'keyword = ', and 3 between value and comment) +C which leaves 67 spaces for the value string + comment string + nvalue=max(20,lenval) + ncomm=67-nvalue + +C write the keyword record + if (ncomm .gt. 0)then +C there is space for a comment + call ftprec(ounit, + & keynam//'= '//value(1:nvalue)//' / '//cmnt(1:ncomm),status) + else +C no room for a comment + call ftprec(ounit, + & keynam//'= '//value(1:nvalue)//' ',status) + end if + end diff --git a/pkg/tbtables/fitsio/ftpkyt.f b/pkg/tbtables/fitsio/ftpkyt.f new file mode 100644 index 00000000..766fee96 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpkyt.f @@ -0,0 +1,41 @@ +C-------------------------------------------------------------------------- + subroutine ftpkyt(ounit,keywrd,jval,dval,comm,status) + +C concatinate a integer value with a double precision fraction +C and write it to the FITS header along with the comment string +C The value will be displayed in F28.16 format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C jval i integer part of the keyword value +C dval d fractional part of the keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Sept 1992 + + character*(*) keywrd,comm + double precision dval + integer ounit,jval,status,dlen + character dstr*35,jstr*20,key*8,cmnt*48 + + if (status .gt. 0)return + + if (dval .ge. 1.0 .or. dval .lt. 0.)then + status = 402 + end if + + key=keywrd + cmnt=comm + +C convert integer to C*20 character string + call fti2c(jval,jstr,status) + +C convert double precision to E23.16 format character string + call ftd2e(dval,20,dstr,dlen,status) + +C write the concatinated keyword record + call ftprec(ounit,key//'= '//jstr(10:20)//'.'// + 1 dstr(2:2)//dstr(4:18)//' / '//cmnt,status) + end diff --git a/pkg/tbtables/fitsio/ftplsw.f b/pkg/tbtables/fitsio/ftplsw.f new file mode 100644 index 00000000..58d3d5d7 --- /dev/null +++ b/pkg/tbtables/fitsio/ftplsw.f @@ -0,0 +1,39 @@ +C-------------------------------------------------------------------------- + subroutine ftplsw(ounit,status) + +C Put Long String Warning: +C write the LONGSTRN keyword and a few COMMENT keywords to the header +C (if they don't already exist) to warn users that this FITS file +C may use the OGIP long string convention. + +C This subroutine should be called whenever FTPKLS is called. + + integer ounit,status,tstat + character value*8,comm*8 + + if (status .gt. 0)return + + tstat=status + call ftgkys(ounit,'LONGSTRN',value,comm,status) + if (status .eq. 0)then +C The keyword already exists so just exit + return + end if + + status=tstat + call ftpkys(ounit,'LONGSTRN','OGIP 1.0', + & 'The OGIP Long String Convention may be used.',status) + + call ftpcom(ounit, + & 'This FITS file may contain long string keyword values that are' + & ,status) + call ftpcom(ounit, + & 'continued over multiple keywords. The OGIP convention uses the' + & //' &',status) + call ftpcom(ounit, + & 'character at the end of each substring which is then continued' + & ,status) + call ftpcom(ounit, + & 'on the next keyword which has the name CONTINUE.' + & ,status) + end diff --git a/pkg/tbtables/fitsio/ftpmsg.f b/pkg/tbtables/fitsio/ftpmsg.f new file mode 100644 index 00000000..0cf605b1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpmsg.f @@ -0,0 +1,7 @@ +C------------------------------------------------------------------------------ + subroutine ftpmsg(text) + +C put error message onto stack. + character*(*) text + call ftxmsg(1,text) + end diff --git a/pkg/tbtables/fitsio/ftpnul.f b/pkg/tbtables/fitsio/ftpnul.f new file mode 100644 index 00000000..c46152b9 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpnul.f @@ -0,0 +1,58 @@ +C-------------------------------------------------------------------------- + subroutine ftpnul(ounit,blank,status) + +C Primary Null value definition +C Define the null value for an integer primary array. +C +C ounit i Fortran I/O unit number +C blank i the value to be use to signify undefined data +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,blank,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,ngroup + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + if (status .gt. 0)return + +C test for proper HDU type + if (hdutyp(ibuff) .ne. 0)then + status=233 + return + end if + +C the primary array is actually interpreted as a binary table. There +C are two columns for each group: the first column contains the +C group parameters, if any, and the second column contains the +C primary array of data. + + ngroup=tfield(ibuff)/2 + do 10 i=1,ngroup + tnull(i*2+tstart(ibuff))=blank +10 continue + end diff --git a/pkg/tbtables/fitsio/ftppnb.f b/pkg/tbtables/fitsio/ftppnb.f new file mode 100644 index 00000000..9f6cd175 --- /dev/null +++ b/pkg/tbtables/fitsio/ftppnb.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftppnb(ounit,group,felem,nelem,array,nulval,status) + +C Write an array of c*1 (byte) values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same as the +C array being written). Any input pixels equal to the value of NULVAL +C will be replaced by the appropriate null value in the output FITS file. + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array c*1 the array of values to be written +C nulval c*1 pixel value used to represent an undefine pixel +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,group,felem,nelem,status,row + character*1 array(*),nulval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcnb(ounit,2,row,felem,nelem,array,nulval,status) + end diff --git a/pkg/tbtables/fitsio/ftppnd.f b/pkg/tbtables/fitsio/ftppnd.f new file mode 100644 index 00000000..836b6a62 --- /dev/null +++ b/pkg/tbtables/fitsio/ftppnd.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftppnd(ounit,group,felem,nelem,array,nulval,status) + +C Write an array of double precision values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same as the +C array being written). Any input pixels equal to the value of NULVAL +C will be replaced by the appropriate null value in the output FITS file. + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array d the array of values to be written +C nulval d pixel value used to represent an undefine pixel +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,group,felem,nelem,status,row + double precision array(*),nulval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcnd(ounit,2,row,felem,nelem,array,nulval,status) + end diff --git a/pkg/tbtables/fitsio/ftppne.f b/pkg/tbtables/fitsio/ftppne.f new file mode 100644 index 00000000..ca87a68b --- /dev/null +++ b/pkg/tbtables/fitsio/ftppne.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftppne(ounit,group,felem,nelem,array,nulval,status) + +C Write an array of real values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same as the +C array being written). Any input pixels equal to the value of NULVAL +C will be replaced by the appropriate null value in the output FITS file. + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array r the array of values to be written +C nulval r pixel value used to represent an undefine pixel +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,group,felem,nelem,status,row + real array(*),nulval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcne(ounit,2,row,felem,nelem,array,nulval,status) + end diff --git a/pkg/tbtables/fitsio/ftppni.f b/pkg/tbtables/fitsio/ftppni.f new file mode 100644 index 00000000..0fd71641 --- /dev/null +++ b/pkg/tbtables/fitsio/ftppni.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftppni(ounit,group,felem,nelem,array,nulval,status) + +C Write an array of i*2 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same as the +C array being written). Any input pixels equal to the value of NULVAL +C will be replaced by the appropriate null value in the output FITS file. + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array i*2 the array of values to be written +C nulval i*2 pixel value used to represent an undefine pixel +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,group,felem,nelem,status,row + integer*2 array(*),nulval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcni(ounit,2,row,felem,nelem,array,nulval,status) + end diff --git a/pkg/tbtables/fitsio/ftppnj.f b/pkg/tbtables/fitsio/ftppnj.f new file mode 100644 index 00000000..c8bac808 --- /dev/null +++ b/pkg/tbtables/fitsio/ftppnj.f @@ -0,0 +1,31 @@ +C---------------------------------------------------------------------- + subroutine ftppnj(ounit,group,felem,nelem,array,nulval,status) + +C Write an array of i values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same as the +C array being written). Any input pixels equal to the value of NULVAL +C will be replaced by the appropriate null value in the output FITS file. + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array i the array of values to be written +C nulval i pixel value used to represent an undefine pixel +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1994 + + integer ounit,group,felem,nelem,status,row + integer array(*),nulval + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcnj(ounit,2,row,felem,nelem,array,nulval,status) + end diff --git a/pkg/tbtables/fitsio/ftpprb.f b/pkg/tbtables/fitsio/ftpprb.f new file mode 100644 index 00000000..60ff91e1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpprb.f @@ -0,0 +1,30 @@ +C---------------------------------------------------------------------- + subroutine ftpprb(ounit,group,felem,nelem,array,status) + +C Write an array of byte values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array b the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + + character*1 array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpclb(ounit,2,row,felem,nelem,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpprd.f b/pkg/tbtables/fitsio/ftpprd.f new file mode 100644 index 00000000..bfb15d05 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpprd.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftpprd(ounit,group,felem,nelem,array,status) + +C Write an array of r*8 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array d the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + double precision array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcld(ounit,2,row,felem,nelem,array,status) + end diff --git a/pkg/tbtables/fitsio/ftppre.f b/pkg/tbtables/fitsio/ftppre.f new file mode 100644 index 00000000..c6b9827b --- /dev/null +++ b/pkg/tbtables/fitsio/ftppre.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftppre(ounit,group,felem,nelem,array,status) + +C Write an array of r*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array r the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + real array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcle(ounit,2,row,felem,nelem,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpprh.f b/pkg/tbtables/fitsio/ftpprh.f new file mode 100644 index 00000000..f452cd2a --- /dev/null +++ b/pkg/tbtables/fitsio/ftpprh.f @@ -0,0 +1,12 @@ +C---------------------------------------------------------------------- + subroutine ftpprh(ounit,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + +C OBSOLETE routine: should call ftphpr instead + + integer ounit,bitpix,naxis,naxes(*),pcount,gcount,status + logical simple,extend + + call ftphpr(ounit,simple,bitpix,naxis,naxes, + & pcount,gcount,extend,status) + end diff --git a/pkg/tbtables/fitsio/ftppri.f b/pkg/tbtables/fitsio/ftppri.f new file mode 100644 index 00000000..691ac191 --- /dev/null +++ b/pkg/tbtables/fitsio/ftppri.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftppri(ounit,group,felem,nelem,array,status) + +C Write an array of i*2 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array i*2 the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + integer*2 array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpcli(ounit,2,row,felem,nelem,array,status) + end diff --git a/pkg/tbtables/fitsio/ftpprj.f b/pkg/tbtables/fitsio/ftpprj.f new file mode 100644 index 00000000..a9b1aa45 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpprj.f @@ -0,0 +1,29 @@ +C---------------------------------------------------------------------- + subroutine ftpprj(ounit,group,felem,nelem,array,status) + +C Write an array of i*4 values into the primary array. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being written). + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be written +C array i the array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + integer array(*) + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpclj(ounit,2,row,felem,nelem,array,status) + end diff --git a/pkg/tbtables/fitsio/ftppru.f b/pkg/tbtables/fitsio/ftppru.f new file mode 100644 index 00000000..3c0f6f3a --- /dev/null +++ b/pkg/tbtables/fitsio/ftppru.f @@ -0,0 +1,24 @@ +C---------------------------------------------------------------------- + subroutine ftppru(ounit,group,felem,nelem,status) + +C set elements of the primary array equal to the undefined value + +C ounit i Fortran output unit number +C group i number of the data group, if any +C felem i the first pixel to be written (this routine treats +C the primary array a large one dimensional array of +C values, regardless of the actual dimensionality). +C nelem i number of data elements to be set to undefined +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,group,felem,nelem,status,row + +C the primary array is represented as a binary table: +C each group of the primary array is a row in the table, +C where the first column contains the group parameters +C and the second column contains the image itself + row=max(group,1) + call ftpclu(ounit,2,row,felem,nelem,status) + end diff --git a/pkg/tbtables/fitsio/ftprec.f b/pkg/tbtables/fitsio/ftprec.f new file mode 100644 index 00000000..febc78b8 --- /dev/null +++ b/pkg/tbtables/fitsio/ftprec.f @@ -0,0 +1,67 @@ +C-------------------------------------------------------------------------- + subroutine ftprec(ounit,record,status) + +C write a 80 character record to the FITS header +C +C ounit i fortran output unit number +C record c input 80 character header record +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*(*) record + character*80 rec + integer ounit,status,ibuff + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C-------END OF COMMON BLOCK DEFINITIONS:------- ----------------------------- + + if (status .gt. 0)return + +C get the number of the data buffer used for this unit + ibuff=bufnum(ounit) + + if (dtstrt(ibuff) .gt. 0 + & .and.(dtstrt(ibuff)-hdend(ibuff)) .le. 80)then +C not enough room in the header for another keyword + +C try getting more header space + call ftiblk(ounit,1,0,status) + if (status .gt. 0)then + go to 900 + end if + end if + + rec=record + +C make sure keyword name is in upper case + call ftupch(rec(1:8)) + +C test that keyword name contains only legal characters + call fttkey(rec(1:8),status) + +C test that the rest of the record contains only legal values + call fttrec(rec(9:80),status) + +C position the I/O pointer to the end of the header + call ftmbyt(ounit,hdend(ibuff),.true.,status) + +C append the 80 characters to the output buffer: + call ftpcbf(ounit,1,80,rec,status) + if (status .gt. 0)go to 900 + +C increment the pointer to the last header record + hdend(ibuff)=hdend(ibuff)+80 + nxthdr(ibuff)=hdend(ibuff) + +900 continue + end diff --git a/pkg/tbtables/fitsio/ftprsv.f b/pkg/tbtables/fitsio/ftprsv.f new file mode 100644 index 00000000..ba87cde1 --- /dev/null +++ b/pkg/tbtables/fitsio/ftprsv.f @@ -0,0 +1,82 @@ +C-------------------------------------------------------------------------- + subroutine ftprsv(keyrec,lenval,status) + +C find the total length of the keyword+value string in a keyword record + +C keyrec c 80 column header record +C OUTPUT PARAMETERS: +C lenval i output length of keyword+value string +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*80 keyrec + integer lenval,status,j,c1 + + if (status .gt. 0)return + + if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY ' + & .or. keyrec(1:8).eq.'END ' .or. keyrec(1:8).eq.' ') + & then +C this is a COMMENT or HISTORY record, with no value + lenval=8 + else if (keyrec(9:10) .eq. '= ')then +C this keyword has a value field; now find the first character: + do 10 j=10,80 + if (keyrec(j:j) .ne. ' ')then + c1=j + go to 15 + end if +10 continue +C error: value is blank + status=204 + call ftpmsg('The keyword '//keyrec(1:8)// + & ' has no value string after the equal sign:') + call ftpmsg(keyrec) + return + +15 if (keyrec(c1:c1) .eq. '''')then +C This is a string value. +C Work forward to find a single quote. Two single quotes +C in succession is to be interpreted as a literal single +C quote character as part of the character string, not as +C the end of the character string. Everything to the right +C of the closing quote is assumed to be the comment. + do 20 j=c1+1,80 + if (keyrec(j:j) .eq. '''')then + if (j.lt.80 .and. keyrec(j+1:j+1).eq.'''')then +C found 2 successive quote characters; this is +C interpreted as a literal quote character + else + lenval=max(30,j) + go to 30 + end if + end if +20 continue +C error: no closing quote character + status=205 + call ftpmsg('The following Keyword value string has '// + & 'no closing quote:') + call ftpmsg(keyrec) + return + else +C This is either an integer, floating point, or logical value. +C Extract the first token as the value; remainder = comment + do 25 j=c1,80 + if (keyrec(j:j) .eq. ' ')then + lenval=j-1 + go to 30 + end if +25 continue +C the first token went all the way to column 80: + lenval=80 + end if + else +C illegal keyword record format; must have '= ' in columns 9-10 +C status=210 +C Modified July 1993: this is actually not an error. The +C keyword should simply be interpreted as a comment. + lenval=8 + end if +30 continue + end diff --git a/pkg/tbtables/fitsio/ftpscl.f b/pkg/tbtables/fitsio/ftpscl.f new file mode 100644 index 00000000..af0505c8 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpscl.f @@ -0,0 +1,66 @@ +C-------------------------------------------------------------------------- + subroutine ftpscl(ounit,bscale,bzero,status) + +C Primary SCaLing factor definition +C Define the scaling factor for the primary header data. +C +C ounit i Fortran I/O unit number +C bscale d scaling factor +C bzero d scaling zero point +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,status + double precision bscale,bzero + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,i,ngroup + + if (status .gt. 0)return + + if (bscale .eq. 0.)then +C illegal bscale value + status=322 + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + if (status .gt. 0)return + +C test for proper HDU type + if (hdutyp(ibuff) .ne. 0)then + status=233 + return + end if + +C the primary array is actually interpreted as a binary table. There +C are two columns for each group: the first column contains the +C group parameters, if any, and the second column contains the +C primary array of data. + ngroup=tfield(ibuff)/2 + do 10 i=1,ngroup + tscale(i*2+tstart(ibuff))=bscale + tzero(i*2+tstart(ibuff))=bzero +10 continue + end diff --git a/pkg/tbtables/fitsio/ftpssb.f b/pkg/tbtables/fitsio/ftpssb.f new file mode 100644 index 00000000..5c65ef7c --- /dev/null +++ b/pkg/tbtables/fitsio/ftpssb.f @@ -0,0 +1,114 @@ +C-------------------------------------------------------------------------- + subroutine ftpssb(iunit,group,naxis,naxes,fpixel,lpixel, + & array,status) + +C Write a subsection of byte values to the primary array. +C A subsection is defined to be any contiguous rectangular +C array of pixels within the n-dimensional FITS data file. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran input unit number +C group i number of the data group to be written, if any +C naxis i number of data axes in the FITS array +C naxes i (array) size of each FITS axis +C fpixel i (array) the first pixel in each dimension to be included +C in the subsection (first pixel = 1) +C lpixel i (array) the last pixel in each dimension to be included +C in the subsection +C array c*1 array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status + character*1 array(*) + integer fpix(7),irange(7),dimen(7),astart,pstart + integer off2,off3,off4,off5,off6,off7 + integer st10,st20,st30,st40,st50,st60,st70 + integer st1,st2,st3,st4,st5,st6,st7 + integer i,i1,i2,i3,i4,i5,i6,i7 + character caxis*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 7)then +C this routine only supports up to 7 dimensions + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSB ' + & //'is illegal.') + return + end if + +C calculate the sizes and number of loops to perform in each dimension + do 10 i=1,7 + fpix(i)=1 + irange(i)=1 + dimen(i)=1 +10 continue + + do 20 i=1,naxis + fpix(i)=fpixel(i) + irange(i)=lpixel(i)-fpixel(i)+1 + dimen(i)=naxes(i) +20 continue + i1=irange(1) + +C compute the pixel offset between each dimension + off2= dimen(1) + off3=off2*dimen(2) + off4=off3*dimen(3) + off5=off4*dimen(4) + off6=off5*dimen(5) + off7=off6*dimen(6) + + st10=fpix(1) + st20=(fpix(2)-1)*off2 + st30=(fpix(3)-1)*off3 + st40=(fpix(4)-1)*off4 + st50=(fpix(5)-1)*off5 + st60=(fpix(6)-1)*off6 + st70=(fpix(7)-1)*off7 + +C store the initial offset in each dimension + st1=st10 + st2=st20 + st3=st30 + st4=st40 + st5=st50 + st6=st60 + st7=st70 + + astart=1 + + do 170 i7=1,irange(7) + do 160 i6=1,irange(6) + do 150 i5=1,irange(5) + do 140 i4=1,irange(4) + do 130 i3=1,irange(3) + pstart=st1+st2+st3+st4+st5+st6+st7 + do 120 i2=1,irange(2) + call ftpprb(iunit,group,pstart,i1, + & array(astart),status) + astart=astart+i1 + pstart=pstart+off2 +120 continue + st2=st20 + st3=st3+off3 +130 continue + st3=st30 + st4=st4+off4 +140 continue + st4=st40 + st5=st5+off5 +150 continue + st5=st50 + st6=st6+off6 +160 continue + st6=st60 + st7=st7+off7 +170 continue + end diff --git a/pkg/tbtables/fitsio/ftpssd.f b/pkg/tbtables/fitsio/ftpssd.f new file mode 100644 index 00000000..b2269e94 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpssd.f @@ -0,0 +1,114 @@ +C-------------------------------------------------------------------------- + subroutine ftpssd(iunit,group,naxis,naxes,fpixel,lpixel, + & array,status) + +C Write a subsection of double precision values to the primary array. +C A subsection is defined to be any contiguous rectangular +C array of pixels within the n-dimensional FITS data file. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran input unit number +C group i number of the data group to be written, if any +C naxis i number of data axes in the FITS array +C naxes i (array) size of each FITS axis +C fpixel i (array) the first pixel in each dimension to be included +C in the subsection (first pixel = 1) +C lpixel i (array) the last pixel in each dimension to be included +C in the subsection +C array d array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status + double precision array(*) + integer fpix(7),irange(7),dimen(7),astart,pstart + integer off2,off3,off4,off5,off6,off7 + integer st10,st20,st30,st40,st50,st60,st70 + integer st1,st2,st3,st4,st5,st6,st7 + integer i,i1,i2,i3,i4,i5,i6,i7 + character caxis*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 7)then +C this routine only supports up to 7 dimensions + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSD ' + & //'is illegal.') + return + end if + +C calculate the sizes and number of loops to perform in each dimension + do 10 i=1,7 + fpix(i)=1 + irange(i)=1 + dimen(i)=1 +10 continue + + do 20 i=1,naxis + fpix(i)=fpixel(i) + irange(i)=lpixel(i)-fpixel(i)+1 + dimen(i)=naxes(i) +20 continue + i1=irange(1) + +C compute the pixel offset between each dimension + off2= dimen(1) + off3=off2*dimen(2) + off4=off3*dimen(3) + off5=off4*dimen(4) + off6=off5*dimen(5) + off7=off6*dimen(6) + + st10=fpix(1) + st20=(fpix(2)-1)*off2 + st30=(fpix(3)-1)*off3 + st40=(fpix(4)-1)*off4 + st50=(fpix(5)-1)*off5 + st60=(fpix(6)-1)*off6 + st70=(fpix(7)-1)*off7 + +C store the initial offset in each dimension + st1=st10 + st2=st20 + st3=st30 + st4=st40 + st5=st50 + st6=st60 + st7=st70 + + astart=1 + + do 170 i7=1,irange(7) + do 160 i6=1,irange(6) + do 150 i5=1,irange(5) + do 140 i4=1,irange(4) + do 130 i3=1,irange(3) + pstart=st1+st2+st3+st4+st5+st6+st7 + do 120 i2=1,irange(2) + call ftpprd(iunit,group,pstart,i1, + & array(astart),status) + astart=astart+i1 + pstart=pstart+off2 +120 continue + st2=st20 + st3=st3+off3 +130 continue + st3=st30 + st4=st4+off4 +140 continue + st4=st40 + st5=st5+off5 +150 continue + st5=st50 + st6=st6+off6 +160 continue + st6=st60 + st7=st7+off7 +170 continue + end diff --git a/pkg/tbtables/fitsio/ftpsse.f b/pkg/tbtables/fitsio/ftpsse.f new file mode 100644 index 00000000..55a79a73 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpsse.f @@ -0,0 +1,114 @@ +C-------------------------------------------------------------------------- + subroutine ftpsse(iunit,group,naxis,naxes,fpixel,lpixel, + & array,status) + +C Write a subsection of real values to the primary array. +C A subsection is defined to be any contiguous rectangular +C array of pixels within the n-dimensional FITS data file. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran input unit number +C group i number of the data group to be written, if any +C naxis i number of data axes in the FITS array +C naxes i (array) size of each FITS axis +C fpixel i (array) the first pixel in each dimension to be included +C in the subsection (first pixel = 1) +C lpixel i (array) the last pixel in each dimension to be included +C in the subsection +C array r array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status + real array(*) + integer fpix(7),irange(7),dimen(7),astart,pstart + integer off2,off3,off4,off5,off6,off7 + integer st10,st20,st30,st40,st50,st60,st70 + integer st1,st2,st3,st4,st5,st6,st7 + integer i,i1,i2,i3,i4,i5,i6,i7 + character caxis*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 7)then +C this routine only supports up to 7 dimensions + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSE ' + & //'is illegal.') + return + end if + +C calculate the sizes and number of loops to perform in each dimension + do 10 i=1,7 + fpix(i)=1 + irange(i)=1 + dimen(i)=1 +10 continue + + do 20 i=1,naxis + fpix(i)=fpixel(i) + irange(i)=lpixel(i)-fpixel(i)+1 + dimen(i)=naxes(i) +20 continue + i1=irange(1) + +C compute the pixel offset between each dimension + off2= dimen(1) + off3=off2*dimen(2) + off4=off3*dimen(3) + off5=off4*dimen(4) + off6=off5*dimen(5) + off7=off6*dimen(6) + + st10=fpix(1) + st20=(fpix(2)-1)*off2 + st30=(fpix(3)-1)*off3 + st40=(fpix(4)-1)*off4 + st50=(fpix(5)-1)*off5 + st60=(fpix(6)-1)*off6 + st70=(fpix(7)-1)*off7 + +C store the initial offset in each dimension + st1=st10 + st2=st20 + st3=st30 + st4=st40 + st5=st50 + st6=st60 + st7=st70 + + astart=1 + + do 170 i7=1,irange(7) + do 160 i6=1,irange(6) + do 150 i5=1,irange(5) + do 140 i4=1,irange(4) + do 130 i3=1,irange(3) + pstart=st1+st2+st3+st4+st5+st6+st7 + do 120 i2=1,irange(2) + call ftppre(iunit,group,pstart,i1, + & array(astart),status) + astart=astart+i1 + pstart=pstart+off2 +120 continue + st2=st20 + st3=st3+off3 +130 continue + st3=st30 + st4=st4+off4 +140 continue + st4=st40 + st5=st5+off5 +150 continue + st5=st50 + st6=st6+off6 +160 continue + st6=st60 + st7=st7+off7 +170 continue + end diff --git a/pkg/tbtables/fitsio/ftpssi.f b/pkg/tbtables/fitsio/ftpssi.f new file mode 100644 index 00000000..a1179c94 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpssi.f @@ -0,0 +1,114 @@ +C-------------------------------------------------------------------------- + subroutine ftpssi(iunit,group,naxis,naxes,fpixel,lpixel, + & array,status) + +C Write a subsection of integer*2 values to the primary array. +C A subsection is defined to be any contiguous rectangular +C array of pixels within the n-dimensional FITS data file. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran input unit number +C group i number of the data group to be written, if any +C naxis i number of data axes in the FITS array +C naxes i (array) size of each FITS axis +C fpixel i (array) the first pixel in each dimension to be included +C in the subsection (first pixel = 1) +C lpixel i (array) the last pixel in each dimension to be included +C in the subsection +C array i*2 array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status + integer*2 array(*) + integer fpix(7),irange(7),dimen(7),astart,pstart + integer off2,off3,off4,off5,off6,off7 + integer st10,st20,st30,st40,st50,st60,st70 + integer st1,st2,st3,st4,st5,st6,st7 + integer i,i1,i2,i3,i4,i5,i6,i7 + character caxis*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 7)then +C this routine only supports up to 7 dimensions + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSI ' + & //'is illegal.') + return + end if + +C calculate the sizes and number of loops to perform in each dimension + do 10 i=1,7 + fpix(i)=1 + irange(i)=1 + dimen(i)=1 +10 continue + + do 20 i=1,naxis + fpix(i)=fpixel(i) + irange(i)=lpixel(i)-fpixel(i)+1 + dimen(i)=naxes(i) +20 continue + i1=irange(1) + +C compute the pixel offset between each dimension + off2= dimen(1) + off3=off2*dimen(2) + off4=off3*dimen(3) + off5=off4*dimen(4) + off6=off5*dimen(5) + off7=off6*dimen(6) + + st10=fpix(1) + st20=(fpix(2)-1)*off2 + st30=(fpix(3)-1)*off3 + st40=(fpix(4)-1)*off4 + st50=(fpix(5)-1)*off5 + st60=(fpix(6)-1)*off6 + st70=(fpix(7)-1)*off7 + +C store the initial offset in each dimension + st1=st10 + st2=st20 + st3=st30 + st4=st40 + st5=st50 + st6=st60 + st7=st70 + + astart=1 + + do 170 i7=1,irange(7) + do 160 i6=1,irange(6) + do 150 i5=1,irange(5) + do 140 i4=1,irange(4) + do 130 i3=1,irange(3) + pstart=st1+st2+st3+st4+st5+st6+st7 + do 120 i2=1,irange(2) + call ftppri(iunit,group,pstart,i1, + & array(astart),status) + astart=astart+i1 + pstart=pstart+off2 +120 continue + st2=st20 + st3=st3+off3 +130 continue + st3=st30 + st4=st4+off4 +140 continue + st4=st40 + st5=st5+off5 +150 continue + st5=st50 + st6=st6+off6 +160 continue + st6=st60 + st7=st7+off7 +170 continue + end diff --git a/pkg/tbtables/fitsio/ftpssj.f b/pkg/tbtables/fitsio/ftpssj.f new file mode 100644 index 00000000..3ee5b208 --- /dev/null +++ b/pkg/tbtables/fitsio/ftpssj.f @@ -0,0 +1,114 @@ +C-------------------------------------------------------------------------- + subroutine ftpssj(iunit,group,naxis,naxes,fpixel,lpixel, + & array,status) + +C Write a subsection of integer values to the primary array. +C A subsection is defined to be any contiguous rectangular +C array of pixels within the n-dimensional FITS data file. +C Data conversion and scaling will be performed if necessary +C (e.g, if the datatype of the FITS array is not the same +C as the array being read). + +C iunit i Fortran input unit number +C group i number of the data group to be written, if any +C naxis i number of data axes in the FITS array +C naxes i (array) size of each FITS axis +C fpixel i (array) the first pixel in each dimension to be included +C in the subsection (first pixel = 1) +C lpixel i (array) the last pixel in each dimension to be included +C in the subsection +C array i array of values to be written +C status i returned error stataus + +C written by Wm Pence, HEASARC/GSFC, Feb 1992 + + integer iunit,group,naxis,naxes(*),fpixel(*),lpixel(*),status + integer array(*) + integer fpix(7),irange(7),dimen(7),astart,pstart + integer off2,off3,off4,off5,off6,off7 + integer st10,st20,st30,st40,st50,st60,st70 + integer st1,st2,st3,st4,st5,st6,st7 + integer i,i1,i2,i3,i4,i5,i6,i7 + character caxis*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 7)then +C this routine only supports up to 7 dimensions + status=320 + write(caxis,1001)naxis +1001 format(i20) + call ftpmsg('NAXIS ='//caxis//' in the call to FTPSSJ ' + & //'is illegal.') + return + end if + +C calculate the sizes and number of loops to perform in each dimension + do 10 i=1,7 + fpix(i)=1 + irange(i)=1 + dimen(i)=1 +10 continue + + do 20 i=1,naxis + fpix(i)=fpixel(i) + irange(i)=lpixel(i)-fpixel(i)+1 + dimen(i)=naxes(i) +20 continue + i1=irange(1) + +C compute the pixel offset between each dimension + off2= dimen(1) + off3=off2*dimen(2) + off4=off3*dimen(3) + off5=off4*dimen(4) + off6=off5*dimen(5) + off7=off6*dimen(6) + + st10=fpix(1) + st20=(fpix(2)-1)*off2 + st30=(fpix(3)-1)*off3 + st40=(fpix(4)-1)*off4 + st50=(fpix(5)-1)*off5 + st60=(fpix(6)-1)*off6 + st70=(fpix(7)-1)*off7 + +C store the initial offset in each dimension + st1=st10 + st2=st20 + st3=st30 + st4=st40 + st5=st50 + st6=st60 + st7=st70 + + astart=1 + + do 170 i7=1,irange(7) + do 160 i6=1,irange(6) + do 150 i5=1,irange(5) + do 140 i4=1,irange(4) + do 130 i3=1,irange(3) + pstart=st1+st2+st3+st4+st5+st6+st7 + do 120 i2=1,irange(2) + call ftpprj(iunit,group,pstart,i1, + & array(astart),status) + astart=astart+i1 + pstart=pstart+off2 +120 continue + st2=st20 + st3=st3+off3 +130 continue + st3=st30 + st4=st4+off4 +140 continue + st4=st40 + st5=st5+off5 +150 continue + st5=st50 + st6=st6+off6 +160 continue + st6=st60 + st7=st7+off7 +170 continue + end diff --git a/pkg/tbtables/fitsio/ftpsvc.f b/pkg/tbtables/fitsio/ftpsvc.f new file mode 100644 index 00000000..92e36d3e --- /dev/null +++ b/pkg/tbtables/fitsio/ftpsvc.f @@ -0,0 +1,117 @@ +C-------------------------------------------------------------------------- + subroutine ftpsvc(keyrec,value,comm,status) + +C parse the header record to find value and comment strings + +C keyrec c 80 column header record +C OUTPUT PARAMETERS: +C value c output keyword value string +C comm c output keyword comment string +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + character*80 keyrec,keytmp + character*(*) value,comm + character*80 ctemp + integer status,j,c1 + + if (status .gt. 0)return + + if (keyrec(1:8) .eq.'COMMENT ' .or. keyrec(1:8).eq.'HISTORY ' + & .or. keyrec(1:8).eq.'END ' .or. keyrec(1:8).eq.' ') + & then +C this is a COMMENT or HISTORY record, with no value + value=' ' + comm=keyrec(9:80) + else if (keyrec(9:10) .eq. '= ')then +C this keyword has a value field; now find the first character: + do 10 j=10,80 + if (keyrec(j:j) .ne. ' ')then + c1=j + go to 15 + end if +10 continue +C error: value is blank + status=204 + call ftpmsg('The keyword '//keyrec(1:8)// + & ' has no value string after the equal sign:') + call ftpmsg(keyrec) + return + +15 if (keyrec(c1:c1) .eq. '''')then +C This is a string value. +C Work forward to find a single quote. Two single quotes +C in succession is to be interpreted as a literal single +C quote character as part of the character string, not as +C the end of the character string. Everything to the right +C of the closing quote is assumed to be the comment. +C First, copy input to temporary string variable + keytmp=keyrec + do 20 j=c1+1,80 + if (keytmp(j:j) .eq. '''')then + if (j.lt.80 .and. keytmp(j+1:j+1).eq.'''')then +C found 2 successive quote characters; this is +C interpreted as a literal quote character; remove +C one of the quotes from the string, and continue +C searching for the closing quote character: + keytmp(j+1:80)=keytmp(j+2:80) + else + value=keytmp(c1:j) + if (j .lt. 80)then + ctemp=keytmp(j+1:80) + else + ctemp=' ' + end if + go to 30 + end if + end if +20 continue +C error: no closing quote character + status=205 + call ftpmsg('The following Keyword value string has '// + & 'no closing quote:') + call ftpmsg(keyrec) + return + else +C This is either an integer, floating point, or logical value. +C Extract the first token as the value; remainder = comment + do 25 j=c1,80 + if (keyrec(j:j) .eq. ' ')then + value=keyrec(c1:j-1) + ctemp=keyrec(j+1:80) + go to 30 + end if +25 continue +C the first token went all the way to column 80: + value=keyrec(c1:80) + ctemp=' ' + end if + +30 comm=' ' +C look for first character in the comment string + do 40 j=1,78 + if (ctemp(j:j).ne.' ')then + if (ctemp(j:j).eq.'/')then +C ignore first space, if it exists + if (ctemp(j+1:j+1) .eq. ' ')then + comm=ctemp(j+2:80) + else + comm=ctemp(j+1:80) + end if + else + comm=ctemp(j:80) + end if + go to 50 + end if +40 continue + else +C illegal keyword record format; must have '= ' in columns 9-10 +C status=210 +C Modified July 1993: this is actually not an error. The +C keyword should simply be interpreted as a comment. + value=' ' + comm=keyrec(9:80) + end if +50 continue + end diff --git a/pkg/tbtables/fitsio/ftptbb.f b/pkg/tbtables/fitsio/ftptbb.f new file mode 100644 index 00000000..11b96776 --- /dev/null +++ b/pkg/tbtables/fitsio/ftptbb.f @@ -0,0 +1,64 @@ +C---------------------------------------------------------------------- + subroutine ftptbb(iunit,frow,fchar,nchars,value,status) + +C write a consecutive string of bytes to an ascii or binary +C table. This will span multiple rows of the table if NCHARS+FCHAR is +C greater than the length of a row. + +C iunit i fortran unit number +C frow i starting row number (1st row = 1) +C fchar i starting byte in the row to write (1st character=1) +C nchars i number of bytes to write (can span multiple rows) +C value i array of bytes to write +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Dec 1991 + + integer iunit,frow,fchar,nchars,status + integer value(*) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check for errors + if (nchars .le. 0)then +C zero or negative number of character requested + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + return + else if (fchar .lt. 1)then +C error: illegal starting character + status=308 + return + end if + +C move the i/o pointer to the start of the sequence of characters + bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 + call ftmbyt(iunit,bstart,.true.,status) + +C put the string of bytes + call ftpbyt(iunit,nchars,value,status) + end diff --git a/pkg/tbtables/fitsio/ftptbh.f b/pkg/tbtables/fitsio/ftptbh.f new file mode 100644 index 00000000..6ed2e91b --- /dev/null +++ b/pkg/tbtables/fitsio/ftptbh.f @@ -0,0 +1,12 @@ +C---------------------------------------------------------------------- + subroutine ftptbh(ounit,ncols,nrows,nfield,ttype,tbcol, + & tform,tunit,extnam,status) + +C OBSOLETE routine: should call ftphtb instead + + integer ounit,ncols,nrows,nfield,tbcol(*),status + character*(*) ttype(*),tform(*),tunit(*),extnam + + call ftphtb(ounit,ncols,nrows,nfield,ttype,tbcol, + & tform,tunit,extnam,status) + end diff --git a/pkg/tbtables/fitsio/ftptbs.f b/pkg/tbtables/fitsio/ftptbs.f new file mode 100644 index 00000000..d25fc853 --- /dev/null +++ b/pkg/tbtables/fitsio/ftptbs.f @@ -0,0 +1,64 @@ +C---------------------------------------------------------------------- + subroutine ftptbs(iunit,frow,fchar,nchars,svalue,status) + +C write a consecutive string of characters to an ascii or binary +C table. This will span multiple rows of the table if NCHARS+FCHAR is +C greater than the length of a row. + +C iunit i fortran unit number +C frow i starting row number (1st row = 1) +C fchar i starting character/byte in the row to write (1st character=1) +C nchars i number of characters/bytes to write (can span multiple rows) +C svalue c string of characters to write +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Dec 1991 + + integer iunit,frow,fchar,nchars,status + character*(*) svalue + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,bstart + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C check for errors + if (nchars .le. 0)then +C zero or negative number of character requested + return + else if (frow .lt. 1)then +C error: illegal first row number + status=307 + return + else if (fchar .lt. 1)then +C error: illegal starting character + status=308 + return + end if + +C move the i/o pointer to the start of the sequence of characters + bstart=dtstrt(ibuff)+(frow-1)*rowlen(ibuff)+fchar-1 + call ftmbyt(iunit,bstart,.true.,status) + +C put the string of characters + call ftpcbf(iunit,1,nchars,svalue,status) + end diff --git a/pkg/tbtables/fitsio/ftptdm.f b/pkg/tbtables/fitsio/ftptdm.f new file mode 100644 index 00000000..1b3464d3 --- /dev/null +++ b/pkg/tbtables/fitsio/ftptdm.f @@ -0,0 +1,60 @@ +C---------------------------------------------------------------------- + subroutine ftptdm(iunit,colnum,naxis,naxes,status) + +C write the TDIMnnn keyword describing the dimensionality of a column + +C iunit i fortran unit number to use for reading +C colnum i column number to read +C naxis i number of axes in the data array +C naxes i array giving the length of each data axis +C OUTPUT PARAMETERS: +C status i output error status (0=OK) +C +C written by Wm Pence, HEASARC/GSFC, October 1993 + + integer iunit,colnum,naxis,naxes(*),status + + integer i,j,nextsp + character tdim*120, cval*20 + + if (status .gt. 0)return + + if (naxis .lt. 1 .or. naxis .gt. 100)then +C illegal number of axes + status=320 + return + else if (colnum .lt. 1 .or. colnum .gt. 999)then +C illegal column number + status=302 + return + end if + +C construct the keyword value + tdim='(' + + nextsp=2 + do 100 i=1,naxis + if (naxes(i) .lt. 1)then + status=323 + return + end if + +C convert integer to right justified C*20 string + call fti2c(naxes(i),cval,status) + if (status .gt. 0)return + + do 20 j=20,1,-1 + if (cval(j:j) .eq. ' ')then + tdim(nextsp:)=cval(j+1:20) + nextsp=nextsp+21-j + tdim(nextsp-1:)=',' + go to 100 + end if +20 continue +100 continue + + tdim(nextsp-1:)=')' + + call ftpkns(iunit,'TDIM',colnum,1,tdim, + & 'size of the multidimensional array',status) + end diff --git a/pkg/tbtables/fitsio/ftpthp.f b/pkg/tbtables/fitsio/ftpthp.f new file mode 100644 index 00000000..c6e82bde --- /dev/null +++ b/pkg/tbtables/fitsio/ftpthp.f @@ -0,0 +1,46 @@ +C-------------------------------------------------------------------------- + subroutine ftpthp(ounit,heap,status) + +C Define the starting address for the heap for a binary table. +C The default address is NAXIS1 * NAXIS2. It is in units of +C bytes relative to the beginning of the regular binary table data. +C This subroutine also writes the appropriate THEAP keyword to the +C FITS header. + +C ounit i Fortran I/O unit number +C heap i starting address of the heap +C OUTPUT PARAMETERS: +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, Nov 1991 + + integer ounit,heap,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + ibuff=bufnum(ounit) + theap(ibuff)=heap + +C write the keyword + call ftukyj(ounit,'THEAP',heap,'Byte offset of heap area', + & status) + end diff --git a/pkg/tbtables/fitsio/ftr2e.f b/pkg/tbtables/fitsio/ftr2e.f new file mode 100644 index 00000000..d85cca43 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr2e.f @@ -0,0 +1,36 @@ +C---------------------------------------------------------------------- + subroutine ftr2e(val,dec,cval,status) + +C convert real value to E20.* format character string +C val r input value to be converted +C dec i number of decimal places to display in output string +C cval c output character string +C status i output error status (0 = OK) + + real val + integer dec,status + character*20 cval,form*10 + + if (status .gt. 0)return + + if (dec .ge. 1 .and. dec .le. 9)then + write(form,2000)dec +2000 format('(1pe20.',i1,')') + else if (dec .ge. 10 .and. dec .le. 13)then + write(form,2001)dec +2001 format('(1pe20.',i2,')') + else +C illegal number of decimal places were specified + status=411 + call ftpmsg('Error in FTR2E: number of decimal places ' + & //'is less than 1 or greater than 13.') + return + endif + + write(cval,form,err=900)val + if (cval(1:1) .eq. '*')go to 900 + return + +900 status=402 + call ftpmsg('Error in FTR2E converting real to E20. string.') + end diff --git a/pkg/tbtables/fitsio/ftr2f.f b/pkg/tbtables/fitsio/ftr2f.f new file mode 100644 index 00000000..09e151fd --- /dev/null +++ b/pkg/tbtables/fitsio/ftr2f.f @@ -0,0 +1,34 @@ +C---------------------------------------------------------------------- + subroutine ftr2f(val,dec,cval,status) + +C convert real value to F20.* format character string +C val r input value to be converted +C dec i number of decimal places to display in output string +C cval c output character string +C status i output error status (0 = OK) + + real val + integer dec,status + character*20 cval,form*8 + + if (status .gt. 0)return + + if (dec .ge. 0 .and. dec .le. 9)then + write(form,2000)dec +2000 format('(f20.',i1,')') + else if (dec .ge. 10 .and. dec .lt.18)then + write(form,2001)dec +2001 format('(f20.',i2,')') + else + status=411 + call ftpmsg('Error in FTR2F: number of decimal places ' + & //'is less than 0 or greater than 18.') + return + endif + + write(cval,form,err=900)val + if (cval(1:1) .eq. '*')go to 900 + return +900 status=402 + call ftpmsg('Error in FTR2F converting real to F20. string.') + end diff --git a/pkg/tbtables/fitsio/ftr4i1.f b/pkg/tbtables/fitsio/ftr4i1.f new file mode 100644 index 00000000..6954b9ff --- /dev/null +++ b/pkg/tbtables/fitsio/ftr4i1.f @@ -0,0 +1,154 @@ +C---------------------------------------------------------------------- + subroutine ftr4i1(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*4 values to output i*1 values, doing optional +C scaling and checking for null values + +C input r input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval c*1 value to set array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + real input(*) + character*1 output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + logical fttrnn + external fttrnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +50 continue + else + do 60 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr4i2.f b/pkg/tbtables/fitsio/ftr4i2.f new file mode 100644 index 00000000..937fd658 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr4i2.f @@ -0,0 +1,161 @@ +C---------------------------------------------------------------------- + subroutine ftr4i2(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*4 values to output i*2 values, doing optional +C scaling and checking for null values + +C input r input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval i*2 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i*2 returned array of values +C status i output error status (0 = ok) + + real input(*) + integer*2 output(*),setval,mmini2,mmaxi2 + integer n,i,chktyp,status + double precision scale,zero,dval,i2max,i2min + logical tofits,flgray(*),anynul,noscal + logical fttrnn + parameter (i2max=3.276749D+04) + parameter (i2min=-3.276849D+04) + real mini2,maxi2 + parameter (maxi2=32767.49) + parameter (mini2=-32768.49) + parameter (mmaxi2=32767) + parameter (mmini2=-32768) + external fttrnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*2 range + if (input(i) .le. maxi2 .and. + & input(i) .ge. mini2)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi2)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if + end if +50 continue + else + do 60 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=mmaxi2 + else + status=-11 + output(i)=mmini2 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr4i4.f b/pkg/tbtables/fitsio/ftr4i4.f new file mode 100644 index 00000000..51f4c5a2 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr4i4.f @@ -0,0 +1,165 @@ +C---------------------------------------------------------------------- + subroutine ftr4i4(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*4 values to output i*4 values, doing optional +C scaling and checking for null values + +C input r input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval i value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i returned array of values +C status i output error status (0 = ok) + + real input(*) + integer output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval,i4min,i4max + logical tofits,flgray(*),anynul,noscal + logical fttrnn + parameter (i4max= 2.14748364749D+09) + parameter (i4min=-2.14748364849D+09) + real mini4,maxi4 +C Warning: only have about 7 digits of precision, so don't try +C to set the maxi4 and mini4 limits any closer to the I*4 range. + parameter (maxi4= 2.1474835E+09) + parameter (mini4=-2.1474835E+09) + integer mmaxi4,mmini4 + parameter (mmaxi4=2147483647) + external fttrnn +C work around for bug in the DEC Alpha VMS compiler + mmini4=-2147483647 - 1 + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*4 range + if (input(i) .le. maxi4 .and. + & input(i) .ge. mini4)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi4)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*4 range + if (input(i) .le. maxi4 .and. + & input(i) .ge. mini4)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi4)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*4 range + if (input(i) .le. maxi4 .and. + & input(i) .ge. mini4)then + output(i)=nint(input(i)) + else if (input(i) .gt. maxi4)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if + end if +50 continue + else + do 60 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=mmaxi4 + else + status=-11 + output(i)=mmini4 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr4r4.f b/pkg/tbtables/fitsio/ftr4r4.f new file mode 100644 index 00000000..71950759 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr4r4.f @@ -0,0 +1,93 @@ +C---------------------------------------------------------------------- + subroutine ftr4r4(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*4 values to output r*4 values, doing optional +C scaling and checking for null values + +C input r input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output r returned array of values + + real input(*) + real output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + logical fttrnn + external fttrnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr4r8.f b/pkg/tbtables/fitsio/ftr4r8.f new file mode 100644 index 00000000..adf4f8e6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr4r8.f @@ -0,0 +1,93 @@ +C---------------------------------------------------------------------- + subroutine ftr4r8(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*4 values to output r*8 values, doing optional +C scaling and checking for null values + +C input r input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output d returned array of values + + real input(*) + double precision output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + logical fttrnn + external fttrnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (fttrnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr8i1.f b/pkg/tbtables/fitsio/ftr8i1.f new file mode 100644 index 00000000..10666519 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr8i1.f @@ -0,0 +1,154 @@ +C---------------------------------------------------------------------- + subroutine ftr8i1(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*8 values to output i*1 values, doing optional +C scaling and checking for null values + +C input d input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval c*1 value to set array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output c*1 returned array of values +C status i output error status (0 = ok) + + double precision input(*) + character*1 output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval + logical tofits,flgray(*),anynul,noscal + logical fttdnn + external fttdnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*1 range + if (input(i).lt. 255.49 .and. + & input(i).gt. -.49)then + output(i)=char(nint(input(i))) + else if (input(i) .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +50 continue + else + do 60 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*1 range + if (dval.lt. 255.49 .and. dval.gt. -.49)then + output(i)=char(nint(dval)) + else if (dval .ge. 255.49)then + status=-11 + output(i)=char(255) + else + status=-11 + output(i)=char(0) + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr8i2.f b/pkg/tbtables/fitsio/ftr8i2.f new file mode 100644 index 00000000..529dce48 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr8i2.f @@ -0,0 +1,159 @@ +C---------------------------------------------------------------------- + subroutine ftr8i2(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*8 values to output i*2 values, doing optional +C scaling and checking for null values + +C input d input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval i*2 value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i*2 returned array of values +C status i output error status (0 = ok) + + double precision input(*) + integer*2 output(*),setval,maxi2,mini2 + integer n,i,chktyp,status + double precision scale,zero,dval,i2max,i2min + logical tofits,flgray(*),anynul,noscal + logical fttdnn + parameter (i2max=3.276749D+04) + parameter (i2min=-3.276849D+04) + + parameter (maxi2=32767) + parameter (mini2=-32768) + external fttdnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. i2max .and. + & input(i) .ge. i2min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*2 range + if (input(i) .le. i2max .and. + & input(i) .ge. i2min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*2 range + if (input(i) .le. i2max .and. + & input(i) .ge. i2min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +50 continue + else + do 60 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*2 range + if (dval.lt.i2max .and. dval.gt.i2min)then + output(i)=nint(dval) + else if (dval .ge. i2max)then + status=-11 + output(i)=maxi2 + else + status=-11 + output(i)=mini2 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr8i4.f b/pkg/tbtables/fitsio/ftr8i4.f new file mode 100644 index 00000000..235b15fe --- /dev/null +++ b/pkg/tbtables/fitsio/ftr8i4.f @@ -0,0 +1,160 @@ +C---------------------------------------------------------------------- + subroutine ftr8i4(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*8 values to output i*4 values, doing optional +C scaling and checking for null values + +C input d input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval i value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output i returned array of values +C status i output error status (0 = ok) + + double precision input(*) + integer output(*),setval + integer n,i,chktyp,status + double precision scale,zero,dval,i4min,i4max + logical tofits,flgray(*),anynul,noscal + logical fttdnn + parameter (i4max=2.14748364749D+09) + parameter (i4min=-2.14748364849D+09) + integer maxi4,mini4 + parameter (maxi4=2147483647) + external fttdnn +C work around for bug in the DEC Alpha VMS compiler + mini4=-2147483647 - 1 + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n +C trap any values that overflow the I*4 range + if (input(i) .le. i4max .and. + & input(i) .ge. i4min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +10 continue + else + do 20 i=1,n + dval=(input(i)-zero)/scale +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n +C trap any values that overflow the I*4 range + if (input(i) .le. i4max .and. + & input(i) .ge. i4min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +30 continue + else + do 40 i=1,n + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else +C trap any values that overflow the I*4 range + if (input(i) .le. i4max .and. + & input(i) .ge. i4min)then + output(i)=nint(input(i)) + else if (input(i) .gt. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if + end if +50 continue + else + do 60 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + dval=input(i)*scale+zero +C trap any values that overflow the I*4 range + if (dval.lt.i4max .and. dval.gt.i4min)then + output(i)=nint(dval) + else if (dval .ge. i4max)then + status=-11 + output(i)=maxi4 + else + status=-11 + output(i)=mini4 + end if + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr8r4.f b/pkg/tbtables/fitsio/ftr8r4.f new file mode 100644 index 00000000..f5f2bbbb --- /dev/null +++ b/pkg/tbtables/fitsio/ftr8r4.f @@ -0,0 +1,93 @@ +C---------------------------------------------------------------------- + subroutine ftr8r4(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*8 values to output r*4 values, doing optional +C scaling and checking for null values + +C input d input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval r value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output r returned array of values + + double precision input(*) + real output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + logical fttdnn + external fttdnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftr8r8.f b/pkg/tbtables/fitsio/ftr8r8.f new file mode 100644 index 00000000..36424121 --- /dev/null +++ b/pkg/tbtables/fitsio/ftr8r8.f @@ -0,0 +1,93 @@ +C---------------------------------------------------------------------- + subroutine ftr8r8(input,n,scale,zero,tofits, + & chktyp,setval,flgray,anynul,output,status) + +C copy input r*8 values to output r*8 values, doing optional +C scaling and checking for null values + +C input d input array of values +C n i number of values +C scale d scaling factor to be applied +C zero d scaling zero point to be applied +C tofits l true if converting from internal format to FITS +C chktyp i type of null value checking to be done if TOFITS=.false. +C =0 no checking for null values +C =1 set null values = SETVAL +C =2 set corresponding FLGRAY value = .true. +C setval d value to set output array to if value is undefined +C flgray l array of logicals indicating if corresponding value is null +C anynul l set to true if any nulls were set in the output array +C output d returned array of values + + double precision input(*) + double precision output(*),setval + integer n,i,chktyp,status + double precision scale,zero + logical tofits,flgray(*),anynul,noscal + logical fttdnn + external fttdnn + + if (status .gt. 0)return + + if (scale .eq. 1. .and. zero .eq. 0)then + noscal=.true. + else + noscal=.false. + end if + + if (tofits) then +C we don't have to worry about null values when writing to FITS + if (noscal)then + do 10 i=1,n + output(i)=input(i) +10 continue + else + do 20 i=1,n + output(i)=(input(i)-zero)/scale +20 continue + end if + else +C converting from FITS to internal format; may have to check nulls + if (chktyp .eq. 0)then +C don't have to check for nulls + if (noscal)then + do 30 i=1,n + output(i)=input(i) +30 continue + else + do 40 i=1,n + output(i)=input(i)*scale+zero +40 continue + end if + else +C must test for null values + if (noscal)then + do 50 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i) + end if +50 continue + else + do 60 i=1,n + if (fttdnn(input(i)))then + anynul=.true. + if (chktyp .eq. 1)then + output(i)=setval + else + flgray(i)=.true. + end if + else + output(i)=input(i)*scale+zero + end if +60 continue + end if + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftrdef.f b/pkg/tbtables/fitsio/ftrdef.f new file mode 100644 index 00000000..db200a00 --- /dev/null +++ b/pkg/tbtables/fitsio/ftrdef.f @@ -0,0 +1,41 @@ +C-------------------------------------------------------------------------- + subroutine ftrdef(ounit,status) + +C ReDEFine the structure of a data unit. This routine re-reads +C the CHDU header keywords to determine the structure and length of the +C current data unit. This redefines the start of the next HDU. +C +C ounit i Fortran I/O unit number +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1993 + + integer ounit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,dummy + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C see if we have write access to this file (no need to go on, if not) + if (wrmode(ibuff))then +C rewrite the header END card, and following blank fill + call ftwend(ounit,status) + if (status .gt. 0)return + +C now re-read the required keywords to determine the structure + call ftrhdu(ounit,dummy,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftrhdu.f b/pkg/tbtables/fitsio/ftrhdu.f new file mode 100644 index 00000000..ac8a291b --- /dev/null +++ b/pkg/tbtables/fitsio/ftrhdu.f @@ -0,0 +1,108 @@ +C-------------------------------------------------------------------------- + subroutine ftrhdu(iunit,xtend,status) + +C read the CHDU structure by reading the header keywords which define +C the size and structure of the header and data units. + +C iunit i Fortran I/O unit number +C OUTPUT PARAMETERS: +C xtend i returned type of extension: 0 = the primary HDU +C 1 = an ASCII table +C 2 = a binary table +C -1 = unknown +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer iunit,xtend,status,i,ic,tstat + character keynam*8,exttyp*10,comm*30,keybuf*80 + logical endof + + if (status .gt. 0)return + +C read first keyword to determine the type of the CHDU + call ftgrec(iunit,1,keybuf,status) + + if (status .gt. 0)then + call ftpmsg('Cannot read first keyword in header (FTRHDU)') + return + end if + +C release any current column descriptors for this unit + call ftfrcl(iunit,status) + + keynam=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,exttyp,comm,status) + + if (status .gt. 0)then +C unknown type of FITS record; can't read it + call ftpmsg('Cannot parse value of first keyword; unknown ' + & //'type of FITS record (FTRHDU):') + + else if (keynam .eq. 'SIMPLE')then +C initialize the parameters describing the primay HDU + call ftpini(iunit,status) + xtend=0 + else if (keynam.eq.'XTENSION')then + if (exttyp(1:1) .ne. '''')then +C value of XTENSION is not a quoted character string! + if (keybuf(9:10) .ne. '= ')then + call ftpmsg('XTENSION keyword does not ' + & //'have "= " in cols 9-10.') + else + call ftpmsg('Unknown type of extension; value' + & //' of XTENSION keyword is not a quoted string:') + end if + status=251 + call ftpmsg(keybuf) + else if (exttyp(2:9) .eq. 'TABLE ')then +C initialize the parameters for the ASCII table extension + call ftaini(iunit,status) + xtend=1 + else if (exttyp(2:9) .eq. 'BINTABLE' .or. exttyp(2:9) + & .eq. 'A3DTABLE' .or. exttyp(2:9) .eq. '3DTABLE ')then +C initialize the parameters for the binary table extension + call ftbini(iunit,status) + xtend=2 + else +C try to initialize the parameters describing extension + tstat=status + call ftpini(iunit,status) + xtend=0 + if (status .eq. 251)then +C unknown type of extension + xtend=-1 + status=tstat + end if + end if + else +C unknown record +C If file is created on a VAX with 512-byte records, then +C the FITS file may have fill bytes (ASCII NULs) at the end. +C Also, if file has been editted on a SUN, an extra ASCII 10 +C character may appear at the end of the file. Finally, if +C file is not a multiple of the record length long, then +C the last truncated record may be filled with ASCII blanks. +C So, if the record only contains NULS, LF, and blanks, then +C assume we found the end of file. Otherwise report an error. + + endof=.true. + do 10 i=1,80 + ic=ichar(keybuf(i:i)) + if (ic .ne. 0 .and .ic .ne. 10 .and. ic .ne. 32) + & endof=.false. +10 continue + if (endof)then + status=107 + call ftpmsg('ASCII 0s, 10s, or 32s at start of ' + & //'extension are treated as EOF (FTRHDU):') + else + status=252 + call ftpmsg('Extension does not start with SIMPLE' + & //' or XTENSION keyword (FTRHDU):') + end if + xtend=-1 + call ftpmsg(keybuf) + end if + end diff --git a/pkg/tbtables/fitsio/ftrsnm.f b/pkg/tbtables/fitsio/ftrsnm.f new file mode 100644 index 00000000..f9f4eb38 --- /dev/null +++ b/pkg/tbtables/fitsio/ftrsnm.f @@ -0,0 +1,15 @@ +C-------------------------------------------------------------------------- + subroutine ftrsnm + +C simply reset the column names as undefined +C this will force ftgcnn to read the column names from the +C file the next time it is called + +C written by Wm Pence, HEASARC/GSFC, Feb 1995 + + integer colpnt,untpnt + common/ftname/colpnt,untpnt + + colpnt= -999 + untpnt=0 + end diff --git a/pkg/tbtables/fitsio/ftrwdn.f b/pkg/tbtables/fitsio/ftrwdn.f new file mode 100644 index 00000000..86bb17f4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftrwdn.f @@ -0,0 +1,183 @@ +C-------------------------------------------------------------------------- + subroutine ftrwdn(iunit,frow,lrow,nshift,status) + +C shift rows in a table down by NROWS rows, inserting blank rows + +C iunit i Fortran I/O unit number +C frow i rows *AFTER* this one are to be moved down +C lrow i last row to be moved down (last row of the table) +C nshift i how far to shift the rows +C status i returned error status (0=ok) + + integer iunit,frow,lrow,nshift,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(2880,2) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,kshift,nchar,fchar,in,out,i,j,irow,tin,jrow + integer lstptr,inptr,outptr,nseg + character cfill*1 + + if (status .gt. 0)return + +C don't have to do anything if inserting blank rows at end of the table + if (frow .eq. lrow)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C select appropriate fill value + if (hdutyp(ibuff) .eq. 1)then +C fill header or ASCII table with space + cfill=char(32) + else +C fill image or bintable data area with Null (0) + cfill=char(0) + end if + +C how many rows will fit in the single buffer? + kshift=2880/rowlen(ibuff) + +C ********************************************************************** +C CASE #1: optimal case where the NSHIFT number of rows will all +C fit in the 2880-byte work buffer simultaneously. The rows can +C be shifted down in one efficient pass through the table. +C ********************************************************************** + if (kshift .ge. nshift)then + + kshift=nshift + nchar=kshift*rowlen(ibuff) + fchar=1 + +C initialize the first buffer + in=2 + out=1 + + do 5 i=1,2880 + buff(i,1)=cfill +5 continue + + do 10 irow=frow+1,lrow,kshift + +C read the row(s) to be shifted + call ftgtbs(iunit,irow,fchar,nchar,buff(1,in),status) + +C overwrite these row(s) with the previous row(s) + call ftptbs(iunit,irow,fchar,nchar,buff(1,out),status) + +C swap the input and output buffer pointers and move to next rows + tin=in + in=out + out=tin + jrow=irow +10 continue + +C write the last row(s) out + irow=jrow+kshift + nchar=(lrow-jrow+1)*rowlen(ibuff) + + call ftptbs(iunit,irow,fchar,nchar,buff(1,out),status) + return + +C ********************************************************************** +C CASE #2: One or more rows of the table will fit in the work buffer, +C but cannot fit all NSHIFT rows in the buffer at once. Note that +C since we do not need 2 buffers, as in the previous case, we can +C combine both buffers into one single 2880*2 byte buffer, to handle +C wider tables. This algorithm copies then moves blocks of contiguous +C rows at one time, working upwards from the bottom of the table. +C ********************************************************************** + else if (rowlen(ibuff) .le. 5760)then + +C how many rows can we move at one time? + kshift=5760/rowlen(ibuff) + fchar=1 + +C initialize pointers + lstptr=lrow + inptr=lrow-kshift+1 + +20 if (inptr .le. frow)inptr=frow+1 + nchar=(lstptr-inptr+1)*rowlen(ibuff) + outptr=inptr+nshift + +C read the row(s) to be shifted + call ftgtbs(iunit,inptr,fchar,nchar,buff,status) + +C write the row(s) to the new location + call ftptbs(iunit,outptr,fchar,nchar,buff,status) + +C If there are more rows, update pointers and repeat + if (inptr .gt. frow+1)then + lstptr=lstptr-kshift + inptr =inptr -kshift + go to 20 + end if + +C initialize the buffer with the fill value + do 25 i=1,2880 + buff(i,1)=cfill + buff(i,2)=cfill +25 continue + +C fill the empty rows with blanks or nulls + nchar=rowlen(ibuff) + do 30 i=1,nshift + outptr=frow+i + call ftptbs(iunit,outptr,fchar,nchar,buff,status) +30 continue + return + +C ********************************************************************** +C CASE #3: Cannot fit a whole row into the work buffer, so have +C to move each row in pieces. +C ********************************************************************** + else + + nseg=(rowlen(ibuff)+5759)/5760 + nchar=5760 + + do 60 j=1,nseg + fchar=(j-1)*5760+1 + if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760 + + do 40 i=lrow,frow+1,-1 +C read the row to be shifted + call ftgtbs(iunit,i,fchar,nchar,buff,status) + +C write the row(s) to the new location + call ftptbs(iunit,i+nshift,fchar,nchar,buff,status) +40 continue + +C initialize the buffer with the fill value + do 45 i=1,2880 + buff(i,1)=cfill + buff(i,2)=cfill +45 continue + +C fill the empty rows with blanks or nulls + do 50 i=1,nshift + outptr=frow+i + call ftptbs(iunit,outptr,fchar,nchar,buff,status) +50 continue +60 continue + + end if + end diff --git a/pkg/tbtables/fitsio/ftrwup.f b/pkg/tbtables/fitsio/ftrwup.f new file mode 100644 index 00000000..9239ead0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftrwup.f @@ -0,0 +1,136 @@ +C-------------------------------------------------------------------------- + subroutine ftrwup(iunit,frow,lrow,nshift,status) + +C shift rows in a table up by NROWS rows, overwriting the rows above + +C iunit i Fortran I/O unit number +C frow i first row to be moved up +C lrow i last row to be moved up (last row of the table) +C nshift i how far to shift the rows (number of rows) +C status i returned error status (0=ok) + + integer iunit,frow,lrow,nshift,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nb = 20) + parameter (nf = 3000) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character*1 buff(5760) + common/ftheap/buff +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,kshift,nchar,fchar,i,j + integer lstptr,inptr,outptr,nseg + character cfill*1 + + if (status .gt. 0)return + +C define the number of the buffer used for this file + ibuff=bufnum(iunit) + +C select appropriate fill value + if (hdutyp(ibuff) .eq. 1)then +C fill header or ASCII table with space + cfill=char(32) + else +C fill image or bintable data area with Null (0) + cfill=char(0) + end if + +C ********************************************************************** +C CASE #1: One or more rows of the table will fit in the work buffer, +C ********************************************************************** + if (rowlen(ibuff) .le. 5760)then + +C how many rows can we move at one time? + kshift=5760/rowlen(ibuff) + fchar=1 + +C check if we just need to clear the last NSHIFT rows of the table + if (frow .eq. lrow+1)go to 25 + +C initialize pointers + inptr=frow + lstptr=inptr+kshift + +20 if (lstptr .gt. lrow)lstptr=lrow + nchar=(lstptr-inptr+1)*rowlen(ibuff) + outptr=inptr-nshift + +C read the row(s) to be shifted + call ftgtbs(iunit,inptr,fchar,nchar,buff,status) + +C write the row(s) to the new location + call ftptbs(iunit,outptr,fchar,nchar,buff,status) + +C If there are more rows, update pointers and repeat + if (lstptr .lt. lrow)then + inptr =inptr +kshift + lstptr=lstptr+kshift + go to 20 + end if + +C initialize the buffer with the fill value +25 continue + do 30 i=1,5760 + buff(i)=cfill +30 continue + +C fill the empty rows at the bottom of the table with blanks or nulls + nchar=rowlen(ibuff) + do 35 i=1,nshift + outptr=lrow-nshift+i + call ftptbs(iunit,outptr,fchar,nchar,buff,status) +35 continue + return + +C ********************************************************************** +C CASE #2: Cannot fit a whole row into the work buffer, so have +C to move each row in pieces. +C ********************************************************************** + else + + nseg=(rowlen(ibuff)+5759)/5760 + nchar=5760 + + do 60 j=1,nseg + fchar=(j-1)*5760+1 + if (j .eq. nseg)nchar=rowlen(ibuff)-(nseg-1)*5760 + +C check if we just need to clear the last NSHIFT rows of the table + if (frow .eq. lrow+1)go to 45 + + do 40 i=frow,lrow +C read the row to be shifted + call ftgtbs(iunit,i,fchar,nchar,buff,status) + +C write the row(s) to the new location + call ftptbs(iunit,i-nshift,fchar,nchar,buff,status) +40 continue + +C initialize the buffer with the fill value +45 continue + do 50 i=1,5760 + buff(i)=cfill +50 continue + +C fill the empty rows with blanks or nulls + do 55 i=1,nshift + outptr=lrow-nshift+i + call ftptbs(iunit,outptr,fchar,nchar,buff,status) +55 continue +60 continue + end if + end diff --git a/pkg/tbtables/fitsio/fts2c.f b/pkg/tbtables/fitsio/fts2c.f new file mode 100644 index 00000000..2bceee6b --- /dev/null +++ b/pkg/tbtables/fitsio/fts2c.f @@ -0,0 +1,57 @@ +C---------------------------------------------------------------------- + subroutine fts2c(in,cval,lenval,status) +C convert an input string to a left justified quoted string +C The minimum length FITS string is 8 characters, so +C pad the quoted string with spaces if necessary. +C cval = returned quoted string +C lenval = length of the cval string, including the 2 quote characters + character*(*) in,cval + integer length,i,j,i1,i2,lenval,status + + if (status .gt. 0)return + + i1=1 + i2=1 +C test for blank input string + if (in .eq. ' ')then + cval=''' ''' + lenval=10 + return + end if + + length=len(in) +C find first and last non-blank characters + +C modified 29 Nov 1994 to treat leading spaces as significant +C do 5 i=1,length +C i1=i +C if (in(i:i) .ne. ' ')go to 10 +C5 continue +C10 continue + + do 15 i=length,1,-1 + i2=i + if (in(i:i) .ne. ' ')go to 20 +15 continue +20 continue + + cval=''''//in(i1:i2) + +C test if there are any single quotes in the string; if so, replace +C them with two successive single quotes + lenval=i2-i1+2 + do 30 i=lenval,2,-1 + if (cval(i:i) .eq. '''')then +C shift all the characters over 1 space + do 40 j=len(cval),i+1,-1 + cval(j:j)=cval(j-1:j-1) +40 continue + i2=i2+1 + end if +30 continue + +C find location of closing quote + lenval=max(10,i2-i1+3) + lenval=min(lenval,len(cval)) + cval(lenval:lenval)='''' + end diff --git a/pkg/tbtables/fitsio/ftsdnn.f b/pkg/tbtables/fitsio/ftsdnn.f new file mode 100644 index 00000000..9bd41107 --- /dev/null +++ b/pkg/tbtables/fitsio/ftsdnn.f @@ -0,0 +1,15 @@ +C---------------------------------------------------------------------- + subroutine ftsdnn(value) + +C set a 64-bit pattern equal to an IEEE Not-a-Number value +C A NaN has all the exponent bits=1, and the fractional part +C not=0. +C +C written by Wm Pence, HEASARC/GSFC, February 1991 + + integer value(2) + +C there are many NaN values; choose a simple one in which all bits=1 + value(1)=-1 + value(2)=-1 + end diff --git a/pkg/tbtables/fitsio/ftsnul.f b/pkg/tbtables/fitsio/ftsnul.f new file mode 100644 index 00000000..6ef34ecb --- /dev/null +++ b/pkg/tbtables/fitsio/ftsnul.f @@ -0,0 +1,59 @@ +C-------------------------------------------------------------------------- + subroutine ftsnul(ounit,colnum,nulval,status) + +C ascii table Column NULl value definition +C Define the null value for an ASCII table column. +C +C ounit i Fortran I/O unit number +C colnum i number of the column to be defined +C nulval c the string to be use to signify undefined data +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,status + character*(*) nulval + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) + character cnull*16, cform*8 + common/ft0003/cnull(nf),cform(nf) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + if (status .gt. 0)return + +C test for proper HDU type + if (hdutyp(ibuff) .ne. 1)then + status=226 + return + end if + + if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then + status=302 + return + end if + + cnull(colnum+tstart(ibuff))=nulval + end diff --git a/pkg/tbtables/fitsio/ftsrnn.f b/pkg/tbtables/fitsio/ftsrnn.f new file mode 100644 index 00000000..5ba489bc --- /dev/null +++ b/pkg/tbtables/fitsio/ftsrnn.f @@ -0,0 +1,14 @@ +C---------------------------------------------------------------------- + subroutine ftsrnn(value) + +C set a 32-bit pattern equal to an IEEE Not-a-Number value +C A NaN has all the exponent bits=1, and the fractional part +C not=0. +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer value + +C there are many NaN values; choose a simple one in which all bits=1 + value=-1 + end diff --git a/pkg/tbtables/fitsio/fttbit.f b/pkg/tbtables/fitsio/fttbit.f new file mode 100644 index 00000000..3733f100 --- /dev/null +++ b/pkg/tbtables/fitsio/fttbit.f @@ -0,0 +1,18 @@ +C---------------------------------------------------------------------- + subroutine fttbit(bitpix,status) + +C test that bitpix has a legal value + + integer bitpix,status + character value*20 + + if (status .gt. 0)return + + if (bitpix .ne. 8 .and. bitpix .ne. 16 .and. bitpix .ne. 32 + & .and. bitpix .ne. -32 .and. bitpix .ne. -64)then + status=211 + write(value,1000)bitpix +1000 format(i20) + call ftpmsg('Illegal BITPIX value: '//value) + end if + end diff --git a/pkg/tbtables/fitsio/fttdnn.f b/pkg/tbtables/fitsio/fttdnn.f new file mode 100644 index 00000000..287d32ea --- /dev/null +++ b/pkg/tbtables/fitsio/fttdnn.f @@ -0,0 +1,96 @@ +C---------------------------------------------------------------------- + logical function fttdnn(value) + +C test if a R*8 value has a IEEE Not-a-Number value +C A NaN has all the exponent bits=1, and the fractional part +C not=0. +C Exponent field is in bits 20-30 in the most significant 4-byte word +C Mantissa field is in bits 0-19 of most sig. word and entire 2nd word +C +C written by Wm Pence, HEASARC/GSFC, May 1992 +C modified Aug 1994 to handle all IEEE special values. + + integer value(2) + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer compid + common/ftcpid/compid +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer word1,word2 + +C COMPID specifies what type of floating point word structure +C is used on this machine, and determines how to test for NaNs. + +C COMPID value: +C 1 generic machine: simply test for NaNs with all bits set +C 2 like a decstation or alpha OSF/1, or IBM PC +C 3 SUN workstation, or IBM mainframe +C -2305843009213693952 Cray (64-bit) machine + + fttdnn=.false. + return + + if (compid .eq. 1)then +C on the VAX we can assume that all NaNs will be set to all bits on +C (which is equivalent to an integer with a value of -1) because +C this is what the IEEE to VAX conversion MACRO program returns + if (value(1) .eq. -1 .and. value(2) .eq. -1)fttdnn=.true. + + else if (compid .gt. 1)then + if (compid .ge. 3)then +C this is for SUN-like machines, or IBM main frames + word1=value(1) + word2=value(2) + else +C this is for DECstation and IBM PCs. The 2 32 bit integer words +C are reversed from what you get on the SUN. + word1=value(2) + word2=value(1) + end if + +C efficiently search the number space for NaNs and underflows + if (word2 .eq. -1)then + if ((word1 .ge. -1048577 .and. word1 .le. -1) + & .or. (word1 .ge. 2146435071))then + fttdnn=.true. + else if ((word1 .lt. -2146435072) .or. + & (word1 .ge. 0 .and. word1 .lt. 1048576))then + value(1)=0 + value(2)=0 + end if + else if (word2 .eq. 0)then + if ((word1 .gt. -1048577 .and. word1 .le. -1) + & .or. (word1 .gt. 2146435071))then + fttdnn=.true. + else if ((word1 .le. -2146435072) .or. + & (word1 .ge. 0 .and. word1 .le. 1048576))then + value(1)=0 + value(2)=0 + end if + else + if ((word1 .gt. -1048577 .and. word1 .le. -1) + & .or. (word1 .gt. 2146435071))then + fttdnn=.true. + else if ((word1 .lt. -2146435072) .or. + & (word1 .ge. 0 .and. word1 .lt. 1048576))then + value(1)=0 + value(2)=0 + end if + end if + else +C branch for the Cray: COMPID stores the negative integer +C which corresponds to the 3 most sig digits set to 1. If these +C 3 bits are set in a floating point number, then it represents +C a reserved value (i.e., a NaN) + if (value(1).lt. 0 .and. value(1) .ge. compid)fttdnn=.true. + end if + end diff --git a/pkg/tbtables/fitsio/fttkey.f b/pkg/tbtables/fitsio/fttkey.f new file mode 100644 index 00000000..048510df --- /dev/null +++ b/pkg/tbtables/fitsio/fttkey.f @@ -0,0 +1,50 @@ +C---------------------------------------------------------------------- + subroutine fttkey(keynam,status) + +C test that keyword name contains only legal characters: +C uppercase letters, numbers, hyphen, underscore, or space +C (but no embedded spaces) + +C keynam c*8 keyword name +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) + + character keynam*(*) + integer status,i + character*1 c1,pos + logical spaces + + if (status .gt. 0)return + + spaces=.false. + do 20 i=1,8 + c1=keynam(i:i) + if ((c1 .ge. 'A' .and. c1 .le. 'Z') .or. + & (c1 .ge. '0' .and. c1 .le. '9') .or. + & c1 .eq. '-' .or. c1 .eq. '_')then + if (spaces)then +C error: name contains embedded space + status=207 + call ftpmsg('Keyword name contains embedded '// + & 'space(s): '//keynam(1:8)) + return + end if + else if (c1 .eq. ' ')then + spaces=.true. + else +C illegal character found + status=207 + write(pos,1000)i +1000 format(i1) + call ftpmsg('Character '//pos//' in this keyword name' + & //' is illegal: "'//keynam(1:8)//'"') +C explicitly test for the 2 most common cases: + if (ichar(c1) .eq. 0)then + call ftpmsg('(This is an ASCII NUL (0) character).') + else if (ichar(c1) .eq. 9)then + call ftpmsg('(This is an ASCII TAB (9) character).') + end if + return + end if +20 continue + end diff --git a/pkg/tbtables/fitsio/fttkyn.f b/pkg/tbtables/fitsio/fttkyn.f new file mode 100644 index 00000000..967f6cbc --- /dev/null +++ b/pkg/tbtables/fitsio/fttkyn.f @@ -0,0 +1,65 @@ +C-------------------------------------------------------------------------- + subroutine fttkyn(iunit,nkey,keynam,keyval,status) + +C test that the keyword number NKEY has name = KEYNAM +C and has value = KEYVAL +C +C iunit i Fortran I/O unit number +C nkey i sequence number of the keyword to test +C keynam c name that the keyword is supposed to have +C keyval c value that the keyword is supposed to have +C OUTPUT PARAMETERS: +C status i returned error status (0=ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 +C + integer iunit,nkey,status + character*(*) keynam,keyval + character kname*8,value*30,comm*48,npos*8,keybuf*80 + character errmsg*80 + + if (status .gt. 0)return + +C read the name and value of the keyword + +C get the whole record + call ftgrec(iunit,nkey,keybuf,status) + + kname=keybuf(1:8) +C parse the value and comment fields from the record + call ftpsvc(keybuf,value,comm,status) + if (status .gt. 0)go to 900 + +C test if the keyword has the correct name + if (kname .ne. keynam)then + status=208 + go to 900 + end if + +C check that the keyword has the correct value + if (value .ne. keyval)then + status=209 + end if + +900 continue + if (status .gt. 0)then + + write(npos,1000)nkey +1000 format(i8) + errmsg='FTTKYN found unexpected keyword or value '// + & 'for header keyword number '//npos//'.' + call ftpmsg(errmsg) + errmsg=' Was expecting keyword '//keynam// + & ' with value = '//keyval + call ftpmsg(errmsg) + if (keybuf(9:10) .ne. '= ')then + errmsg=' but found keyword '//kname// + & ' with no "= " in cols. 9-10.' + else + errmsg=' but found keyword '//kname// + & ' with value = '//value + end if + call ftpmsg(errmsg) + call ftpmsg(keybuf) + end if + end diff --git a/pkg/tbtables/fitsio/fttnul.f b/pkg/tbtables/fitsio/fttnul.f new file mode 100644 index 00000000..a1fa6be9 --- /dev/null +++ b/pkg/tbtables/fitsio/fttnul.f @@ -0,0 +1,56 @@ +C-------------------------------------------------------------------------- + subroutine fttnul(ounit,colnum,inull,status) + +C Table column NULl value definition +C Define the null value for a table column +C +C ounit i Fortran I/O unit number +C colnum i number of the column to be defined +C inull i the value to be use to signify undefined data +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,inull,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + if (status .gt. 0)return + +C test for proper HDU type + if (hdutyp(ibuff) .eq. 0)then + status=235 + return + end if + + if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then + status=302 + return + end if + + tnull(colnum+tstart(ibuff))=inull + end diff --git a/pkg/tbtables/fitsio/fttrec.f b/pkg/tbtables/fitsio/fttrec.f new file mode 100644 index 00000000..e7376891 --- /dev/null +++ b/pkg/tbtables/fitsio/fttrec.f @@ -0,0 +1,44 @@ +C---------------------------------------------------------------------- + subroutine fttrec(string,status) + +C test the remaining characters in a header record to insure that +C it contains only pri-ntable ASCII characters, +C i.e., with ASCII codes greater than or equal to 32 (a blank) +C Note: this will not detect the delete character (ASCII 127) +C because of the difficulties in also supporting this check +C on IBM mainframes, where the collating sequence is entirely +C different. + +C string c*72 keyword name +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) + +C optimized in 7/93 to compare "ichar(string(i:i)) .lt. space" +C rather than "(string(i:i)) .lt. ' ' " +C This is much faster on SUNs and DECstations, +C and decreases the time needed to write a keywor (ftprec) by 10%. +C This change made no difference on a VAX + + integer space +C The following line won't compile with the Lahey compiler on a PC +C parameter(space = ichar(' ')) + character string*(*) + integer status,i + character pos*2 + + if (status .gt. 0)return + space=ichar(' ') + + do 20 i=1,72 + if (ichar(string(i:i)) .lt. space)then +C illegal character found + status=207 + write(pos,1000)i +1000 format(i2) + call ftpmsg('Character #'//pos//' in this keyword value or '// + & 'comment string is illegal:') + call ftpmsg(string) + return + end if +20 continue + end diff --git a/pkg/tbtables/fitsio/fttrnn.f b/pkg/tbtables/fitsio/fttrnn.f new file mode 100644 index 00000000..56338a36 --- /dev/null +++ b/pkg/tbtables/fitsio/fttrnn.f @@ -0,0 +1,65 @@ +C---------------------------------------------------------------------- + logical function fttrnn(value) + +C test if a R*4 value has a IEEE Not-a-Number (NaN) value +C A NaN has all the exponent bits=1, and the fractional part not=0. +C The exponent field occupies bits 23-30, (least significant bit = 0) +C The mantissa field occupies bits 0-22 + +C This routine also sets any underflow values to zero. + +C written by Wm Pence, HEASARC/GSFC, May 1992 +C modified Aug 1994 to handle all IEEE special values. + + integer value + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer compid + common/ftcpid/compid +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + +C COMPID specifies what type of floating point word structure +C is used on this machine, and determines how to test for NaNs. + +C COMPID value: +C 1 VAX or generic machine: simply test for NaNs with all bits set +C 2 like a decstation or alpha OSF/1, or IBM PC +C 3 SUN workstation, or IBM mainframe +C -2305843009213693952 Cray (64-bit) machine + + fttrnn=.false. + return + + if (compid .eq. 1)then +C on the VAX we can assume that all NaNs will be set to all bits on +C (which is equivalent to an integer with a value of -1) because +C this is what the IEEE to VAX conversion MACRO program returns + if (value .eq. -1)fttrnn=.true. + else if (compid .gt. 1)then +C the following test works on all other machines (except Cray) +C the sign bit may be either 1 or 0 so have to test both possibilites. +C Note: overflows and infinities are also flagged as NaNs. + if (value .ge. 2139095039 .or. (value .lt. 0 .and. + 1 value .ge. -8388609))then + fttrnn=.true. + else if ((value .gt. 0 .and. value .le. 8388608) .or. + 1 value .le. -2139095040)then +C set underflows and denormalized values to zero + value=0 + end if + else +C branch for the Cray: COMPID stores the negative integer +C which corresponds to the 3 most sig digits set to 1. If these +C 3 bits are set in a floating point number, then it represents +C a reserved value (i.e., a NaN) + if (value .lt. 0 .and. value .ge. compid)fttrnn=.true. + end if + end diff --git a/pkg/tbtables/fitsio/fttscl.f b/pkg/tbtables/fitsio/fttscl.f new file mode 100644 index 00000000..8a12b43c --- /dev/null +++ b/pkg/tbtables/fitsio/fttscl.f @@ -0,0 +1,65 @@ +C-------------------------------------------------------------------------- + subroutine fttscl(ounit,colnum,bscale,bzero,status) + +C Table column SCaLing factor definition +C Define the scaling factor for a table column. +C +C ounit i Fortran I/O unit number +C colnum i number of the column to be defined +C bscale d scaling factor +C bzero d scaling zero point +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, June 1991 + + integer ounit,colnum,status + double precision bscale,bzero + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne,nf + parameter (nb = 20) + parameter (ne = 200) + parameter (nf = 3000) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff + + if (status .gt. 0)return + + if (bscale .eq. 0.)then +C illegal bscale value + status=322 + return + end if + + ibuff=bufnum(ounit) + +C if HDU structure is not defined then scan the header keywords + if (dtstrt(ibuff) .lt. 0)call ftrdef(ounit,status) + if (status .gt. 0)return + +C test for proper HDU type + if (hdutyp(ibuff) .eq. 0)then + status=235 + return + end if + + if (colnum .gt. tfield(ibuff) .or. colnum .lt. 1)then + status=302 + return + end if + + tscale(colnum+tstart(ibuff))=bscale + tzero(colnum+tstart(ibuff))=bzero + end diff --git a/pkg/tbtables/fitsio/ftucks.f b/pkg/tbtables/fitsio/ftucks.f new file mode 100644 index 00000000..71c3aba0 --- /dev/null +++ b/pkg/tbtables/fitsio/ftucks.f @@ -0,0 +1,124 @@ +C---------------------------------------------------------------------- + subroutine ftucks(iunit,status) + +C Update the CHECKSUM keyword value. This assumes that the DATASUM +C keyword exists and has the correct value. + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, May, 1995 + + integer iunit,status + +C-------COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nf,nb,ne + parameter (nf = 3000) + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld + integer tfield,tstart,tbcol,rowlen,tdtype,trept,tnull,scount + integer theap,nxheap + double precision tscale,tzero + common/ft0002/tfield(nb),tstart(nb),tbcol(nf),rowlen(nb), + & tdtype(nf),trept(nf),tscale(nf),tzero(nf),tnull(nf),scount(nb) + & ,theap(nb),nxheap(nb) +C-------END OF COMMON BLOCK DEFINITIONS----------------------------------- + + double precision sum,dsum + integer ibuff,nrec,dd,mm,yy,i,tstat + character datstr*8,string*16,comm*40,datsum*20,oldcks*16 + logical complm + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C get the DATASUM keyword value + call ftgkys(iunit,'DATASUM',datsum,comm,status) + if (status .eq. 202)then + call ftpmsg('DATASUM keyword not found (FTUCKS)') + return + end if + +C decode the datasum string into a double precision variable + do 10 i=1,20 + if (datsum(i:i) .ne. ' ')then + call ftc2dd(datsum(i:20),dsum,status) + go to 15 + end if +10 continue + dsum=0. + +C generate current date string to put into the keyword comment +15 call ftgsdt(dd,mm,yy,status) + if (status .gt. 0)return + + datstr=' / / ' + write(datstr(1:2),1001)dd + write(datstr(4:5),1001)mm + write(datstr(7:8),1001)yy +1001 format(i2) + +C replace blank with leading 0 in each field if required + if (datstr(1:1) .eq. ' ')datstr(1:1)='0' + if (datstr(4:4) .eq. ' ')datstr(4:4)='0' + if (datstr(7:7) .eq. ' ')datstr(7:7)='0' + +C get the CHECKSUM keyword value if it exists + tstat=status + call ftgkys(iunit,'CHECKSUM',oldcks,comm,status) + if (status .eq. 202)then + status=tstat + oldcks='0000000000000000' + comm='encoded HDU checksum updated on '//datstr + call ftpkys(iunit,'CHECKSUM','0000000000000000',comm,status) + end if + +C rewrite the header END card, and following blank fill + call ftwend(iunit,status) + if (status .gt. 0)return + +C move to the start of the header + call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) + +C accumulate the header checksum into the previous data checksum + nrec= (dtstrt(ibuff)-hdstrt(ibuff,chdu(ibuff)))/2880 + sum=dsum + call ftcsum(iunit,nrec,sum,status) + +C encode the COMPLEMENT of the checksum into a 16-character string + complm=.true. + call ftesum(sum,complm,string) + +C return if the checksum is correct + if (string .eq. '0000000000000000')return + + if (oldcks .eq. '0000000000000000')then +C update the CHECKSUM keyword value with the checksum string + call ftmkys(iunit,'CHECKSUM',string,'&',status) + else + +C Zero the checksum and compute the new value + comm='encoded HDU checksum updated on '//datstr + call ftmkys(iunit,'CHECKSUM','0000000000000000',comm,status) + +C move to the start of the header + call ftmbyt(iunit,hdstrt(ibuff,chdu(ibuff)),.true.,status) + +C accumulate the header checksum into the previous data checksum + sum=dsum + call ftcsum(iunit,nrec,sum,status) + +C encode the COMPLEMENT of the checksum into a 16-character string + complm=.true. + call ftesum(sum,complm,string) + +C update the CHECKSUM keyword value with the checksum string + call ftmkys(iunit,'CHECKSUM',string,'&',status) + end if + end diff --git a/pkg/tbtables/fitsio/ftucrd.f b/pkg/tbtables/fitsio/ftucrd.f new file mode 100644 index 00000000..5f525c42 --- /dev/null +++ b/pkg/tbtables/fitsio/ftucrd.f @@ -0,0 +1,28 @@ +C-------------------------------------------------------------------------- + subroutine ftucrd(ounit,keywrd,card,status) + +C update a 80-character FITS header card/record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C card c 80-character FITS card image +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, May 1995 + + character*(*) keywrd,card + integer ounit,status,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the card, if it exists + call ftmcrd(ounit,keywrd,card,status) + + if (status .eq. 202)then +C card doesn't exist, so create it + status=tstat + call ftprec(ounit,card,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukyd.f b/pkg/tbtables/fitsio/ftukyd.f new file mode 100644 index 00000000..b9a8558d --- /dev/null +++ b/pkg/tbtables/fitsio/ftukyd.f @@ -0,0 +1,31 @@ +C-------------------------------------------------------------------------- + subroutine ftukyd(ounit,keywrd,dval,decim,comm,status) + +C update a double precision value header record in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (max. 47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkyd(ounit,keywrd,dval,decim,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkyd(ounit,keywrd,dval,decim,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukye.f b/pkg/tbtables/fitsio/ftukye.f new file mode 100644 index 00000000..f2296597 --- /dev/null +++ b/pkg/tbtables/fitsio/ftukye.f @@ -0,0 +1,31 @@ +C-------------------------------------------------------------------------- + subroutine ftukye(ounit,keywrd,rval,decim,comm,status) + +C update a real*4 value header record in E format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkye(ounit,keywrd,rval,decim,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkye(ounit,keywrd,rval,decim,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukyf.f b/pkg/tbtables/fitsio/ftukyf.f new file mode 100644 index 00000000..ed9acf83 --- /dev/null +++ b/pkg/tbtables/fitsio/ftukyf.f @@ -0,0 +1,31 @@ +C-------------------------------------------------------------------------- + subroutine ftukyf(ounit,keywrd,rval,decim,comm,status) + +C update a real*4 value header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C rval r keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + real rval + integer ounit,status,decim,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkyf(ounit,keywrd,rval,decim,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkyf(ounit,keywrd,rval,decim,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukyg.f b/pkg/tbtables/fitsio/ftukyg.f new file mode 100644 index 00000000..a0d01680 --- /dev/null +++ b/pkg/tbtables/fitsio/ftukyg.f @@ -0,0 +1,31 @@ +C-------------------------------------------------------------------------- + subroutine ftukyg(ounit,keywrd,dval,decim,comm,status) + +C update a double precision value header record in F format +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C dval d keyword value +C decim i number of decimal places to display in value field +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + double precision dval + integer ounit,status,decim,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkyg(ounit,keywrd,dval,decim,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkyg(ounit,keywrd,dval,decim,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukyj.f b/pkg/tbtables/fitsio/ftukyj.f new file mode 100644 index 00000000..bf55fd93 --- /dev/null +++ b/pkg/tbtables/fitsio/ftukyj.f @@ -0,0 +1,29 @@ +C-------------------------------------------------------------------------- + subroutine ftukyj(ounit,keywrd,intval,comm,status) + +C update an integer value header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C intval i keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + integer ounit,status,intval,tstat + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkyj(ounit,keywrd,intval,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkyj(ounit,keywrd,intval,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukyl.f b/pkg/tbtables/fitsio/ftukyl.f new file mode 100644 index 00000000..ce6bf3a6 --- /dev/null +++ b/pkg/tbtables/fitsio/ftukyl.f @@ -0,0 +1,30 @@ +C-------------------------------------------------------------------------- + subroutine ftukyl(ounit,keywrd,logval,comm,status) + +C update a logical value header record +C +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C logval l keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,comm + integer ounit,status,tstat + logical logval + + if (status .gt. 0)return + tstat=status + +C try modifying the keyword, if it exists + call ftmkyl(ounit,keywrd,logval,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat + call ftpkyl(ounit,keywrd,logval,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftukys.f b/pkg/tbtables/fitsio/ftukys.f new file mode 100644 index 00000000..6c070d1a --- /dev/null +++ b/pkg/tbtables/fitsio/ftukys.f @@ -0,0 +1,30 @@ +C-------------------------------------------------------------------------- + subroutine ftukys(ounit,keywrd,strval,comm,status) + +C update a character string value header record + +C ounit i fortran output unit number +C keywrd c keyword name ( 8 characters, cols. 1- 8) +C strval c keyword value +C comm c keyword comment (47 characters, cols. 34-80) +C OUTPUT PARAMETERS: +C status i output error status (0 = ok) +C +C written by Wm Pence, HEASARC/GSFC, Oct 1994 + + character*(*) keywrd,strval,comm + integer ounit,status,tstat + + if (status .gt. 0)return + + tstat=status +C try modifying the keyword, if it exists + call ftmkys(ounit,keywrd,strval,comm,status) + + if (status .eq. 202)then +C keyword doesn't exist, so create it + status=tstat +C note that this supports the HEASARC long-string conventions + call ftpkls(ounit,keywrd,strval,comm,status) + end if + end diff --git a/pkg/tbtables/fitsio/ftuscc.f b/pkg/tbtables/fitsio/ftuscc.f new file mode 100644 index 00000000..2a45abf4 --- /dev/null +++ b/pkg/tbtables/fitsio/ftuscc.f @@ -0,0 +1,32 @@ +C---------------------------------------------------------------------- + subroutine ftuscc(input,np,scaled,scale,zero,output) + +C unscale the array of complex numbers, prior to writing to the FITS file + +C input r array of complex numbers (pairs of real/imaginay numbers) +C np i total number of values to scale (no. of pairs times 2) +C scaled l is the data scaled? +C scale d scale factor +C zero d offset +C output r output array + + integer np,i,j + logical scaled + real input(np),output(np) + double precision scale,zero + + j=1 + if (scaled)then + do 10 i=1,np/2 + output(j)=(input(j)-zero)/scale + j=j+1 +C the imaginary part of the number is not offset!! + output(j)=input(j)/scale + j=j+1 +10 continue + else + do 20 i=1,np + output(i)=input(i) +20 continue + end if + end diff --git a/pkg/tbtables/fitsio/ftuscm.f b/pkg/tbtables/fitsio/ftuscm.f new file mode 100644 index 00000000..1d05cf49 --- /dev/null +++ b/pkg/tbtables/fitsio/ftuscm.f @@ -0,0 +1,32 @@ +C---------------------------------------------------------------------- + subroutine ftuscm(input,np,scaled,scale,zero,output) + +C unscale the array of complex numbers, prior to writing to the FITS file + +C input d array of complex numbers (pairs of real/imaginay numbers) +C np i total number of values to scale (no. of pairs times 2) +C scaled l is the data scaled? +C scale d scale factor +C zero d offset +C output d output array + + integer np,i,j + logical scaled + double precision input(np),output(np) + double precision scale,zero + + j=1 + if (scaled)then + do 10 i=1,np/2 + output(j)=(input(j)-zero)/scale + j=j+1 +C the imaginary part of the number is not offset!! + output(j)=input(j)/scale + j=j+1 +10 continue + else + do 20 i=1,np + output(i)=input(i) +20 continue + end if + end diff --git a/pkg/tbtables/fitsio/ftvcks.f b/pkg/tbtables/fitsio/ftvcks.f new file mode 100644 index 00000000..4b3a991b --- /dev/null +++ b/pkg/tbtables/fitsio/ftvcks.f @@ -0,0 +1,83 @@ +C---------------------------------------------------------------------- + subroutine ftvcks(iunit,dataok,hduok,status) + +C Verify the HDU by comparing the value of the computed checksums against +C the values of the DATASUM and CHECKSUM keywords if they are present. + +C iunit i fortran unit number +C dataok i output verification code for the data unit alone +C hduok i output verification code for the entire HDU +C the code values = 1 verification is correct +C = 0 checksum keyword is not present +C = -1 verification not correct +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Dec, 1994 + + integer iunit,dataok,hduok,status,tstat,i + double precision datsum,chksum,dsum + character keyval*20,comm*8 + logical cexist,dexist + + if (status .gt. 0)return + +C check if the CHECKSUM keyword exists + tstat=status + call ftgkys(iunit,'CHECKSUM',keyval,comm,status) + if (status .le. 0)then + cexist=.true. + else + hduok=0 + cexist=.false. + status=tstat + end if + +C check if the DATASUM keyword exists and get its value + call ftgkys(iunit,'DATASUM',keyval,comm,status) + if (status .le. 0)then + dexist=.true. + else + dataok=0 + dexist=.false. + status=tstat + end if + +C return if neither keyword exists + if (.not. cexist .and. .not. dexist)return + +C calculate the data checksum and the HDU checksum + call ftgcks(iunit,datsum,chksum,status) + if (status .gt. 0)return + + if (dexist)then + +C decode the datasum string into a double precision variable + do 10 i=1,20 + if (keyval(i:i) .ne. ' ')then + call ftc2dd(keyval(i:20),dsum,status) + if (status .eq. 409)then +C couldn't read the keyword; assume it is out of date + status=tstat + dsum=-1. + end if + go to 15 + end if +10 continue + dsum=0. +15 continue + + if (dsum .eq. datsum)then + dataok=1 + else + dataok=-1 + end if + end if + + if (cexist)then + if (chksum .eq. 0 .or. chksum .eq. 4.294967295D+09)then + hduok=1 + else + hduok=-1 + end if + end if + end diff --git a/pkg/tbtables/fitsio/ftvers.f b/pkg/tbtables/fitsio/ftvers.f new file mode 100644 index 00000000..acc430ab --- /dev/null +++ b/pkg/tbtables/fitsio/ftvers.f @@ -0,0 +1,72 @@ +C------------------------------------------------------------------------------ +C This software was prepared by High Energy Astrophysic Science Archive +C Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +C shall not, without prior written permission of the U.S. Government, +C establish a claim to statutory copyright. The Government and others acting +C on its behalf, shall have a royalty-free, non-exclusive, irrevocable, +C worldwide license for Government purposes to publish, distribute, +C translate, copy, exhibit, and perform such material. +C------------------------------------------------------------------------------ + subroutine ftvers(vernum) + +C Returns the current revision number of the FITSIO package. +C The revision number will be incremented whenever any modifications, +C bug fixes, or enhancements are made to the package + + real vernum +C version 4.06 18 Aug 1995 ftdelt bug; ftpmsg saves latest errors +C version 4.05 2 Aug 1995 another bug in ftfrcl in reseting tstart +C version 4.04 12 Jul 1995 bug in ftfrcl in resetting tstart +C version 4.03 3 Jul 1995 bug in restoring CHDU when moving to EOF +C version 4.02 20 Jun 1995 modified checksum algorithm +C version 4.01 30 May 1995 many changes +C version 3.711 30 Jan 1995 ftgphx was cutting BSCALE to 20 chars +C version 3.710 27 Jan 1995 fix ftgcnn, fitsmac; add ftirec, ftdrec +C version 3.700 29 Dec 1994 public release +C version 3.623 8 Nov 1994 ftgkys, ftgnst, checksum +C version 3.622 7 Nov 1994 ftgclj R*8 alignment; I*2 overflow fti4i2 +C version 3.621 4 Nov 1994 fixed endhd position in ftgrec +C version 3.62 2 Nov 1994 ftgcx[ijd] routines added +C version 3.612 31 Oct 1994 restored previous FTIBLK algorithm +C version 3.61 26 Oct 1994 ftirow and ftdrow to modify tables +C version 3.6 18 Oct 1994 ftukyX, range checking, new EOF checks +C version 3.512 20 Sep 1994 fixed writing header fill in FTWEND +C version 3.511 20 Sep 1994 removed '=' from CONTINUE on long strings +C version 3.51 14 Sep 1994 long string convention and IEEE support +C version 3.504 22 Aug 1994 fixed bug in ftcopy making files too big +C version 3.503 8 Aug 1994 fixed bug in ftcopy making files too big +C version 3.502 26 Jul 1994 explicitly write data fill bytes +C version 3.501 19 Jul 1994 minor changes for FTOOLS release +C version 3.500 29 Jun 1994 added error message stack +C version 3.415 07 Jun 1994 fixed ftmahd and ftgrec +C version 3.414 18 May 1994 modify ftmoff and ftpbyt for status 112 +C version 3.413 18 Mar 1994 Cray port added +C version 3.412 01 Mar 1994 SUN internal read problem in ftgthd +C version 3.411 25 Feb 1994 fixed 107 error when reading byte column +C version 3.410 21 Jan 1994 bug fixes in Alpha VMS version +C version 3.409 21 Dec 1993 long string bug; HP support +C version 3.408 09 Nov 1993 Alpha VMS open; ftgthd -; 210 status +C version 3.407 02 Nov 1993 initialize TABLEs with blanks; ftrdef +C version 3.406 26 Oct 1993 ftgtdm bug - last not initialized +C modified to read unknown extenstions +C version 3.405 21 Oct 1993 ftpini bug with GROUP format files +C version 3.404 7 Oct 1993 new TDIM subroutines, new error status +C version 3.403 1 Sept 1993 initialize strlen in ftpkys +C version 3.402 23 Aug 1993 bug in ftgcno +C version 3.401 20 Aug 1993 minor change to ftpi1b +C version 3.4 - 11 Aug 1993 +C version 3.31 - 2 Feb 1993 +C version 3.3 - 28 Oct 1992 +C version 3.21 - 8 July 1992 +C version 3.20 - 30 Mar 1992 +C version 3.10 - 4 Nov 1991 +C version 3.01 - 27 Sept 1991 +C version 3.00 - 12 Sept 1991 +C version 2.99 - 24 July 1991 +C version 2.0 - 1 May 1991 +C version 1.3 - 2 April 1991 +C version 1.22 - 22 March 1991 +C version 1.21 - 20 March 1991 + + vernum=4.06 + end diff --git a/pkg/tbtables/fitsio/ftwend.f b/pkg/tbtables/fitsio/ftwend.f new file mode 100644 index 00000000..7245a4ca --- /dev/null +++ b/pkg/tbtables/fitsio/ftwend.f @@ -0,0 +1,67 @@ +C---------------------------------------------------------------------- + subroutine ftwend(iunit,status) + +C write the END card, and following fill values in the CHDU + +C iunit i fortran unit number +C status i output error status +C +C written by Wm Pence, HEASARC/GSFC, Aug 1994 + + integer iunit,status + +C COMMON BLOCK DEFINITIONS:-------------------------------------------- + integer nb,ne + parameter (nb = 20) + parameter (ne = 200) + integer bufnum,chdu,hdutyp,maxhdu,hdstrt,hdend,nxthdr,dtstrt + integer nxtfld + logical wrmode + common/ft0001/bufnum(199),chdu(nb),hdutyp(nb),maxhdu(nb), + & wrmode(nb),hdstrt(nb,ne),hdend(nb),nxthdr(nb),dtstrt(nb),nxtfld +C END OF COMMON BLOCK DEFINITIONS----------------------------------- + + integer ibuff,nblank,i,endpos + character*80 rec + + if (status .gt. 0)return + + ibuff=bufnum(iunit) + +C calc the data starting position if not currently defined + if (dtstrt(ibuff) .lt. 0)then + dtstrt(ibuff)=(hdend(ibuff)/2880 + 1)*2880 + end if + +C calculate the number of blank keyword slots in the header + endpos=hdend(ibuff) + nblank=(dtstrt(ibuff)-endpos)/80 +C move the i/o pointer to the end of the header keywords + call ftmbyt(iunit,endpos,.true.,status) + +C fill all the slots with blanks + rec=' ' + do 10 i=1,nblank + call ftpcbf(iunit,1,80,rec,status) +10 continue + +C The END keyword must either be placed +C immediately after the last keyword that was written +C (as indicated by the HDEND parameter), or must be in the +C first 80 bytes of the FITS record immediately preceeding +C the data unit, whichever is further in the file. +C The latter will occur if the user reserved room for more +C header keywords which have not (yet) been filled. + +C move pointer to where the END card should be + endpos=max(endpos,dtstrt(ibuff)-2880) + call ftmbyt(iunit,endpos,.true.,status) + +C write the END record to the output buffer: + rec='END' + call ftpcbf(iunit,1,80,rec,status) + + if (status .gt. 0)then + call ftpmsg('Error while writing END card (FTWEND).') + end if + end diff --git a/pkg/tbtables/fitsio/ftwldp.f b/pkg/tbtables/fitsio/ftwldp.f new file mode 100644 index 00000000..69f78137 --- /dev/null +++ b/pkg/tbtables/fitsio/ftwldp.f @@ -0,0 +1,289 @@ +C------------------------------------------------------------------------------ + subroutine ftwldp(xpix,ypix,xref,yref,xrefpix,yrefpix, + & xinc,yinc,rot,type,xpos,ypos,status) + +C Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS +C Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994 +C routine to determine accurate position from pixel coordinates +C does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections +C returns 0 = good, +C 501 = angle too large for projection; +C Input: +C dbl xpix x pixel number (RA or long without rotation) +C dbl ypiy y pixel number (dec or lat without rotation) +C dbl xref x reference coordinate value (deg) +C dbl yref y reference coordinate value (deg) +C dbl xrefpix x reference pixel +C dbl yrefpix y reference pixel +C dbl xinc x coordinate increment (deg) +C dbl yinc y coordinate increment (deg) +C dbl rot rotation (deg) (from N through E) +C chr type projection type code e.g. "-SIN" +C Output: +C dbl xpos x (RA) coordinate (deg) +C dbl ypos y (dec) coordinate (deg) +C int status error status flag, zero + + integer status + double precision xpix,ypix,xref,yref,xrefpix,yrefpix + double precision xinc,yinc,rot,xpos,ypos + character*(*) type + integer error1,error4 + parameter (error1=501) + parameter (error4=504) + + double precision cosr,sinr,dx,dy,dz,temp + double precision sins,coss,dect,rat,dt,l,m,mg,da,dd,cos0,sin0 + double precision dec0,ra0,decout,raout + double precision geo1,geo2,geo3 + double precision cond2r + parameter (cond2r=1.745329252d-2) + double precision twopi,deps + parameter (twopi = 6.28318530717959) + parameter (deps = 1.0d-5) + integer i,itype + character*4 ctypes(8) + data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP', + & '-GLS', '-MER', '-AIT', '-STG' / + + if (status .gt. 0) return +C *** Offset from ref pixel + dx = (xpix-xrefpix) * xinc + dy = (ypix-yrefpix) * yinc +C *** Take out rotation + cosr = dcos(rot*cond2r) + sinr = dsin(rot*cond2r) + if (rot .ne. 0.0) then + temp = dx * cosr - dy * sinr + dy = dy * cosr + dx * sinr + dx = temp + end if +C *** Find type of coordinate transformation (0 is linear) + itype = 0 + do 10 i = 1, 8 + if (ctypes(i) .eq. type) itype = i + 10 continue +C *** default, linear result for error return + xpos = xref + dx + ypos = yref + dy +C *** Convert to radians + ra0 = xref * cond2r + dec0 = yref * cond2r + l = dx * cond2r + m = dy * cond2r + sins = l*l + m*m + decout = 0.0 + raout = 0.0 + cos0 = dcos(dec0) + sin0 = dsin(dec0) +C *** Process by case + if (itype .eq. 0) then +C *** LINEAR + rat = ra0 + l + dect = dec0 + m + else if (itype .eq. 1) then +C *** SINE from '-SIN' type + if (sins .gt. 1.0) then + status = error1 + goto 30 + end if + coss = dsqrt(1.0 - sins) + dt = sin0 * coss + cos0 * m + if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then + status = error1 + goto 30 + end if + dect = dasin(dt) + rat = cos0 * coss - sin0 * m + if ((rat .eq. 0.0) .and. (l .eq. 0.0)) then + status = error1 + goto 30 + end if + rat = datan2 (l, rat) + ra0 + else if (itype .eq. 2) then +C *** TANGENT from '-TAN' type + if (sins .gt. 1.0) then + status = error1 + goto 30 + end if + dect = cos0 - m * sin0 + if (dect .eq. 0.0) then + status = error1 + goto 30 + end if + rat = ra0 + datan2(l, dect) + dect = datan(dcos(rat-ra0) * (m * cos0 + sin0) / dect) + else if (itype .eq. 3) then +C *** Arc from '-ARC' type + if (sins .ge. twopi * twopi / 4.0) then + status = error1 + goto 30 + end if + sins = dsqrt(sins) + coss = dcos(sins) + if (sins .ne. 0.0) then + sins = dsin(sins) / sins + else + sins = 1.0 + end if + dt = m * cos0 * sins + sin0 * coss + if ((dt .gt. 1.0) .or. (dt .lt. -1.0)) then + status = error1 + goto 30 + end if + dect = dasin(dt) + da = coss - dt * sin0 + dt = l * sins * cos0 + if ((da .eq. 0.0) .and. (dt .eq. 0.0)) then + status = error1 + goto 30 + end if + rat = ra0 + datan2(dt, da) + else if (itype .eq. 4) then +C *** North Celestial Pole from '-NCP' type + dect = cos0 - m * sin0 + if (dect .eq. 0.0) then + status = error1 + goto 30 + end if + rat = ra0 + datan2(l, dect) + dt = dcos(rat-ra0) + if (dt .eq. 0.0) then + status = error1 + goto 30 + end if + dect = dect / dt + if ((dect .gt. 1.0) .or. (dect .lt. -1.0)) then + status = error1 + goto 30 + end if + dect = dacos(dect) + if (dec0 .lt. 0.0) dect = -dect + else if (itype .eq. 5) then +C *** Global Sinusoid from '-GLS' type + dect = dec0 + m + if (dabs(dect) .gt. twopi/4.0) then + status = error1 + goto 30 + end if + coss = dcos(dect) + if (dabs(l) .gt. twopi*coss/2.0) then + status = error1 + goto 30 + end if + rat = ra0 + if (coss .gt. deps) rat = rat + l / coss + else if (itype .eq. 6) then +C *** Mercator from '-MER' type + dt = yinc * cosr + xinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dy = (yref/2.0 + 45.0) * cond2r + dx = dy + dt / 2.0 * cond2r + dy = dlog(dtan(dy)) + dx = dlog(dtan(dx)) + geo2 = dt * cond2r / (dx - dy) + geo3 = geo2 * dy + geo1 = dcos(yref * cond2r) + if (geo1 .le. 0.0) geo1 = 1.0 + rat = l / geo1 + ra0 + if (dabs(rat - ra0) .gt. twopi) then + status = error1 + goto 30 + end if + dt = 0.0 + if (geo2 .ne. 0.0) dt = (m + geo3) / geo2 + dt = dexp(dt) + dect = 2.0 * datan(dt) - twopi / 4.0 + else if (itype .eq. 7) then +C *** Aitoff from '-AIT' type + dt = yinc * cosr + xinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dt = dt * cond2r + dy = yref * cond2r + dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) - + & dsin(dy)/dsqrt((1.0+dcos(dy))/2.0) + if (dx .eq. 0.0) dx = 1.0 + geo2 = dt / dx + dt = xinc * cosr - yinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dt = dt * cond2r + dx = 2.0 * dcos(dy) * dsin(dt/2.0) + if (dx .eq. 0.0) dx = 1.0 + geo1 = dt * dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0) / dx + geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0) + rat = ra0 + dect = dec0 + if ((l .eq. 0.0) .and. (m .eq. 0.0)) goto 20 + dz = 4.0-l*l/(4.0*geo1*geo1)-((m+geo3)/geo2)*((m+geo3)/geo2) + if ((dz .gt. 4.0) .or. (dz .lt. 2.0)) then + status = error1 + goto 30 + end if + dz = 0.5 * dsqrt(dz) + dd = (m+geo3) * dz / geo2 + if (dabs(dd) .gt. 1.0) then + status = error1 + goto 30 + end if + dd = dasin(dd) + if (dabs(dcos(dd)) .lt. deps) then + status = error1 + goto 30 + end if + da = l * dz / (2.0 * geo1 * dcos(dd)) + if (dabs(da) .gt. 1.0) then + status = error1 + goto 30 + end if + da = dasin(da) + rat = ra0 + 2.0 * da + dect = dd + else if (itype .eq. 8) then +C *** Stereographic from '-STG' type + dz = (4.0 - sins) / (4.0 + sins) + if (dabs(dz) .gt. 1.0) then + status = error1 + goto 30 + end if + dect = dz * sin0 + m * cos0 * (1.0+dz) / 2.0 + if (dabs(dect) .gt. 1.0) then + status = error1 + goto 30 + end if + dect = dasin(dect) + rat = dcos(dect) + if (dabs(rat) .lt. deps) then + status = error1 + goto 30 + end if + rat = l * (1.0+dz) / (2.0 * rat) + if (dabs(rat) .gt. 1.0) then + status = error1 + goto 30 + end if + rat = dasin(rat) + mg = 1.0 + dsin(dect)*sin0 + dcos(dect)*cos0*dcos(rat) + if (dabs(mg) .lt. deps) then + status = error1 + goto 30 + end if + mg = 2.0 * (dsin(dect)*cos0 - dcos(dect)*sin0*dcos(rat)) / mg + if (dabs(mg-m) .gt. deps) rat = twopi/2.0 - rat + rat = ra0 + rat + else +C *** Unsupported Projection + status = error4 + goto 30 + end if + 20 continue +C *** Return RA in range + raout = rat + decout = dect + if (raout-ra0 .gt. twopi/2.0) raout = raout - twopi + if (raout-ra0 .lt. -twopi/2.0) raout = raout + twopi + if (raout .lt. 0.0) raout = raout + twopi +C *** Correct units back to degrees + xpos = raout / cond2r + ypos = decout / cond2r + 30 continue + end diff --git a/pkg/tbtables/fitsio/ftxiou.f b/pkg/tbtables/fitsio/ftxiou.f new file mode 100644 index 00000000..f75a1808 --- /dev/null +++ b/pkg/tbtables/fitsio/ftxiou.f @@ -0,0 +1,37 @@ +C------------------------------------------------------------------------------ + subroutine ftxiou(iounit,status) + +C generic routine to manage logical unit numbers in the range 50-99 + + integer iounit,status,i + integer*2 array(50) + save array + data array/50*0/ + + if (iounit .eq. 0)then +C get an unused logical unit number + do 10 i=50,1,-1 + if (array(i) .eq. 0)then + array(i)=1 + iounit=i+49 + return + end if +10 continue +C error: all units are allocated + iounit=-1 + status=114 + call ftpmsg('FTGIOU has no more available unit numbers.') + + else if (iounit .eq. -1)then +C deallocate all the unit numbers + do 20 i=1,50 + array(i)=0 +20 continue + + else +C deallocat a specific unit number + if (iounit .ge. 50 .and. iounit .le. 99)then + array(iounit-49)=0 + end if + endif + end diff --git a/pkg/tbtables/fitsio/ftxmsg.f b/pkg/tbtables/fitsio/ftxmsg.f new file mode 100644 index 00000000..bd5b9006 --- /dev/null +++ b/pkg/tbtables/fitsio/ftxmsg.f @@ -0,0 +1,47 @@ +C------------------------------------------------------------------------------ + subroutine ftxmsg(action,text) + +C get, put, or clear the error message stack + + integer action + character*(*) text + + integer nbuff,i + parameter (nbuff=50) + character*80 txbuff(nbuff) + save txbuff + data txbuff/nbuff * ' '/ + + if (action .eq. -1)then + +C get error message from top of stack and shift the stack up one + text=txbuff(1) + do 10 i=1,nbuff-1 + txbuff(i) = txbuff(i+1) + 10 continue + txbuff(nbuff)=' ' + + else if (action .eq. 1)then + +C put error message onto stack. + do 20 i=1,nbuff + if (txbuff(i) .eq. ' ')then + txbuff(i)=text + return + end if +20 continue +C stack is full so discard oldest message + do 25 i=1,nbuff-1 + txbuff(i) = txbuff(i+1) +25 continue + txbuff(nbuff)=text + + else if (action .eq. 0)then + +C clear the error message stack + do 30 i=1,nbuff + txbuff(i) = ' ' +30 continue + + end if + end diff --git a/pkg/tbtables/fitsio/ftxypx.f b/pkg/tbtables/fitsio/ftxypx.f new file mode 100644 index 00000000..4a21e55f --- /dev/null +++ b/pkg/tbtables/fitsio/ftxypx.f @@ -0,0 +1,230 @@ +C------------------------------------------------------------------------------ + subroutine ftxypx(xpos,ypos,xref,yref,xrefpix,yrefpix, + & xinc,yinc,rot,type,xpix,ypix,status) + +C Fortran version of worldpos.c -- WCS Algorithms from Classic AIPS +C Translated by James Kent Blackburn -- HEASARC/GSFC/NASA -- November 1994 +C routine to determine accurate pixel coordinates from an RA and Dec +C does: -SIN, -TAN, -ARC, -NCP, -GLS, -MER, -AIT projections +C returns 0 = good, +C 501 = angle too large for projection; +C 502 = bad values +C 503 = ???undocumented error - looks like an underflow??? +C Input: +C dbl xpos x (RA) coordinate (deg) +C dbl ypos y (dec) coordinate (deg) +C dbl xref x reference coordinate value (deg) +C dbl yref y reference coordinate value (deg) +C dbl xrefpix x reference pixel +C dbl yrefpix y reference pixel +C dbl xinc x coordinate increment (deg) +C dbl yinc y coordinate increment (deg) +C dbl rot rotation (deg) (from N through E) +C chr type projection type code e.g. "-SIN" +C Output: +C dbl xpix x pixel number (RA or long without rotation) +C dbl ypiy y pixel number (dec or lat without rotation) +C int status error status flag, zero + + integer status + double precision xpos,ypos,xref,yref,xrefpix,yrefpix + double precision xinc,yinc,rot,xpix,ypix + character*(*) type + integer error1,error2,error3,error4 + parameter (error1=501) + parameter (error2=502) + parameter (error3=503) + parameter (error4=504) + double precision dx,dy,dz,r,ra0,dec0,ra,dec + double precision coss,sins,dt,da,dd,sint,oldxpos + double precision l,m,geo1,geo2,geo3,sinr,cosr + double precision cond2r + parameter (cond2r=1.745329252d-2) + double precision twopi,deps + parameter (twopi = 6.28318530717959) + parameter (deps = 1.0d-5) + integer i,itype + character*4 ctypes(8) + data ctypes/ '-SIN', '-TAN', '-ARC', '-NCP', + & '-GLS', '-MER', '-AIT', '-STG' / + + if (status .gt. 0) return +C *** 0 hour wrap around test + oldxpos = xpos + dt = (xpos - xref) + if (dt .gt. +180) xpos = xpos - 360 + if (dt .lt. -180) xpos = xpos + 360 +C *** Default values - Linear + dx = xpos - xref + dy = ypos - yref + dz = 0.0 +C *** Correct for rotation + r = rot * cond2r + cosr = dcos(r) + sinr = dsin(r) + dz = dx * cosr + dy * sinr + dy = dy * cosr - dx * sinr + dx = dz +C *** Check axis increments - bail out if either 0 + if ((xinc .eq. 0.0) .or. (yinc .eq. 0.0)) then + xpix = 0.0 + ypix = 0.0 + status = error2 + goto 30 + end if + xpix = dx / xinc + xrefpix + ypix = dy / yinc + yrefpix +C *** Find type of coordinate transformation (0 is linear) + itype = 0 + do 10 i = 1, 8 + if (ctypes(i) .eq. type) itype = i + 10 continue +C *** Done if linear + if (itype .eq. 0) goto 30 +C *** Non-Linear position + ra0 = xref * cond2r + dec0 = yref * cond2r + ra = xpos * cond2r + dec = ypos * cond2r +C *** Compute directional cosine + coss = dcos(dec) + sins = dsin(dec) + l = dsin(ra-ra0) * coss + sint = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0) +C *** Process by case + if (itype .eq. 1) then +C *** SINE from '-SIN' type + if (sint .lt. 0.0) then + status = error1 + goto 30 + end if + m = sins * dcos(dec0) - coss * dsin(dec0) * dcos(ra-ra0) + else if (itype .eq. 2) then +C *** TANGENT from '-TAN' type + if (sint .le. 0.0) then + status = error1 + goto 30 + end if + m = sins * dsin(dec0) + coss * dcos(dec0) * dcos(ra-ra0) + l = l / m + m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) / m + else if (itype .eq. 3) then +C *** Arc from '-ARC' type + m = sins*dsin(dec0) + coss*dcos(dec0)*dcos(ra-ra0) + if (m .lt. -1.0) m = -1.0 + if (m .gt. 1.0) m = 1.0 + m = dacos(m) + if (m .ne. 0) then + m = m / dsin(m) + else + m = 1.0 + end if + l = l * m + m = (sins*dcos(dec0) - coss*dsin(dec0)*dcos(ra-ra0)) * m + else if (itype .eq. 4) then +C *** North Celestial Pole from '-NCP' type + if (dec0 .eq. 0.0) then + status = error1 + goto 30 + else + m = (dcos(dec0) - coss * dcos(ra-ra0)) / dsin(dec0) + end if + else if (itype .eq. 5) then +C *** Global Sinusoid from '-GLS' type + dt = ra - ra0 + if (dabs(dec) .gt. twopi/4.0) then + status = error1 + goto 30 + end if + if (dabs(dec0) .gt. twopi/4.0) then + status = error1 + goto 30 + end if + m = dec - dec0 + l = dt * coss + else if (itype .eq. 6) then +C *** Mercator from '-MER' type + dt = yinc * cosr + xinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dy = (yref/2.0 + 45.0) * cond2r + dx = dy + dt / 2.0 * cond2r + dy = dlog(dtan(dy)) + dx = dlog(dtan (dx)) + geo2 = dt * cond2r / (dx - dy) + geo3 = geo2 * dy + geo1 = cos (yref * cond2r) + if (geo1 .le. 0.0) geo1 = 1.0 + dt = ra - ra0 + l = geo1 * dt + dt = dec / 2.0 + twopi / 8.0 + dt = dtan(dt) + if (dt .lt. deps) then + status = error2 + goto 30 + end if + m = geo2 * dlog(dt) - geo3 + else if (itype .eq. 7) then +C *** Aitoff from '-AIT' type + l = 0.0 + m = 0.0 + da = (ra - ra0) / 2.0 + if (dabs(da) .gt. twopi/4.0) then + status = error1 + goto 30 + end if + dt = yinc * cosr + xinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dt = dt * cond2r + dy = yref * cond2r + dx = dsin(dy+dt)/dsqrt((1.0+dcos(dy+dt))/2.0) - + & dsin(dy)/dsqrt((1.0+dcos(dy))/2.0) + if (dx .eq. 0.0) dx = 1.0 + geo2 = dt / dx + dt = xinc * cosr - yinc * sinr + if (dt .eq. 0.0) dt = 1.0 + dt = dt * cond2r + dx = 2.0 * dcos(dy) * dsin(dt/2.0) + if (dx .eq. 0.0) dx = 1.0 + geo1 = dt*dsqrt((1.0+dcos(dy)*dcos(dt/2.0))/2.0)/dx + geo3 = geo2 * dsin(dy) / dsqrt((1.0+dcos(dy))/2.0) + dt = dsqrt ((1.0 + dcos(dec) * dcos(da))/2.0) + if (dabs(dt) .lt. deps) then + status = error3 + goto 30 + end if + l = 2.0 * geo1 * dcos(dec) * dsin(da) / dt + m = geo2 * dsin(dec) / dt - geo3 + else if (itype .eq. 8) then +C *** Stereographic from '-STG' type + da = ra - ra0 + if (dabs(dec) .gt. twopi/4.0) then + status = error1 + goto 30 + end if + dd = 1.0 + sins*dsin(dec0) + coss*dcos(dec0)*dcos(da) + if (dabs(dd) .lt. deps) then + status = error1 + goto 30 + end if + dd = 2.0 / dd + l = l * dd + m = dd * (sins*dcos(dec0) - coss*dsin(dec0)*dcos(da)) + else +C *** Unsupported Projection + status = error4 + goto 30 + end if +C *** Convert back to degrees + dx = l / cond2r + dy = m / cond2r +C *** Correct for rotation + dz = dx * cosr + dy * sinr + dy = dy * cosr - dx * sinr + dx = dz +C *** Convert to PIXELS ... yeah! + xpix = dx / xinc + xrefpix + ypix = dy / yinc + yrefpix + 30 continue +C *** reset xpos to correct for in place modification + xpos = oldxpos + end diff --git a/pkg/tbtables/fitsio/mkpkg b/pkg/tbtables/fitsio/mkpkg new file mode 100644 index 00000000..cefd89a6 --- /dev/null +++ b/pkg/tbtables/fitsio/mkpkg @@ -0,0 +1,374 @@ +# FITSIO -- This IRAF mkpkg file updates the TBTABLES library to include +# the FITSIO interface. + +tbtables: +$checkout libtbtables.a ../ +$update libtbtables.a +$checkin libtbtables.a ../ +$exit + +libtbtables.a: + ftadef.f + ftaini.f + ftarch.f + ftas2c.f + ftasfm.f + ftbdef.f + ftbini.f + ftbnfm.f + ftc2as.f + ftc2d.f + ftc2dd.f + ftc2i.f + ftc2ii.f + ftc2l.f + ftc2ll.f + ftc2r.f + ftc2rr.f + ftc2s.f + ftc2x.f + ftcdel.f + ftcdfl.f + ftchdu.f + ftchfl.f + ftcins.f + ftclos.f + ftcmps.f + ftcmsg.f + ftcopy.f + ftcpdt.f + ftcrep.f + ftcrhd.f + ftcsum.f + ftd2e.f + ftd2f.f + ftdblk.f + ftdcol.f + ftddef.f + ftdelt.f + ftdhdu.f + ftdkey.f + ftdrec.f + ftdrow.f + ftdsum.f + ftdtyp.f + ftesum.f + ftfiou.f + ftfrcl.f + ftg2db.f + ftg2dd.f + ftg2de.f + ftg2di.f + ftg2dj.f + ftg3db.f + ftg3dd.f + ftg3de.f + ftg3di.f + ftg3dj.f + ftgabc.f + ftgacl.f + ftgatp.f + ftgbcl.f + ftgbit.f + ftgbnh.f + ftgbtp.f + ftgcfb.f + ftgcfc.f + ftgcfd.f + ftgcfe.f + ftgcfi.f + ftgcfj.f + ftgcfl.f + ftgcfm.f + ftgcfs.f + ftgcks.f + ftgcl.f + ftgclb.f + ftgclc.f + ftgcld.f + ftgcle.f + ftgcli.f + ftgclj.f + ftgclm.f + ftgcls.f + ftgcnn.f + ftgcno.f + ftgcrd.f + ftgcvb.f + ftgcvc.f + ftgcvd.f + ftgcve.f + ftgcvi.f + ftgcvj.f + ftgcvm.f + ftgcvs.f + ftgcx.f + ftgcxd.f + ftgcxi.f + ftgcxj.f + ftgdes.f + ftgerr.f + ftgext.f + ftggpb.f + ftggpd.f + ftggpe.f + ftggpi.f + ftggpj.f + ftghad.f + ftghbn.f + ftghdn.f + ftghpr.f + ftghps.f + ftghsp.f + ftghtb.f + ftgi1b.f + ftgics.f + ftgiou.f + ftgkey.f + ftgknd.f + ftgkne.f + ftgknj.f + ftgknl.f + ftgkns.f + ftgkyd.f + ftgkye.f + ftgkyj.f + ftgkyl.f + ftgkyn.f + ftgkys.f + ftgkyt.f + ftgmsg.f + ftgnst.f + ftgpfb.f + ftgpfd.f + ftgpfe.f + ftgpfi.f + ftgpfj.f + ftgphx.f + ftgprh.f + ftgpvb.f + ftgpvd.f + ftgpve.f + ftgpvi.f + ftgpvj.f + ftgrec.f + ftgsfb.f + ftgsfd.f + ftgsfe.f + ftgsfi.f + ftgsfj.f + ftgsvb.f + ftgsvd.f + ftgsve.f + ftgsvi.f + ftgsvj.f + ftgtbb.f + ftgtbc.f + ftgtbh.f + ftgtbn.f + ftgtbs.f + ftgtcl.f + ftgtcs.f + ftgtdm.f + ftgthd.f + ftgtkn.f + ftgttb.f + fthdef.f + fthpdn.f + fthpup.f + fti1i1.f + fti1i2.f + fti1i4.f + fti1r4.f + fti1r8.f + fti2c.f + fti2i1.f + fti2i2.f + fti2i4.f + fti2r4.f + fti2r8.f + fti4i1.f + fti4i2.f + fti4i4.f + fti4r4.f + fti4r8.f + ftibin.f + ftiblk.f + fticol.f + ftiimg.f + ftikyd.f + ftikye.f + ftikyf.f + ftikyg.f + ftikyj.f + ftikyl.f + ftikys.f + ftinit.f + ftirec.f + ftirow.f + ftitab.f + ftkeyn.f + ftkshf.f + ftl2c.f + ftmahd.f + ftmcom.f + ftmcrd.f + ftmkey.f + ftmkyd.f + ftmkye.f + ftmkyf.f + ftmkyg.f + ftmkyj.f + ftmkyl.f + ftmkys.f + ftmnam.f + ftmodr.f + ftmrec.f + ftmrhd.f + ftnkey.f + ftnulc.f + ftnulm.f + ftopen.f + ftp2db.f + ftp2dd.f + ftp2de.f + ftp2di.f + ftp2dj.f + ftp3db.f + ftp3dd.f + ftp3de.f + ftp3di.f + ftp3dj.f + ftpbit.f + ftpbnh.f + ftpcks.f + ftpclb.f + ftpclc.f + ftpcld.f + ftpcle.f + ftpcli.f + ftpclj.f + ftpcll.f + ftpclm.f + ftpcls.f + ftpclu.f + ftpclx.f + ftpcnb.f + ftpcnd.f + ftpcne.f + ftpcni.f + ftpcnj.f + ftpcom.f + ftpdat.f + ftpdef.f + ftpdes.f + ftpdfl.f + ftpgpb.f + ftpgpd.f + ftpgpe.f + ftpgpi.f + ftpgpj.f + ftphbn.f + ftphis.f + ftphpr.f + ftphtb.f + ftpi1b.f + ftpini.f + ftpkey.f + ftpkls.f + ftpknd.f + ftpkne.f + ftpknf.f + ftpkng.f + ftpknj.f + ftpknl.f + ftpkns.f + ftpkyd.f + ftpkye.f + ftpkyf.f + ftpkyg.f + ftpkyj.f + ftpkyl.f + ftpkys.f + ftpkyt.f + ftplsw.f + ftpmsg.f + ftpnul.f + ftppnb.f + ftppnd.f + ftppne.f + ftppni.f + ftppnj.f + ftpprb.f + ftpprd.f + ftppre.f + ftpprh.f + ftppri.f + ftpprj.f + ftppru.f + ftprec.f + ftprsv.f + ftpscl.f + ftpssb.f + ftpssd.f + ftpsse.f + ftpssi.f + ftpssj.f + ftpsvc.f + ftptbb.f + ftptbh.f + ftptbs.f + ftptdm.f + ftpthp.f + ftr2e.f + ftr2f.f + ftr4i1.f + ftr4i2.f + ftr4i4.f + ftr4r4.f + ftr4r8.f + ftr8i1.f + ftr8i2.f + ftr8i4.f + ftr8r4.f + ftr8r8.f + ftrdef.f + ftrhdu.f + ftrsnm.f + ftrwdn.f + ftrwup.f + fts2c.f + ftsdnn.f + ftsnul.f + ftsrnn.f + fttbit.f + fttdnn.f + fttkey.f + fttkyn.f + fttnul.f + fttrec.f + fttrnn.f + fttscl.f + ftucks.f + ftucrd.f + ftukyd.f + ftukye.f + ftukyf.f + ftukyg.f + ftukyj.f + ftukyl.f + ftukys.f + ftuscc.f + ftuscm.f + ftvcks.f + ftvers.f + ftwend.f + ftwldp.f + ftxiou.f + ftxmsg.f + ftxypx.f + @fitssppb +# @$(FITSIO_HOST_DEP) + @unix + fitsspp.x fitsspp.com + ; diff --git a/pkg/tbtables/fitsio/unix/README b/pkg/tbtables/fitsio/unix/README new file mode 100644 index 00000000..b3d8619b --- /dev/null +++ b/pkg/tbtables/fitsio/unix/README @@ -0,0 +1,15 @@ +# These routines are part of the FITSIO library and are designed to run in +# the IRAF/SPP environment. +#------------------------------------------------------------------------------ +# This software was prepared by High Energy Astrophysics Science Archive +# Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +# shall not, without prior written permission of the U.S. Government, +# establish a claim to statutory copyright. The Government and others acting +# on its behalf shall have a royalty-free, non-exclusive, irrevocable, +# worldwide license for Government purposes to publish, distribute, +# translate, copy, exhibit, and perform such material. +#------------------------------------------------------------------------------ +# +# The two files ftgcbf.x and ftpcbf.x were extracted from ../fitsspp.x +# into this directory because they are system dependent. There is +# another version in the ../vms/ directory which uses the %ref function. diff --git a/pkg/tbtables/fitsio/unix/ftgcbf.x b/pkg/tbtables/fitsio/unix/ftgcbf.x new file mode 100644 index 00000000..20cf860a --- /dev/null +++ b/pkg/tbtables/fitsio/unix/ftgcbf.x @@ -0,0 +1,17 @@ +# FTGCBF -- Read a sequence of characters from a file into the output +# character string buffer. The sequence may begin on any byte boundary and +# may be any number of bytes long. An error status is returned if less than +# the requested amount of data is read. + +procedure ftgcbf (iunit, convrt, nbytes, array, status) + +int iunit #I fortran unit number +int convrt #I convert to ASCII? (not used in SPP version) +int nbytes #I number of bytes to be transferred +% character*(*) array +int status #U output error status + +begin + # Get the data. Won't work on VAX. + call ftgbyt (iunit, nbytes, array, status) +end diff --git a/pkg/tbtables/fitsio/unix/ftpcbf.x b/pkg/tbtables/fitsio/unix/ftpcbf.x new file mode 100644 index 00000000..4f830011 --- /dev/null +++ b/pkg/tbtables/fitsio/unix/ftpcbf.x @@ -0,0 +1,20 @@ +# This is the non-VMS version. A character string variable is passed +# to an integer array argument. +# +# FTPCBF -- Write a sequence of characters to a file. + +# FTPCBF -- Write a sequence of characters to a file. The sequence may begin +# on any byte boundary and may be any number of bytes long. + +procedure ftpcbf (iunit, convrt, nbytes, array, status) + +int iunit #I fortran unit number +int convrt #I convert to ASCII? (not used in SPP version) +int nbytes #I number of bytes to be transferred +% character*(*) array +int status #U output error status + +begin + # Write the data. Won't work on a VAX. + call ftpbyt (iunit, nbytes, array, status) +end diff --git a/pkg/tbtables/fitsio/unix/mkpkg b/pkg/tbtables/fitsio/unix/mkpkg new file mode 100644 index 00000000..5a284614 --- /dev/null +++ b/pkg/tbtables/fitsio/unix/mkpkg @@ -0,0 +1,11 @@ +# FITSIO -- Update the system-dependent subroutines in the FITSIO library. + +$checkout libtbtables.a ../ +$update libtbtables.a +$checkin libtbtables.a ../ +$exit + +libtbtables.a: + ftpcbf.x + ftgcbf.x + ; diff --git a/pkg/tbtables/fitsio/vms/README b/pkg/tbtables/fitsio/vms/README new file mode 100644 index 00000000..8c54270f --- /dev/null +++ b/pkg/tbtables/fitsio/vms/README @@ -0,0 +1,15 @@ +# These routines are part of the FITSIO library and are designed to run in +# the IRAF/SPP environment. +#------------------------------------------------------------------------------ +# This software was prepared by High Energy Astrophysics Science Archive +# Research Center (HEASARC) at the NASA Goddard Space Flight Center. Users +# shall not, without prior written permission of the U.S. Government, +# establish a claim to statutory copyright. The Government and others acting +# on its behalf shall have a royalty-free, non-exclusive, irrevocable, +# worldwide license for Government purposes to publish, distribute, +# translate, copy, exhibit, and perform such material. +#------------------------------------------------------------------------------ +# +# The two files ftgcbf.x and ftpcbf.x were extracted from [-]fitsspp.x +# into this directory because they are system dependent. There is +# another version in the [-.unix] directory. diff --git a/pkg/tbtables/fitsio/vms/ftgcbf.x b/pkg/tbtables/fitsio/vms/ftgcbf.x new file mode 100644 index 00000000..709f5eb0 --- /dev/null +++ b/pkg/tbtables/fitsio/vms/ftgcbf.x @@ -0,0 +1,20 @@ +# This is the VMS version. A character string variable is passed +# to an integer array argument using %ref. +# +# FTGCBF -- Read a sequence of characters from a file into the output +# character string buffer. The sequence may begin on any byte boundary and +# may be any number of bytes long. An error status is returned if less than +# the requested amount of data is read. + +procedure ftgcbf (iunit, convrt, nbytes, array, status) + +int iunit #I fortran unit number +int convrt #I convert to ASCII? (not used in SPP version) +int nbytes #I number of bytes to be transferred +% character*(*) array +int status #U output error status + +begin + # Get the data. Note that we use %ref. + call ftgbyt (iunit, nbytes, %ref (array), status) +end diff --git a/pkg/tbtables/fitsio/vms/ftpcbf.x b/pkg/tbtables/fitsio/vms/ftpcbf.x new file mode 100644 index 00000000..bba325b2 --- /dev/null +++ b/pkg/tbtables/fitsio/vms/ftpcbf.x @@ -0,0 +1,18 @@ +# This is the VMS version. A character string variable is passed +# to an integer array argument using %ref. + +# FTPCBF -- Write a sequence of characters to a file. The sequence may begin +# on any byte boundary and may be any number of bytes long. + +procedure ftpcbf (iunit, convrt, nbytes, array, status) + +int iunit #I fortran unit number +int convrt #I convert to ASCII? (not used in SPP version) +int nbytes #I number of bytes to be transferred +% character*(*) array +int status #U output error status + +begin + # Write the data. Note that we use %ref. + call ftpbyt (iunit, nbytes, %ref (array), status) +end diff --git a/pkg/tbtables/fitsio/vms/mkpkg b/pkg/tbtables/fitsio/vms/mkpkg new file mode 100644 index 00000000..5a284614 --- /dev/null +++ b/pkg/tbtables/fitsio/vms/mkpkg @@ -0,0 +1,11 @@ +# FITSIO -- Update the system-dependent subroutines in the FITSIO library. + +$checkout libtbtables.a ../ +$update libtbtables.a +$checkin libtbtables.a ../ +$exit + +libtbtables.a: + ftpcbf.x + ftgcbf.x + ; |