!+CRCIF subroutine crcif IMPLICIT NONE ! ! Description: ! Task to create an empty Calibration Index File with the name ! given by the filename parameter ! ! Passed Parameters ! None ! ! User i/ps required (prompted for): ! None ... isolated GCRCIF (below) ! ! COMMONS/INCLUDES etc ! common TASK : (FTOOLS) standard fatal error message thingy ! ! Called routines ! subroutine GCRCIF : (below) Gets parameters from XPI par file ! subroutine CRTCIF : (CALLIB) Does the job ! ! Compilation: ! subroutines require XPI, CALLIB, FTOOLS, FITSIO ! ! Origin: ! Original ! ! Authors/Modification History: ! Ron Zellar (1.0.0:94 Jan 14) Original Version ! Ron Zellar (1.1.0:94 Sep 28) crtcif subroutine to CALLIB ! Ian M George (2.0.0:95 Jul 11), cosmetics + CALLIB-ization ! Lorraine Breedon (2.1.0:98 Jun 23), y2k adaptions ! MFC (2.2 2020 Apr 16) f90 version character(7) version parameter (version = '2.2') !- ! Internals character(160) file integer errstat, chatter character(25) context character(40) taskname character(80) message ! Initialize COMMON/task/taskname taskname = 'CRCIF ' // version errstat = 0 message = '** CRCIF ' // version call fcecho(message) ! Get the filename of the CIF to be created call gcrcif(file, chatter, errstat) if (errstat .ne. 0) goto 999 ! Create the empty Calibration Index File call crtcif(chatter, file, errstat) ! 999 if(errstat.NE.0) then context = 'Incomplete Execution' message = '** CRCIF ' // version // ' ERROR : ' // context call fcecho(message) call fcerr(context) else message = '** CRCIF ' // version // ' Finished' call fcecho(message) endif return end !------- End of CRCIF subroutine --------------------------------------- !----------------------------------------------------------------------- !+GCRCIF subroutine gcrcif(file, chatter, ierr) implicit none character*(*) file integer ierr, chatter ! Description: Gets the parameters from the crcif.par parameter file ! Gets the parameters from the crcif.par parameter file ! ! User i/ps required (prompted for): ! FILE - Input Filename ! CHATTER - chattiness flag for o/p (5 quite,10 normal,15 high,>20 silly) ! IERR - Error Flag (zero = OK) ! ! Origin: ! Original ! ! Called Routines ! Incomplete ! ! Compilation: ! requires XPI/Host interface etc and CALLIB ! ! Authors/Modification History: ! Ron Zellar (1.0.0:1994 jan 14) Original Version ! Ian M George (2.0.0:1995 Jul 11) Added chatter as passed and stuff character(7) version parameter (version = '2.0.0') !- ! Internals character(30) errstr, wrnstr character(80) message ! Initialize ierr = 0 errstr = '** GCRCIF ' // version // ' ERROR: ' wrnstr = '** GCRCIF ' // version // ' WARNING: ' ! Get the CIF filename call uclgst('filename', file, ierr) if(ierr.NE.0) then message = errstr // 'Getting FILENAME parameter' call fcecho(message) return endif ! Get the chattiness flag call uclgsi('chatter', chatter, ierr) if(ierr.NE.0) then message = errstr // 'Getting CHATTER parameter' call fcecho(message) ierr = 0 message = ' ... setting CHATTER = 9' call fcecho(message) chatter = 9 endif ! Give user info if requested if(chatter.GE.20) then message = ' ... using GCRCIF ' // version call fcecho(message) endif return end ! ------------------------------------------------------------------------- !+CRTCIF subroutine crtcif(chatter, file, ierr) implicit none integer chatter, ierr character*(*) file ! Description: ! Creates a CIF with name given by file ! ! Passed parameters ! CHATTER i : chattiness flag for o/p (5 quite,10 normal,>20 silly) ! FILE i : name of the CIF to be created ! IERR o : Error Flag (ierr = 0 on successful completion) ! ! User i/ps required (prompted for): ! None ! ! Include files ! None ! ! Called Routines: ! subroutine CGETLUN : (CALLIB) Get free FORTRAN logical unit ! subroutine FTBDEF : (FITSIO) Define BINTABLE stuff ! subroutine FTCLOS : (FITSIO) Close the FITS file ! subroutine FTCRHD : (FITSIO) Create a new extension ! subroutine FTPHBN : (FITSIO) Write header of BINTABLE ! subroutine FTPKYx : (FITSIO) Write keyword/value ! subroutine OPNPA : (FITSIO) Open & write null P.array ! subroutine WTINFO : (FTOOLS) Write message to STDOUT ! subroutine WTERRM : (FTOOLS) Write internal error message ! subroutine WTFERR : (FTOOLS) Write internal + fitsio error message ! ! Compilation & Linking ! link with FITSIO & CALLIB ! ! Origin: ! Written for the Calibration Database ! ! Authors/Modification History: ! Ron Zellar (94 Jan 14:1.0.0) Original Version ! Ron Zellar (94 Sep 28:1.0.1) Split crtcif routine from crcif task ! Ron Zellar (94 Oct 13:1.1.0) initialization of errstat ! Ian M George (95 Jul 11:2.0.0),cosmetics + chatter & ierr passed ! Ian M George (95 Dec 19:2.0.1) added wtinfo & friends ! Ian M George (95 Dec 21:2.0.1) call cfreluns at end ! Lorraine Breedon (98 Jun 23:2.1.0) increase vector length of ! CAL_VSD and CAL_DATE columns ! to cope with yyyy-mm-dd format character(7) version parameter (version = '2.1.0') !- ! Internals character(6) subname parameter (subname = 'crtcif') ! ... This parameter defines the number of columns in the CIF integer ncols ! ... This parameter defines the CIF format version number character(4) vrsnum parameter (ncols = 18, vrsnum = ' 1.1') character(8) ttype(18), tform(18), tunit(18), extname character(80) message, comm integer lun, errstat, nrows integer tfields, varidat, idx ! Initialize ierr = 0 errstat = 0 ! Set up defaults nrows = 0 tfields = ncols extname = 'CIF' varidat = 0 ! Give user info if requested message = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, message) ! Get a free FORTRAN unit call cgetlun(lun) ! Column set-up ttype(1) = 'TELESCOP' tform(1) = '10A' ttype(2) = 'INSTRUME' tform(2) = '10A' ttype(3) = 'DETNAM' tform(3) = '20A' ttype(4) = 'FILTER' tform(4) = '10A' ttype(5) = 'CAL_DEV' tform(5) = '20A' ttype(6) = 'CAL_DIR' tform(6) = '70A' ttype(7) = 'CAL_FILE' tform(7) = '40A' ttype(8) = 'CAL_CLAS' tform(8) = '3A' ttype(9) = 'CAL_DTYP' tform(9) = '4A' ttype(10) = 'CAL_CNAM' tform(10) = '20A' ttype(11) = 'CAL_CBD' tform(11) = '630A70' ttype(12) = 'CAL_XNO' tform(12) = 'I' ttype(13) = 'CAL_VSD' tform(13) = '10A' ttype(14) = 'CAL_VST' tform(14) = '8A' ttype(15) = 'REF_TIME' tform(15) = 'D' ttype(16) = 'CAL_QUAL' tform(16) = 'I' ttype(17) = 'CAL_DATE' tform(17) = '10A' ttype(18) = 'CAL_DESC' tform(18) = '70A' Do 500 idx = 1, ncols tunit(idx) = ' ' 500 continue ! Open the CIF & write a null Primary array call opnpa(file, chatter, lun, .false., errstat) if(errstat.NE.0) then ierr = 1 goto 998 endif ! Create the CIF extension call ftcrhd(lun, errstat) if(errstat.NE.0) then call wtferr(subname, version, errstat, & 'Problem creating new extension') ierr = 1 goto 998 endif ! Write the required binary table keywords call ftphbn(lun, nrows, tfields, ttype, tform, tunit, extname, & varidat, errstat) if(errstat.NE.0) then call wtferr(subname, version, errstat, & 'Problem writing BINTABLE keywords') ierr = 1 goto 998 endif ! Write the CIF version number comm = 'Version of CIF format' call ftpkys(lun, 'CIFVERSN', vrsnum, comm, errstat) if(errstat.NE.0) then call wtferr(subname, version, errstat, & 'Problem writing CIFVERSN keyword') call wtinfo(0, 1, 1, 'continuing regardless') errstat = 0 endif ! Define the binary table data call ftbdef(lun, tfields, tform, varidat, nrows, errstat) if(errstat.NE.0) then call wtferr(subname, version, errstat, & 'Defining BINTABLE') ierr = 1 goto 998 endif ! Close the file call ftclos(lun, errstat) if(errstat.NE.0) then call wtferr(subname, version, errstat, & 'Closing the CIF file') ierr = 1 goto 998 endif ! Final error check 998 if(ierr.NE.0) then call wterrm(subname, version, ' Fatal - aborting') else call wtinfo(chatter, 20, 1, 'CIF created successfully') endif ! Free up the bugger call cfrelun(lun) return end