!+MUDCIF subroutine mudcif implicit none ! Description: Many UpDates to a CIF. ! Enter many cal filenames (+ extns) via ASCII file. ! (1) Reads info from 'data/input.ASCII'. ! This file contains 4 lines : name of mission, name of ! instrument, name of instrument alias ! and name of a 'special' ASCII file. ! The 'special' ASCII file contains a list ! of 'good' quality calibration files appropriate ! for the given mission and instrument; together with ! 'last modification date' info. ! The cal filenames[+ extns] + dates are put into memory. ! ! (2) cal filenames[+extns] + other info from the ! CIF (appropriate for the given mission, instrument) ! are put into memory. ! ! (3) For any file extn in the ASCII list which is also ! in the CIF whose 'last modification date' is later than ! its CIF installation date ---> OVERWRITE the row in the ! CIF for this file extn to describe the more recently changed ! dataset ! ! (4) For any file extn in the ASCII list which is also ! in the CIF whose 'last modification date' is earlier ! or equal to its CIF installation date ---> DO NOTHING ! ! ! (5) For any file extn in the ASCII list which is NOT ! listed in the CIF ---> ADD a new row (1 for each INSTRUME ! alias) to the end of the CIF. These rows contain the keyword ! values from the header of the new cal file extn. ! ! (6) For any file extn in the CIF NOT listed in the ASCII ! list ----> switch the quality flags in the CIF for these ! files to 'bad' (qualval=5). ! ! ! ! Passed parameters : none ! ! User i/ps required (prompted for): none ! ! called routines : ! subroutine GPARAMS : (CALLIB) gets parameters from mudcif.par file ! subroutine WT_FERRMSG : (CALLIB) dumps error messages ! subroutine CGETLUN : (CALLIB) get free FORTRAN logical unit no ! subroutine CFRELUN : (CALLIB) releases FORTRAN logical unit no ! subroutine CALDB_INFO : (CALLIB) checks local CALDB available to user ! for required mission/instrument ! subroutine RDCNFG : (CALLIB) gets the CALDB config file for the ! given mission and instrument ! subroutine FCECHO : (FITSIO) write to standard o/p ! subroutine CIFINFO : (CALLIB) obtains necessary info from CIF and ! writes to memory ! subroutine MOD_CIF : (CALLIB) does the business ! ! compilation & linking : ! link with CALLIB & FITSIO ! ! Origin: Written for the Calibration Database. ! ! Authors/Modification History: ! Lorraine Breedon (1.0.0:96 Oct 15) original version ! Lorraine Breedon (1.1.0:97 Jun 11) accounts for extra CIF column CAL_ORIGIN ! Lorraine Breedon (1.2.0:97 Aug 5) now flags files NOT INCLUDED in ! '_special.ASCII' file as 'bad' ! Lorraine Breedon (1.3.0:98 Aug 20) y2k compliance changes ! Jeff Guerber (1.3.1 1999-02-23) mod_cif: can't call ftgstm with const arg ! MFC (1.3.2 2020-04-16) f90 version; lengthened some string truncations character(7) version parameter (version = '1.3.2') !- ! internals integer arrsz parameter (arrsz = 3000) character(20) mission, instru, alias, chextno, cif_inst(arrsz), & cifinstval, cal_origin(arrsz), wherefrom character(500) message character(180) ciftmp character(160) inpfil, lclf, compf(arrsz), & special, calfiles(arrsz), infile character(20) inp_info(50) character(20) info character(300) contxt character(160) name(arrsz), lclfile(arrsz), compfile, filename character(160) path(arrsz), finalf3, localf, finalf, finalf2, & fext, fileandext(arrsz), calfexp, caldbpth, cif character(160) junkdir, fileval, dirval character(10) date, dat(arrsz), dates, udmode, trans(10) character(30) errstr, warnstr integer errstat, kunit, status, chatter, nospace, caldblen integer fcstln, nfiles, ncomm, lastslash, dirstr, ncalfiles, & flen, flen1, flen2, n, m, fl1, fl2, len, len1, length, lunit integer iy, id, imon, cifqual(arrsz), newcif_unit, oldcif_unit, & ext(arrsz), extno, extnum, qualval, cifrow, ntrans, & alias_unit, qualcoll double precision cifinstdat(arrsz), mjd, lmoddate(arrsz) logical there, agree, qual_switch, old_open, new_open, alias_open ! initialise character(40) taskname common /task/ taskname taskname = 'MUDCIF ' // version errstat = 0 nfiles = 0 ncalfiles = 0 ncomm = 0 ntrans = 0 iy = 0 id = 0 imon = 0 infile = ' ' fileval = ' ' dirval = ' ' ciftmp = ' ' do 5 n = 1, arrsz cif_inst(n) = ' ' compf(n) = ' ' calfiles(n) = ' ' name(n) = ' ' lclfile(n) = ' ' path(n) = ' ' fileandext(n) = ' ' dat(n) = ' ' ext(n) = 0 cifinstdat(n) = 0.0 lmoddate(n) = 0.0 cal_origin(n) = ' ' 5 continue do 6 n = 1, 10 trans(n) = ' ' 6 continue message = '** MUDCIF ' // version call fcecho(message) errstr = '** MUDCIF ' // version // ' ERROR: ' warnstr = '** MUDCIF ' // version // ' WARNING: ' ! Get the parameters from the par file call gparams(inpfil, calfexp, qual_switch, chatter, errstat) ! If there's an error getting parameters then return if (errstat .ne. 0) return ! see if the user has set the environment variable specified in the ! calfexp arguement call ctrlog(calfexp, fcstln(calfexp), caldbpth, caldblen) if (caldblen .eq. 0) then contxt = 'Environment variable not set' message = '**MUDCIF ' // version // ' ERROR : ' // contxt call fcecho(message) message = 'The environment variable or logical "'& // calfexp(:fcstln(calfexp)) // '"' call fcecho(message) message = 'must be set to point at the top of the Caldb' call fcecho(message) message = 'see the Caldb Users Guide for details' call fcecho(message) errstat = 2 return endif ! Open data/input.ASCII file call cgetlun(lunit) open (lunit, file = inpfil, iostat = errstat, status = 'OLD') if (errstat .ne. 0) then inquire (file = inpfil, exist = there) if (.not.there) then contxt = 'cant find ' // inpfil message = '**MUDCIF ' // version // 'ERROR : ' // contxt goto 10 endif contxt = ' can find but cant open ' // inpfil message = '**MUDCIF ' // version // ' ERROR : ' // contxt 10 continue call fcecho(message) status = 20 return endif 20 continue ! read the 4 lines of the input ASCII file containing names of mission, ! instrument, alias and 'special' ASCII file read (lunit, '(A)', iostat = errstat, end = 50) info if (errstat .ne. 0) then contxt = 'error reading ' // inpfil message = '**MUDCIF ' // version // ' ERROR : ' // contxt call fcecho(message) status = errstat return endif ! Skip any blank lines or lines beginning with '#' characters to obtain ! name of 'special' ASCII file if ((info(1:1).ne.'#').and.(fcstln(info).ne.0)) then nfiles = nfiles + 1 inp_info(nfiles) = info else goto 20 endif goto 20 50 continue if (nfiles .le. 3) then contxt = 'input ASCII file: ' // inpfil // ' empty !! ' message = '**MUDCIF ' // version // ' ERROR : ' // contxt call fcecho(message) status = -1 return endif ! Now get names of mission, instrument, alias and actual name of the 'special' file do 55 m = 1, nfiles special = inp_info(m) len = fcstln(special) len1 = len - 1 length = 0 nospace = 0 do 60 n = 0, len1 if (special(len - n:len - n) .ne.' ') then nospace = nospace + 1 if (nospace .eq. 1) length = len - n inp_info(m) = special(len - n:length) endif 60 continue 55 continue ! Open 'special' ASCII file inpfil = inp_info(nfiles) call cgetlun(kunit) open (kunit, file = inpfil, iostat = errstat, status = 'OLD') if (errstat .ne. 0) then inquire (file = inpfil, exist = there) if (.not.there) then contxt = 'cant find special ASCII file ' // inpfil message = '**MUDCIF ' // version // 'ERROR : ' // contxt goto 110 endif contxt = 'can find but cant open special ASCII file ' // inpfil message = '**MUDCIF ' // version // ' ERROR : ' // contxt 110 continue call fcecho(message) status = 20 return endif ! reset nfiles parameter nfiles = 0 100 continue ! get calibration files from 'special' ASCII file read (kunit, '(A)', iostat = errstat, end = 1000) lclf if (errstat .ne. 0) then contxt = 'error reading special ASCII file' message = '**MUDCIF ' // version // ' ERROR : ' // contxt call fcecho(message) status = errstat return endif ! Skip blank lines or lines beginning with '#' characters to obtain cal ! filenames[#ext] and cal date info (= last modification date) if ((lclf(1:1).ne.'#').and.(fcstln(lclf).ne.0)) then nfiles = nfiles + 1 filename = lclf(1:75) date = lclf(99:108) lclfile(nfiles) = filename dat(nfiles) = date else goto 100 endif goto 100 1000 continue if (nfiles .eq. 0) then contxt = 'special ASCII file: ' // inpfil // ' empty !! ' message = '**MUDCIF ' // version // ' ERROR : ' // contxt call fcecho(message) status = -1 return endif ! close the ASCII files close (kunit) call cfrelun(kunit) close (lunit) call cfrelun(lunit) ! Get calibration filenames from special ASCII file ! (**NB** all filenames contain '$CALDB' to represent the top of the ! caldb directory tree) do 1100 m = 1, nfiles localf = lclfile(m) dates = dat(m) ! strip off [#ext], write filename (including path) to 'compfile'. ! get actual ext no and convert to integer flen = fcstln(localf) compfile = ' ' flen1 = flen - 1 flen2 = 0 fl1 = 0 fl2 = 0 do 1150 n = 0, flen1 if (localf(flen - n:flen - n).eq.']') fl1 = flen - n if (localf(flen - n:flen - n).eq.'[') fl2 = flen - n - 1 1150 continue compfile = localf(1:fl2) chextno = localf(fl2 + 2:fl1 - 1) if (fcstln(chextno) .eq. 1) then read (chextno(1:1), fmt = '(I1)') extno else read (chextno(1:2), fmt = '(I2)') extno endif ext(m) = extno ! create COMPLETE filename using 'compfile' info and the environment variable ! specified in the calfexp arguement (NB strip off $CALDB characters first) compf(m) = caldbpth(:fcstln(caldbpth)) // localf(7:fl2) ! now strip filenames of their paths, write the actual filename ! to 'finalf2' and the path to 'finalf3' (ignoring the initial $CALDB/ ! characters). ! Then concatenate [#extn] onto filename finalf2 = ' ' finalf3 = ' ' flen = fcstln(compfile) lastslash = 0 dirstr = 0 flen1 = flen - 1 do 1200 n = 0, flen1 finalf = compfile(flen - n:flen) if (dirstr .eq. 1) then finalf3 = compfile(8:flen2 - 1) endif if (compfile(flen - n:flen - n).eq.'/') then lastslash = lastslash + 1 dirstr = 1 if (lastslash .eq. 1) then flen2 = flen - n finalf2 = compfile(flen - n + 1:flen) fext = localf(flen - n + 1:fl1) endif endif 1200 continue name(m) = finalf2 path(m) = finalf3 fileandext(m) = fext ! ! convert last modification date for each cal file into MJD - ! Parse date into day month and year call fts2dt(dates, iy, imon, id, errstat) if (errstat .ne. 0) then contxt = 'Unable to parse date argument: ' // & date(:fcstln(date)) endif ! Convert id, im, iy to modified julian date. New fitsio date functions ! guarantee 4-digit years, so call ccldj instead of ccaldj. call ccldj(iy, imon, id, mjd, errstat) if (errstat .ne. 0) then message = errstr // & 'ccldj: converting last mod date to MJD' call fcecho(message) return endif lmoddate(m) = mjd 1100 continue ! now check that the calibration files exist. do 1300 m = 1, nfiles inpfil = compf(m) inquire (file = inpfil, exist = there) if (.not.there) then contxt = 'cant find ' // inpfil message = '**MUDCIF ' // version // 'WARNING:'& // contxt call fcecho(message) endif 1300 continue ! get and read the caldb.config file mission = inp_info(1) instru = inp_info(3) alias = inp_info(3) ! NOTE : caldb_info calls the routine ..rdcnfg...where the instru argument ! MUST be the 'instrument alias' rather then the 'instrument' if ((calfexp(1:5).eq.'caldb').or.(calfexp(1:5).eq.'CALDB')) then call caldb_info(chatter, 'INST', mission, instru, errstat) if (errstat.ne.0) then message = 'CALDB not defined/available' call fcecho(message) message = 'task requires CALDB to be both defined ' // & '& available in order to run' call wt_ferrmsg(errstat, message) goto 999 endif errstat = 0 call rdcnfg(mission, alias, .false., calfexp, junkdir, errstat) if (errstat .ne. 0) return endif ! get the relevant CIF info and place in memory errstat = 0 call cifinfo(calfexp, arrsz, cif_inst, calfiles, cifinstdat, & cifqual, cal_origin, ncalfiles, chatter, errstat) if (errstat .ne. 0) return ! now do any relevant OVERWRITING to the CIF : ! ! First have to open the relevant CIF ('old') and a copy ('new') and also the ! alias_config.fits files. ! NOTE : opcifs calls the routine ...rdcaf1....where the instru argument ! MUST be the 'instrument' rather then the 'instrument alias'!! errstat = 0 instru = inp_info(2) call ftupch(instru) newcif_unit = 0 oldcif_unit = 0 alias_unit = 0 old_open = .false. new_open = .false. alias_open = .false. call opcifs(calfexp, old_open, new_open, alias_open, oldcif_unit, & newcif_unit, alias_unit, ciftmp, & mission, instru, trans, ntrans, chatter, errstat) if (errstat.ne. 0) return ! ok...here goes errstat = 0 m = 0 n = 0 do 1600 m = 1, ncalfiles wherefrom = cal_origin(m) if ((wherefrom(1:7) .eq. 'HEASARC') .or.& (wherefrom(1:7) .eq. ' ')) then agree = .false. do 1700 n = 1, nfiles ! for each row in the CIF compare the cal filename[#ext] ! with the cal filenames[#ext] (given in the ASCII file list) if (fileandext(n).eq.calfiles(m)) then agree = .true. ! now compare the last modification date of the cal file (given in the ! ASCII list) with its installation date in the CIF... if (lmoddate(n).gt.cifinstdat(m)) then ! in this case : ! the last modification date for the cal file in the ASCII file list ! is LATER than its installation date in the CIF, therefore must ! OVERWRITE the current line in the CIF to describe the more recently ! 'changed' dataset. ! if 'qualswitch' flag = .true. then it is assumed that this file is now ! `good' quality so must switch CAL_QUAL flag in CIF to 0 (good). ! if 'qualswitch' flag = .false. then do not assume the file is good and hence ! keep the quality status already set in CIF udmode = 'over' infile = compf(n) cif = calfexp extnum = ext(n) if (qual_switch .eqv. .true.) then qualval = 0 else qualval = cifqual(m) endif fileval = name(n) dirval = path(n) cifrow = m cifinstval = cif_inst(m) call mod_cif(chatter, infile, cif, & newcif_unit, udmode, trans, ntrans, & extnum, qualval, fileval, dirval, & cifrow, cifinstval, errstat) if (errstat .ne. 0) return endif ! in this case : ! the last modification date is EARLIER or the SAME as the installation date ! in the CIF....therefore do nothing endif 1700 continue if (agree .eqv. .false.) then ! there is a cal file present in the CIF which is NOT present in the ASCII file. ! if 'qualswitch' flag = .true. then it is assumed that this file is now 'bad' ! and so must change current line in CIF with CAL_QUAL switched to 5 (bad). ! if 'qualswitch' flag = .false. then do not assume file is bad and do nothing ! to CIF. if (qual_switch .eqv. .true.) then errstat = 0 call ftgcno(newcif_unit, .true., & 'CAL_QUAL', qualcoll, errstat) if (errstat .ne. 0) then message = errstr // 'Cannot find index file' & // 'column CAL_QUAL' call fcecho(message) return endif qualval = 5 cifrow = m call ftpclj(newcif_unit, qualcoll, & cifrow, 1, 1, qualval, errstat) if (errstat .ne. 0) return endif endif endif 1600 continue ! Close the relevant CIF ('old') and the copy ('new') and also the ! alias_config.fits file. call clcifs(calfexp, old_open, new_open, alias_open, oldcif_unit, & newcif_unit, alias_unit, ciftmp, chatter, errstat) if (errstat .ne. 0) return ! now do any necessary ADDITIONS to the CIF ! First have to open the relevant CIF ('old') and a copy ('new') and also the ! alias_config.fits files. errstat = 0 newcif_unit = 0 oldcif_unit = 0 alias_unit = 0 old_open = .false. new_open = .false. alias_open = .false. call opcifs(calfexp, old_open, new_open, alias_open, oldcif_unit, & newcif_unit, alias_unit, ciftmp, & mission, instru, trans, ntrans, chatter, errstat) if (errstat.ne. 0) return ! ok...here goes errstat = 0 do 1800 m = 1, nfiles agree = .false. do 1900 n = 1, ncalfiles ! for each cal filename[#ext] (given in the ASCII file list) , compare ! this to the cal filenames[#ext] in the rows of the CIF. if (fileandext(m).eq.calfiles(n)) then agree = .true. endif 1900 continue if (agree .eqv. .false.) then ! then there is a cal file present in the ASCII file and NOT in the CIF. ! this file must be a completely new good quality file and so must ADD ! this file to the CIF.. udmode = 'add' infile = compf(m) cif = calfexp extnum = ext(m) qualval = 0 fileval = name(m) dirval = path(m) cifrow = 0 cifinstval = cif_inst(n) call mod_cif(chatter, infile, cif, newcif_unit, & udmode, trans, ntrans, & extnum, qualval, fileval, dirval, & cifrow, cifinstval, errstat) if (errstat .ne. 0) return endif 1800 continue ! Close the relevant CIF ('old') and the copy ('new') and also the ! alias_config.fits file. call clcifs(calfexp, old_open, new_open, alias_open, oldcif_unit, & newcif_unit, alias_unit, ciftmp, chatter, errstat) if (errstat .ne. 0) return message = ' ' call fcecho(message) message = '** MUDCIF ' // version // ' finished **' call fcecho(message) return 999 continue end !----------End of MUDCIF subroutine----------------------------------- !----------------------------------------------------------------------- !+GPARAMS subroutine gparams(inpfil, calfexp, qual_switch, chatter, & status) implicit none character*(*) inpfil, calfexp integer status, chatter logical qual_switch ! Description: ! Gets the parameters for MUDCIF from the parameter ! file. ! ! passed parameters: ! CALFEXP : value of environment variable ! STATUS : error flg (0=OK) ! CHATTER : chattiness flag for o/p (5 low,10 normal,15 high) ! ! user i/ps (prompted for): ! INPFIL : the name of the input ASCII file (=input.ASCII). ! This file contains 4 lines : name of mission, name of ! instrument, name of instrument alias ! and name of a 'special' ASCII file. ! The 'special' ASCII file contains a list ! of 'good' quality calibration files appropriate ! for the given mission and instrument. ! ! Called routines : ! subroutine UGLGST : (XPI) gets parameter values from mudcif.par ! subroutine FCECHO : (FITSIO) write to standard o/p ! ! compilation & linking : ! link with XPI and FITSIO ! ! Origin: Written for the Calibration Database. ! ! Authors/Modification History: ! Lorraine Breedon (1.0.0:96 Aug 12) original version ! Lorraine Breedon (1.1.0:97 Jun 11) accounts for extra CIF column CAL_ORIGIN character(7) version parameter (version = '1.1.0') !- ! Internals character(50) contxt character(80) message integer errstat ! initialise ! Set Status flg to 'no problem!' status = 0 errstat = 0 ! Get inpfile parameter call uclgst('inpfile', inpfil, errstat) ! If there's an error getting inpfile, return if(errstat.ne.0)then contxt = 'cant get inpfile parameter' message = '**UCLGST ' // version // ' ERROR : ' // contxt call fcecho(message) status = 1 return endif ! Get calfexp parameter call uclgst('calfexp', calfexp, errstat) ! If there's an error getting calfexp, return if(errstat.ne.0) then contxt = 'cant get calfexp parameter' message = '**UCLGST ' // version // ' ERROR : ' // contxt call fcecho(message) status = 1 return endif ! Get qualswitch parameter call uclgsb('qualswitch', qual_switch, errstat) ! If there's an error getting qualswitch, return if(errstat.ne.0) then contxt = 'cant get qual_switch parameter' message = '**UCLGST ' // version // ' ERROR : ' // contxt call fcecho(message) status = 1 return endif ! Get the chatter parameter call uclgsi('chatter', chatter, errstat) if(errstat.ne.0)then contxt = 'cant get chatter parameter' message = '**UCLGST ' // version // ' ERROR : ' // contxt call fcecho(message) chatter = 9 message = ' setting chatter=9' call fcecho(message) status = 0 endif return end !-----------------------end of GPARAMS subroutine---------------------- !--------------------------------------------------------------------- !+CIFINFO subroutine cifinfo(calf, size, cif_instval, namesext, inst_date, & cif_quality, origin, nrows, chatter, status) implicit none integer size character*(*) calf, namesext(size), cif_instval(size), origin(size) integer status, chatter, nrows, cif_quality(size) double precision inst_date(size) ! Description: ! opens a CIF (appropriate for a given mission and instrument). ! reads appropriate column info and places in memory ! passed parameters: ! CALFEXP : value of environment variable ! STATUS : error flg (0=OK) ! CHATTER : chattiness flag for o/p (5 low,10 normal,15 high) ! NROWS(o/p) : the number of rows in the CIF ! CIF_INSTVAL(o/p) : array containing info from CIF column INSTRUME ! NAMESEXT(o/p) : array containing info from CIF columns CAL_FILE and ! CAL_XNO i.e. cal filename with extn number ! concatenated ! INST_DATE(o/p) : array containing info from CIF column CAL_DATE ! CIF_QUALITY(o/p) : array containing info from CIF column CAL_QUAL ! ORIGIN(o/p) : array containing info from CIF column CAL_ORIG ! ! user i/ps (prompted for): ! none ! ! Called routines : ! subroutine FCECHO : (FITSIO) write to STDOUT ! subroutine CGETLUN : (CALLIB) get free FORTRAN logical unit no ! subroutine WT_FERRMSG : (CALLIB) dumps error messages if necessary ! subroutine FTOPEN : (FITSIO) opens CIF ! subroutine FTMAHD : (FITSIO) moves to 1st extension in FITS file ! subroutine FTGKYJ : (FITSIO) determines no. rows in CIF ! subroutine FTGCNO : (FITSIO) gets column nos of all columns to be read ! subroutine FTGCVS : (FITSIO) gets cal file name, instrument values from C CIF ! subroutine FTGCVJ : (FITSIO) gets extn numbers from CIF ! compilation & linking : ! link with XPI, FITSIO & CALLIB ! ! Origin: Written for the Calibration Database. ! ! Authors/Modification History: ! Lorraine Breedon (1.0.0:96 Oct 11) original version ! Lorraine Breedon (1.1.0:97 Jun 11) accounts for extra CIF column CAL_ORIGIN character(7) version parameter (version = '1.1.0') !- ! Internals character(1) chextno1, bracket1, bracket2 character(2) chextno2 character(10) instdate character(20) cal_orig character(30) sjunk, errstr, wrnstr, instrument character(160) file, calfile, calfile1, calfile2, & calfile3 character(200) message integer iunit, ijunk, nax2val, fcstln, errstat, nn, i, extno integer filcol, datcol, xnocol, len, len1, id, iy, imon, flen2 integer lencal, instcol, qualcol, cal_qual, origcol double precision mjd logical ljunk, origin_flag ! initialise and set up defaults origin_flag = .true. file = ' ' calfile = ' ' calfile1 = ' ' calfile2 = ' ' calfile3 = ' ' errstat = 0 status = 0 len = 0 len1 = 0 flen2 = 0 i = 0 id = 0 imon = 0 iy = 0 do 25 i = 1, size inst_date(i) = 0.0 namesext(i) = ' ' cif_instval(i) = ' ' cif_quality(i) = 0 origin(i) = ' ' 25 continue errstr = '** CIFINFO ' // version // 'ERROR: ' wrnstr = '** CIFINFO ' // version // 'WARNING: ' ! Open the CIF call cgetlun(iunit) call ftopen(iunit, calf, 1, ijunk, errstat) if(errstat.ne.0)then message = errstr // ' opening the CIF' call wt_ferrmsg(errstat, message) status = errstat return endif ! Move to the first extension call ftmahd(iunit, 2, ijunk, errstat) if(errstat.ne.0)then message = errstr // ' moving to 1st extension' call wt_ferrmsg(errstat, message) status = errstat return endif ! Find out how many rows the CIF contains call ftgkyj(iunit, 'NAXIS2', nax2val, sjunk, errstat) if(nax2val.eq.0)then status = errstat return endif ! Get the column numbers of all the columns to be read call ftgcno(iunit, .true., 'INSTRUME', instcol, errstat) if(errstat.ne.0)then message = errstr // ' getting INSTRUME column number ' call wt_ferrmsg(errstat, message) status = errstat return endif call ftgcno(iunit, .true., 'CAL_FILE', filcol, errstat) if(errstat.ne.0)then message = errstr // ' getting CAL_FILE column number ' call wt_ferrmsg(errstat, message) status = errstat return endif call ftgcno(iunit, .true., 'CAL_XNO', xnocol, errstat) if(errstat.ne.0)then message = errstr // ' getting CAL_XNO column number ' call wt_ferrmsg(errstat, message) status = errstat return endif call ftgcno(iunit, .true., 'CAL_DATE', datcol, errstat) if(errstat.ne.0)then message = errstr // ' getting CAL_DATE column number ' call wt_ferrmsg(errstat, message) status = errstat return endif call ftgcno(iunit, .true., 'CAL_QUAL', qualcol, errstat) if(errstat.ne.0)then message = errstr // ' getting CAL_QUAL column number' call wt_ferrmsg(errstat, message) status = errstat return endif call ftgcno(iunit, .true., 'CAL_ORIG', origcol, errstat) if(errstat.ne.0)then message = wrnstr // ' getting CAL_ORIG column number' call fcecho(message) origin_flag = .false. endif ! Read required info from each row nrows = nax2val do 100 i = 1, nax2val errstat = 0 ! get instrument value call ftgcvs(iunit, instcol, i, 1, 1, ' ', instrument, ljunk, & errstat) if (errstat .ne. 0) then message = errstr // ' getting instrument value ' call wt_ferrmsg(errstat, message) status = errstat return endif ! Get filename value call ftgcvs(iunit, filcol, i, 1, 1, ' ', file, ljunk, errstat) if (errstat .ne. 0) then message = errstr // ' getting cal file name ' call wt_ferrmsg(errstat, message) status = errstat return endif ! Get cal filename in the CIF independant of path len = fcstln(file) len1 = len - 1 do 120 nn = 0, len1 if (file(len - nn:len - nn).eq.'/') goto 150 calfile = file(len - nn:len) 120 continue 150 continue ! Get ext number call ftgcvj(iunit, xnocol, i, 1, 1, 0, extno, ljunk, errstat) if (errstat .ne. 0) then message = errstr // ' getting extension number ' call wt_ferrmsg(errstat, message) status = errstat return endif ! Concatenate [#ext] onto cal filename lencal = fcstln(calfile) bracket1 = '[' bracket2 = ']' if (extno .lt. 10) then write (chextno1, fmt = '(I1)') extno calfile1 = calfile(1:lencal) // bracket1 calfile2 = calfile1(1:lencal + 1) // chextno1 calfile3 = calfile2(1:lencal + 2) // bracket2 else write (chextno2, fmt = '(I2)') extno if (extno .le. 99) then calfile1 = calfile(1:lencal) // bracket1 calfile2 = calfile1(1:lencal + 1) // chextno2 calfile3 = calfile2(1:lencal + 3) // bracket2 else message = errstr // calfile call fcecho(message) message = 'extension number greater than 99!' call fcecho(message) status = 1 return endif endif ! Get installation date call ftgcvs(iunit, datcol, i, 1, 1, ' ', instdate, ljunk, errstat) if (errstat .ne. 0) then message = errstr // ' getting installation date ' call wt_ferrmsg(errstat, message) status = errstat return endif ! convert installation date into MJD- ! Parse date into day month and year call fts2dt(instdate, iy, imon, id, errstat) if (errstat .ne. 0) then message = 'Unable to parse date argument: ' // & instdate(:fcstln(instdate)) call fcecho(message) endif ! Convert id, im, iy to modified julian date. New fitsio date functions ! guarantee 4-digit years, so call ccldj instead of ccaldj. call ccldj(iy, imon, id, mjd, errstat) if (errstat .ne. 0) then message = errstr // & 'ccldj: converting last mod date to MJD' call fcecho(message) return endif ! get quality value call ftgcvj(iunit, qualcol, i, 1, 1, 0, cal_qual, ljunk, errstat) if (errstat .ne. 0) then message = errstr // ' getting quality value ' call wt_ferrmsg(errstat, message) status = errstat return endif if (origin_flag .eqv. .true.) then ! get origin value call ftgcvs(iunit, origcol, i, 1, 1, ' ', cal_orig, ljunk, & errstat) if (errstat .ne. 0) then message = errstr // ' getting CAL_ORIGIN value ' call wt_ferrmsg(errstat, message) status = errstat return else origin(i) = cal_orig endif endif ! write info read from CIF into memory cif_instval(i) = instrument namesext(i) = calfile3 inst_date(i) = mjd cif_quality(i) = cal_qual 100 continue ! close the CIF call ftclos(iunit, errstat) if (errstat .ne. 0) then status = errstat else call cfrelun(iunit) endif return 999 continue end !--------------------End of CIFINFO subroutine-------------------------- !--------------------------------------------------------------------- !+MOD_CIF subroutine mod_cif(chatter, infile, cif, ounit, udmode, trans, & ntrans, extnum, qualval, & fileval, dirval, cifrow, cifinstval, ierr) implicit none character*(*) infile, cif, udmode, fileval, dirval, & cifinstval, trans(10) integer ierr, chatter, cifrow, qualval, extnum, ounit, ntrans !----------------------------------------------------------------------- ! Description: Accesses the cal file, infile, and searches for OGIP Caldb ! cal datasets in the appropriate CIF. ! ** NB ** ! udmode ='over' option is for a cal file already listed in CIF. ! udmode ='add' option is for a cal file NOT listed in the CIF. ! ********* ! If udmode='over' the row in the CIF containing infile ! is OVERWRITTEN with the keyword values from the header of the ! latest version of infile. ! If udmode='add' then a new row (1 for each INSTRUME alias) is ! ADDED to the end of the CIF. These rows contain the keyword ! values from the header of the new cal file, infile. ! ! *** This is a variant of the routine UPDCIF ***** ! Arguments: infile (i): the full name (including path up to the top ! of the CALDB directory tree) of the FITS file ! containing a Calibration dataset. ! cif (i): the name of the Calibration Index File ! ounit (i): logical unit no for CIF ! udmode (i): update mode required ! trans (i): array containing the 'alias' values for instrument ! ntrans (i): number of 'alias' values ! fileval (i): the file name (only) of the FITS file ! dirval (i): the directory path (data/{mission}/{instrument}/..) ! of the FITS file. ! extnum (i): the extension (data set) of the FITS file. ! qualval (i): the quality value of the data set (default=0;good) ! cifrow (i): the row in the CIF to be OVERWRITTEN if ! udmode option ='over'. If udmode option = 'add' ! then cifrow is set to 0 since the new row number(s) ! at the end of the CIF will be determined later. ! ! Origin: Written for the OGIP Calibration Database ! ! Authors/Modification History: ! Ron Zellar (1.0.0: 1993 Jun 09) Original version ! Ron Zellar (2.0.0: 1994 Aug 08) Added envar variable for cgdr ! Ian M George (3.0.0: 1996 Feb 06) Redesign to include udmode options ! Lorraine Breedon (3.0.1: 1996 Nov 01) Redesigned to parse more parameters: ! infile (the FULL name); fileval; ! dirval;extnum;qualval;cifrow;ounit; ! trans; ntrans. ! Since extnum parsed directly,cal file ! 'extension search' commented out. ! Udmode options written. ! Code dealing with the opening and ! closing of CIFS (`old' and 'new' ! cif.tmp ) and the alias_config.fits ! ripped out and placed into 2 new ! subroutines (OPCIFS.f & CLCIFS.f) ! ! ** Renamed from UPDCIF to MOD_DIF ** ! OPCIFS.f & CLCIFS.f are called before ! and after MOD_CIF respectively. ! Lorraine Breedon (3.0.2: 1997 Jun 11) now accounts for extra CIF column ! CAL_ORIGIN ! Lorraine Breedon (3.1.2: 1998 Aug 20) y2k compliance changes ! Jeff Guerber (3.1.3 1999-02-23) can't call ftgstm with const arg ! character(7) version parameter (version = '3.1.3') !----------------------------------------------------------------------- !- ! Internals character(7) subname parameter (subname = 'mod_cif') character(80) comment, cclsval character(160) context integer fillen, fcstln, errstat, hdutype, iunit integer telecol, instcol, filtcol, devcol, dircol, detcol integer filecol, cbdcol, xnocol, bunit integer refcol, qualcol, datecol, cdescol integer oldrows, newrows integer blcksz, extval, i integer cclscol, cdtpcol, ccnmcol, cvsdcol, cvstcol, row, origcol ! width,size character(10) televal, instval, cvsdatval, cvsdval, date character(4) cdtpval, cval character(20) ccnmval, filtval, detval, devval character(8) cvstval character(70) cdesval, cbdval(9) double precision reftime, second logical exact, iopen, result logical modcif ! character(10) envar integer match ! character(80) dmystr integer iyear, imon, iday, ihour, imin, decimals, utmode character(30) timestr character(160) message ! Initialize the variables ! L.B. (Nov 01 1996) ...comment out extnum ! extnum = 0 iopen = .false. modcif = .false. oldrows = 0 newrows = 0 iunit = 0 bunit = 0 iyear = 0 imon = 0 iday = 0 ihour = 0 imin = 0 second = 0.0 decimals = 0 utmode = 0 ! Get the units call cgetlun(iunit) ! Get length of the cal filename fillen = fcstln(infile) ! type *, ' ** in mod_cif.f **' ! type *, 'infile=',infile ! Open the calibration file call ftopen(iunit, infile(:fillen), 0, blcksz, errstat) If (errstat .ne. 0) then context = 'Cannot open the input file: ' // & infile(:fillen) call wtferr(subname, version, errstat, context) ierr = 1 goto 999 else iopen = .true. endif ! ------ cal file extension search----- ! L.B. (Nov 01 1996) ...comment out loop (via 1000 continuation statement) !1000 continue errstat = 0 ! keep track of the extension number extnum = extnum + 1 extval = extnum - 1 ! move to the extension given by extnum call ftmahd(iunit, extnum, hdutype, errstat) ! If errstat does not = 0, then end of file if (errstat .ne. 0) then if (modcif) goto 9000 context = 'No datasets indexed' call wtwarm(subname, version, chatter, 1, context) goto 999 endif ! Look in the cal file for the CCLS0001 keyword call ftgkys(iunit, 'CCLS0001', cclsval, comment, errstat) ! if (errstat .ne. 0) goto 1000 ! Get the required calibration keywords call ftgkys(iunit, 'CCNM0001', ccnmval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading CCNM0001 keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 else context = 'Dataset Code :' // ccnmval call wtinfo(chatter, 1, 1, context) endif call ftgkys(iunit, 'TELESCOP', televal, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading TELESCOP keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif call ftgkys(iunit, 'INSTRUME', instval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading INSTRUME keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif call ftgkys(iunit, 'CDTP0001', cdtpval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading CDTP0001 keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif call ftgkys(iunit, 'CVSD0001', cvsdatval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading CVSD0001 keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif if (fcstln(cvsdatval) .ne. 10) then message = 'WARNING: CVSD0001 keyword in calibration' // & ' file is in dd/mm/yy format' call fcecho(message) message = 'WARNING: this date will be written in' // & ' yyyy-mm-dd format in the caldb.indx file ' call fcecho(message) call fts2dt(cvsdatval, iyear, imon, iday, errstat) if (errstat .ne. 0) then message = 'problem in fts2dt ' call fcecho(message) endif call fttm2s(iyear, imon, iday, ihour, & imin, second, decimals, cvsdatval, errstat) if (errstat .ne. 0) then message = 'problem in fttm2s ' call fcecho(message) endif endif cvsdval = cvsdatval(1:10) call ftgkys(iunit, 'CVST0001', cvstval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading CVST0001 keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif ! Calculate the reference time for input into the ! REF_TIME column call calcrt(cvsdatval, cvstval, reftime, errstat) if (errstat .ne. 0) then write(cval, '(I4)')extval context = 'Error calculating the REF_TIME value' // & ' in extension:' // cval call wterrm(subname, version, context) ! goto 1000 endif call ftgkys(iunit, 'CDES0001', cdesval, comment, errstat) if (errstat .ne. 0) then write(context, '(a,i4)')& 'Problem reading CDES0001 keyword in ext: ', & extnum call wtwarm(subname, version, chatter, 1, context) call wtinfo(chatter, 1, 2, 'skipping extension') ! goto 1000 endif ! Get the non-required keywords call ftgkys(iunit, 'FILTER', filtval, comment, errstat) if (errstat .ne. 0) filtval = 'NONE' errstat = 0 call ftgkys(iunit, 'DETNAM', detval, comment, errstat) if (errstat .ne. 0) detval = 'NONE' errstat = 0 ! Get all the CBDnxxxx keywords call ftgkys(iunit, 'CBD10001', cbdval(1), comment, errstat) if (errstat .ne. 0) cbdval(1) = 'NONE' call ftgkys(iunit, 'CBD20001', cbdval(2), comment, errstat) if (errstat .ne. 0) cbdval(2) = 'NONE' call ftgkys(iunit, 'CBD30001', cbdval(3), comment, errstat) if (errstat .ne. 0) cbdval(3) = 'NONE' call ftgkys(iunit, 'CBD40001', cbdval(4), comment, errstat) if (errstat .ne. 0) cbdval(4) = 'NONE' call ftgkys(iunit, 'CBD50001', cbdval(5), comment, errstat) if (errstat .ne. 0) cbdval(5) = 'NONE' call ftgkys(iunit, 'CBD60001', cbdval(6), comment, errstat) if (errstat .ne. 0) cbdval(6) = 'NONE' call ftgkys(iunit, 'CBD70001', cbdval(7), comment, errstat) if (errstat .ne. 0) cbdval(7) = 'NONE' call ftgkys(iunit, 'CBD80001', cbdval(8), comment, errstat) if (errstat .ne. 0) cbdval(8) = 'NONE' call ftgkys(iunit, 'CBD90001', cbdval(9), comment, errstat) if (errstat .ne. 0) cbdval(9) = 'NONE' errstat = 0 ! L.B. remove any `blanks' in CBD keyword values so as not to cock-uo ! ckcbd routine. do i = 1, 9 call crmvblk(cbdval(i)) end do ! Check the CBD values to see if the format is readable call ckcbd(cbdval, result) if (.not. result) then context = 'Cannot read the CBD values for this dataset' call wterrm(subname, version, context) ! goto 1000 endif ! L.B. (Nov 01 1996) ...comment out any previous UPDCIF code for fileval;dirval ! qualval. ! Assign input file name to variable written to CIF ! fileval = infile ! Get dir part of system independent specification for the ! current working directory ! call cgdr(envar,dirval,errstat) ! if (errstat .ne. 0) then ! context='Cannot get directory from CGDR' ! call wterrm(subname, version, context) ! ierr = 1 ! goto 999 ! endif ! Use the CAL_DEV column to store the online/offline info ! Since this dataset must be online for me to access it ! write 'ONLINE' to the CAL_DEV column. devval = 'ONLINE' ! Get the system date ! call gtdats(dd,mm,yy,date) ! new FITS standard date call ftgstm(timestr, utmode, errstat) date = timestr(1:10) ! Get the quality value for this dataset ! call uclgsi('quality',qualval,errstat) ! if (errstat .ne. 0) then ! context = 'Cannot get quality parameter' ! call wterrm(subname,version,context) ! goto 1000 ! endif ! .......... Get the column numbers from the index file exact = .true. call ftgcno(ounit, exact, 'TELESCOP', telecol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column TELESCOP' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'INSTRUME', instcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column INSTRUME' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'DETNAM', detcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column DETNAM' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'FILTER', filtcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column FILTER' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_DEV', devcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_DEV' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_DIR', dircol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_DIR' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_FILE', filecol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_FILE' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_CLAS', cclscol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_CLAS' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_DTYP', cdtpcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_DTYP' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_CNAM', ccnmcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_CNAM' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_CBD', cbdcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_CBD' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_XNO', xnocol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_XNO' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_VSD', cvsdcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_VSD' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_VST', cvstcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_VST' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'REF_TIME', refcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column REF_TIME' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_QUAL', qualcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_QUAL' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_DATE', datecol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_DATE' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_DESC', cdescol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_DESC' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftgcno(ounit, exact, 'CAL_ORIG', origcol, errstat) if (errstat .ne. 0) then context = 'Cannot find index file column CAL_ORIG' call wterrm(subname, version, context) ierr = 1 goto 999 endif ! .......... Get the number of rows in the cif call ftgkyj(ounit, 'NAXIS2', oldrows, comment, errstat) if (errstat .ne. 0) then context = 'Cannot get NAXIS2 from back-up CIF' call wterrm(subname, version, context) ierr = 1 goto 999 endif ! endif ! L.B. (Nov 01 1996) ...udmode options written ! UDMODE = ADD if ((udmode.eq.'ADD').OR.(udmode.eq.'add')) then ! Make a new entry in the "back-up" index file containing the keyword ! values gotten above - one entry for each alias (if any) of the ! instval. match = 0 do i = 1, ntrans ! make 1 entry for a cal file with INSTRUME value = a particular alias if (trans(i).eq.instval(:fcstln(instval))) then ! instval = trans(i) newrows = newrows + 1 row = newrows + oldrows call wtcif2(chatter, ounit, row, udmode, telecol, televal, & instcol, & instval, detcol, detval, filtcol, filtval, devcol, devval, & dircol, dirval, filecol, fileval, cclscol, cclsval, cdtpcol, & cdtpval, ccnmcol, ccnmval, cbdcol, cbdval, xnocol, extval, & cvsdcol, cvsdval, cvstcol, cvstval, refcol, reftime, qualcol, & qualval, datecol, date, cdescol, cdesval, origcol, errstat) if(errstat .ne. 0) then ! context='punting for '//instval ! call wterrm(subname,version,context) errstat = 0 newrows = newrows - 1 row = row - 1 else modcif = .true. match = 1 endif endif enddo ! make one entry for each alias if cal file INSTRUME value is the instrument do i = 1, ntrans if (match .eq. 0) then instval = trans(i) newrows = newrows + 1 row = newrows + oldrows call wtcif2(chatter, ounit, row, udmode, telecol, televal, & instcol, & instval, detcol, detval, filtcol, filtval, devcol, devval, & dircol, dirval, filecol, fileval, cclscol, cclsval, cdtpcol, & cdtpval, ccnmcol, ccnmval, cbdcol, cbdval, xnocol, extval, & cvsdcol, cvsdval, cvstcol, cvstval, refcol, reftime, qualcol, & qualval, datecol, date, cdescol, cdesval, origcol, errstat) if(errstat .ne. 0) then ! context='punting for '//instval ! call wterrm(subname,version,context) errstat = 0 newrows = newrows - 1 row = row - 1 else modcif = .true. endif endif enddo ! UDMODE = OVERWRITE ! overwrite the row in the 'back-up' CIF elseif ((udmode.eq.'OVER').OR.(udmode.eq.'over')) then row = cifrow match = 0 do i = 1, ntrans if (trans(i).eq.cifinstval(:fcstln(cifinstval))) then instval = trans(i) match = 1 ! type *, 'OK OVERWRITING NOW *...entering wtcif2**' call wtcif2(chatter, ounit, row, udmode, telecol, & televal, instcol, instval, detcol, & detval, filtcol, filtval, devcol, devval, & dircol, dirval, filecol, fileval, cclscol, & cclsval, cdtpcol, cdtpval, ccnmcol, ccnmval, & cbdcol, cbdval, xnocol, extval, & cvsdcol, cvsdval, cvstcol, cvstval, refcol, & reftime, qualcol, qualval, datecol, date, cdescol, & cdesval, origcol, errstat) if(errstat .ne. 0) then errstat = 0 else modcif = .true. endif endif enddo if (match .eq. 0) then context = 'no match found in CIF for ' // instval call wterrm(subname, version, context) ierr = 1 goto 999 endif ! UDMODE = DELETE ! ........ Delete else call wterrm(subname, version, 'Unsupported UDMODE') ierr = 1 goto 999 endif ! Search for the next dataset ! L.B. (Nov 01 1996) ...comment out loop (via 1000 continuation statement) ! goto 1000 ! ------ Bottom of extension searching loop ------- 9000 continue ! close the calibration file errstat = 0 call ftclos(iunit, errstat) if (errstat .ne. 0) then context = 'Cannot close calibration file: '& // infile(:fillen) call wtferr(subname, version, errstat, context) else call cfrelun(iunit) iopen = .false. endif 999 if(ierr.ne.0) then context = 'Unable to continue ' // & ' -- attempting to shut down & clean up' call wtinfo(chatter, 1, 1, context) errstat = 0 endif ! close the calibration file if (iopen) then call ftclos(iunit, errstat) if (errstat .ne. 0) then context = 'Cannot close calibration file: ' // & infile(:fillen) call wtferr(subname, version, errstat, context) errstat = 0 endif call cfrelun(iunit) iopen = .false. endif return end !-------End of subroutine UPDCIF---------------------------------------- !+WTCIF2 subroutine wtcif2(chatter, ounit, row, udmode, telecol, televal, & instcol, instval, detcol, detval, & filtcol, filtval, devcol, devval, dircol, dirval, filecol, fileval, & cclscol, cclsval, cdtpcol, cdtpval, ccnmcol, ccnmval, cbdcol, cbdval, & xnocol, extval, cvsdcol, cvsdval, cvstcol, cvstval, refcol, reftime, & qualcol, qualval, datecol, date, cdescol, cdesval, origcol, status) implicit none integer ounit, row, status integer extval, qualval, chatter double precision reftime character*(*)televal, instval, detval, filtval, devval, dirval, & fileval, cclsval, cdtpval, ccnmval, cbdval(9), cvsdval, cvstval, date, & cdesval, udmode integer telecol, instcol, detcol, filtcol, devcol, dircol, filecol, & cclscol, cdtpcol, ccnmcol, cbdcol, xnocol, cvsdcol, cvstcol, refcol, & qualcol, datecol, cdescol, origcol logical check ! Description: ! Writes Calibration Index File row to the file opened unit ounit to the ! row given by 'row'. ! ! Arguments: ounit (i) : the logical unit number for the cif ! row (i) : the row number where data will be written ! errstat (r) : the success status of this routine ! ... fill in rest, Ron .... ! ! Origin: written for the caldb ! ! Authors/Modification History ! Ron Zellar (1.0.0: 93 Oct 01) Original version ! Ron Zellar (2.0.0: 94 May 24) Modified ckcif call to include ! cbd values ! Ron Zellar (2.1.0: 94 May 25) Added error checking ! Ian M George (3.0.0: 96 Feb 12) added chatter + cosmetics ! Lorraine Breedon (1.0.0: 96 Nov 01) extra parameter 'udmode' parsed ! + 'check' option added. ! ** Renamed from WTCIFR to WTCIF2 ** ! Lorraine Breedon (1.1.0: 97 Jun 11) now accounts for extra CIF column ! CAL_ORIG character(7) version parameter(version = '1.1.0') !- ! Internals character(6) subname parameter (subname = 'wtcif2') integer nrows, errstat, width, size character(80) context, comment character(20) origval ! Initialize errstat = 0 status = 0 check = .false. ! Give user info if requested context = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, context) write(context, '(a,i12)') 'attempting to write CIF row ', row call wtinfo(chatter, 20, 3, context) ! If quality = 0, check the other entries to make sure that ! there are no conflicting datasets if ((udmode .eq. 'ADD') .or. (udmode .eq. 'add')) then if (qualval .eq. 0) then if (check .eqv. .true.) then nrows = row - 1 call ckcif2(chatter, ounit, nrows, telecol, televal, instcol, & instval, refcol, reftime, ccnmcol, & ccnmval, qualcol, qualval, filtcol, & filtval, detcol, detval, cbdcol, cbdval, filecol, cdescol, & errstat) if (errstat .ne. 0) then status = 1 context = 'Current dataset not written to CIF' call wterrm(subname, version, context) goto 888 endif endif endif endif ! make necessary fitsio calls to add the data errstat = 0 origval = 'HEASARC' call ftpcls(ounit, telecol, row, 1, 1, televal, errstat) call ftpcls(ounit, instcol, row, 1, 1, instval, errstat) call ftpcls(ounit, detcol, row, 1, 1, detval, errstat) call ftpcls(ounit, filtcol, row, 1, 1, filtval, errstat) call ftpcls(ounit, devcol, row, 1, 1, devval, errstat) call ftpcls(ounit, dircol, row, 1, 1, dirval, errstat) call ftpcls(ounit, filecol, row, 1, 1, fileval, errstat) call ftpcls(ounit, cclscol, row, 1, 1, cclsval, errstat) call ftpcls(ounit, cdtpcol, row, 1, 1, cdtpval, errstat) call ftpcls(ounit, ccnmcol, row, 1, 1, ccnmval, errstat) call ftpcls(ounit, cbdcol, row, 1, 9, cbdval, errstat) call ftpclj(ounit, xnocol, row, 1, 1, extval, errstat) call ftpcls(ounit, cvsdcol, row, 1, 1, cvsdval, errstat) call ftpcls(ounit, cvstcol, row, 1, 1, cvstval, errstat) call ftpcld(ounit, refcol, row, 1, 1, reftime, errstat) call ftpclj(ounit, qualcol, row, 1, 1, qualval, errstat) call ftpcls(ounit, datecol, row, 1, 1, date, errstat) call ftpcls(ounit, cdescol, row, 1, 1, cdesval, errstat) call ftpcls(ounit, origcol, row, 1, 1, origval, errstat) if (errstat .ne. 0) then call wtferr(subname, version, errstat, & 'Error writing CIF entry') status = 1 goto 888 else if ((udmode .eq. 'ADD') .or. (udmode .eq. 'add')) then call ftmkyj(ounit, 'NAXIS2', row, '&',errstat) call ftgkyj(ounit, 'NAXIS1', width, comment, errstat) size = width * row call ftddef(ounit, size, errstat) endif endif 888 if(status.NE.0) then call wterrm(subname, version, 'Aborting') else context = subname // ' ' // version // ' successful' call wtinfo(chatter, 20, 3, context) endif return end ! ----------------------------------------------------- !+CKCIF2 subroutine ckcif2(chatter, lun, nrows, telecol, televal, instcol, & instval, & refcol, reftime, ccnmcol, ccnmval, qualcol, qualval, filtcol, filtval, & detcol, detval, cbdcol, cbdval, filecol, descol, status) implicit none integer lun, nrows, telecol, instcol, refcol, ccnmcol, qualcol, qualval integer filtcol, detcol, filecol, descol, cbdcol, status, chatter character*(*) televal, instval, filtval character*(*) ccnmval, detval character*(*) cbdval(9) double precision reftime !----------------------------------------------------------------------- ! Description: Examines the first nrows of a CIF for rows which have the ! quality value qualval and which contain the values ! televal, instval, ccnmval, reftime, filtval, detval and ! the values cbdval. If a row which ! meets these criteria is found then the user is asked to ! input a different quality value for the row which is ! found or for the row being added. If he or she chooses ! to change the quality value of the row being added, this ! new quality value is returned to qualval provided it is ! not the same as the original value. If he or she ! chooses to change the quality value in the row which was ! found, this subroutine will overwrite that row's quality ! value provided the new value is different from the old ! value. If the quality value being edited is not ! different from it's original value, the user will be ! reprompted. ! ! Arguments: lun (i) : The logical unit number for the CIF ! nrows (i) : The number of rows in the CIF excluding ! the row about to be added ! telecol (i) : the col number of the TELESCOP col ! televal (i) : the TELESCOP col value ! instcol (i) : the col number of the INSTRUME col ! instval (i) : the INSTRUME col value ! refcol (i) : the col number of the REF_TIME col ! reftime (i) : the REF_TIME col value ! ccnmcol (i) : the col number of the CAL_CNAM col ! ccnmval (i) : the CAL_CNAM col value ! qualcol (i) : the col number of the CAL_QUAL col ! qualval (r) : the quality value ! filtcol (i) : the col number of the FILTER col ! filtval (i) : the FILTER col value ! detcol (i) : the col number of the DETNAM col ! detval (i) : the DETNAM col value ! cbdcol (i) : the col number of the CAL_CBD col ! cbdval (i) : the CAL_CBD col values ! filecol (i) : the col number of the CAL_FILE col ! descol (i) : the col number of the CAL_DESC col ! ! Origin: Written for the Caldb ! ! Authors/Modification History: ! Ron Zellar (1.0.0: 93 Oct 02) Original Version ! Ron Zellar (1.1.0: 94 May 23) Added FILTER and DETNAM search ! Ron Zellar (1.2.0: 94 May 24) Added CBD search, cmpcbd call ! Ron Zellar (1.3.0: 94 May 25) Added error checking and improved comments ! Ron Zellar (2.0.0: 94 Jun 13) Modified fcecho text and if blocks so that ! single good quality entry is no longer required ! Ian M George (3.0.0: 96 Feb 12) Added chatter, plus cosmetics ! Ian M George (3.0.1: 96 Sep 12) made following parameters character*(*) - ! televal,instval,filtval, ccnmval,detval ! Lorraine Breedon (1.0.0: 96 Nov 01) commented out XPI calls when there is ! a 'conflicting' dataset. ! ** renamed from CKCIF to CKCIF2 ** ! character(7) version parameter (version = '3.0.1') !----------------------------------------------------------------------- !- ! Internals character(7) subname parameter (subname = 'ckcif2') integer qval, errstat, i character(10) tval, ival, fval character(20) cval, dval character(40) file character(80) desc, bval(9), context character(256) text double precision rval logical anyf, result integer pmatch(1) logical valtest(1), unitstest(1) ! Initialize: pmatch(1) = 0 valtest(1) = .false. unitstest(1) = .false. ! Give user info if requested context = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, context) ! ------------------------ Start Main Loop ------------------------ Do 5000 i = 1, nrows ! ..... Get quality value from CIF and compare to qual value of dataset call ftgcvj(lun, qualcol, i, 1, 1, 0, qval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get QUALITY info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (qval .eq. qualval) then ! ....... Get codename value from CIF and compare to codename value of dataset call ftgcvs(lun, ccnmcol, i, 1, 1, ' ', cval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get CODENAME info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (cval .eq. ccnmval) then ! ......... Get instrument value from CIF and compare to that in dataset call ftgcvs(lun, instcol, i, 1, 1, ' ', ival, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get INSTRUME info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (ival .eq. instval) then ! ........... Get telescope value from CIF and compare to that in dataset call ftgcvs(lun, telecol, i, 1, 1, ' ', tval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get TELESCOP info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (tval .eq. televal) then ! ............. Get reftime value from CIF and compare to that in dataset call ftgcvd(lun, refcol, i, 1, 1, 0.0d0, rval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get REFTIME info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (rval .eq. reftime) then ! ............... Get filter value from CIF and compare to that in dataset call ftgcvs(lun, filtcol, i, 1, 1, ' ', fval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get FILTER info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (fval .eq. filtval) then ! ................. Get detnam value from CIF and compare to that in dataset call ftgcvs(lun, detcol, i, 1, 1, ' ', dval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get DETNAM info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif if (dval .eq. detval) then ! ................... Get boundary values from CIF and compare call ftgcvs(lun, cbdcol, i, 1, 9, ' ', bval, anyf, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to get CBD info from CIF row ', i call wtferr(subname, version, errstat, context) status = 1 goto 777 endif call cbdcma(bval, 9, cbdval, 9, chatter, result, & pmatch, valtest, unitstest, errstat) if (errstat .ne. 0) then write(context, '(a,I4)')& 'Unable to compare boundary info from CIF row', i call wterrm(subname, version, context) status = 1 goto 777 endif if (result) then ! ..................... If all the comparisons above are true then there is a ! conflict which the user needs to know about call ftgcvs(lun, filecol, i, 1, 1, ' ', file, anyf, & errstat) call ftgcvs(lun, descol, i, 1, 1, ' ', desc, anyf, & errstat) text = 'Another dataset has been found which ' // & 'is valid for the same conditions as the dataset ' // & 'being indexed. This conflicting dataset has:' call wtinfo(10, 1, 1, text) text = 'Instrument : ' // ival call wtinfo(10, 1, 2, text) text = 'Code Name : ' // ccnmval call wtinfo(10, 1, 2, text) text = 'File : ' // file call wtinfo(10, 1, 2, text) text = 'Description: ' // desc call wtinfo(10, 1, 2, text) ! L.B. (Nov 01 1996) ..XPI calls commented out and status set to 1 ! call uclgsb('editc',ans,errstat) ! if (ans) then ! call uclgsi('newquality',newqual,errstat) ! call ftpclj(lun,qualcol,i,1,1,newqual, ! & errstat) ! else ! call uclgsb('editi',ans,errstat) ! if (ans) then ! call uclgsi('quality',qval,errstat) ! qualval = qval ! endif ! endif status = 1 goto 777 endif endif endif endif endif endif endif endif 5000 continue 777 if(status.NE.0) then call wterrm(subname, version, 'Aborting') else context = subname // ' ' // version // ' successful' call wtinfo(chatter, 25, 3, context) endif return end ! ------------------------------------------------------------------- !+RDCAF1 subroutine rdcaf1(chatter, iunit, telescop, & instval, ntrans, trans, ierr) implicit none character*(*)instval, telescop character(10) trans(10) integer ntrans, iunit, ierr, chatter ! Description: ! Checks the alias config file in the current HDU for an alias value matching ! the instval. If one is found, trans is returned with the translations for ! instval and ntrans is the number of translations for instval. ! If instval does not have any translations, ntrans is returned as 0. ! ! Arguments: ! chatter (i) : chattiness flag (zero for silent running) ! iunit (i) : the logical unit number for the previously ! opened configuration file ! telescop(i) : name of the mission ! instval (i) : name of the instrument for which translations are searched for ! ntrans (r) : the number of translations for instval ! trans (r) : the translations for instval ! ierr (r) : error flag (zero = OK) ! ! Origin: Written for the Caldb ! ! Authors/Modifiction History: ! Ron Zellar (1.0.0: 93 Oct 01) Original Version ! Ian M George (2.0.0: 96 Feb 06) Renamed from ckinst & extracted from ! udcif code, also new params+functionality ! error checking etc added character(7) version parameter (version = '2.0.0') !----------------------------------------------------------------------- !- ! Internals character(6) subname parameter (subname = 'rdcaf1') character(10) alias character(80) comment, contxt, value logical anyf integer errstat, i, nalias, fcstln, hdutype ! Initialize ntrans = 0 ierr = 0 ! Give user info if requested contxt = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, contxt) ! Read the current EXTNAME to see where we are in the file ! if we get an error, then assume we're at the top of the file 100 call ftgkys(iunit, 'EXTNAME', value, comment, errstat) if(errstat.ne.0) then call wtinfo(chatter, 30, 3, & 'No EXTNAME in current extn of CAF - searching') errstat = 0 elseif ((errstat.eq.0).and.& (value(:fcstln(value)).eq.telescop(:fcstln(telescop))))then goto 200 endif ! ... not in the right place, so start scrolling down the file call ftmrhd(iunit, 1, hdutype, errstat) if(errstat.eq.107) then call wtinfo(chatter, 20, 2, & 'EOF encountered in CAF before desired EXTNAME') goto 999 elseif (errstat .ne. 0) then call wtferr(subname, version, errstat, 'Unable to move') ierr = -1 goto 999 else goto 100 endif 200 continue ! ... we've found the right extension call wtinfo(chatter, 30, 3, 'Located correct extn of CAF') call ftgkyj(iunit, 'NAXIS2', nalias, comment, errstat) if (errstat .ne. 0) then call wtferr(subname, version, errstat, & 'Problem reading NAXIS2 keyword in CAF') ierr = -1 goto 999 endif Do 1000 i = 1, nalias call ftgcvs(iunit, 1, i, 1, 1, ' ', alias, anyf, errstat) if(alias(:fcstln(alias)).eq.instval(:fcstln(instval)))then call ftgcvj(iunit, 2, i, 1, 1, 0, ntrans, anyf, errstat) call ftgcvs(iunit, 3, i, 1, ntrans, ' ', trans, anyf, errstat) endif if(errstat.ne.0) then call wtferr(subname, version, errstat, & 'Problem reading CAF') ierr = -1 goto 999 endif 1000 continue 999 if(ierr.ne.0) then call wterrm(subname, version, 'Incomplete Execution') endif return end !-----------------------end of RDCAF1subroutine---------------------- ! ------------------------------------------------------------------------------ !+OPCIFS subroutine opcifs(calfexp, copen, oopen, aopen, cunit, & ounit, aunit, ciftmp, televal, instval, trans, & ntrans, chatter, ierr) implicit none character*(*) calfexp, trans(10), televal, instval, ciftmp logical copen, aopen, oopen integer ierr, chatter, ounit, cunit, aunit, ntrans ! Description: ! Opens a CIF (appropriate for a given mission and instrument). ! Creates a new CIF called cif.tmp and copies all data from old CIF (above) ! to new. ! Opens the alias_config.fits file for the mission/instrument ! passed parameters: ! STATUS : error flg (0=OK) ! CHATTER : chattiness flag for o/p (5 low,10 normal,15 high) ! COPEN : logical flag indicating wether 'old' CIF open ! OOPEN : logical flag indicating wether 'new' CIF open ! AOPEN : logical flag indicating wether alias_config.fits ! file open ! CUNIT : logical unit no for 'old' CIF ! OUNIT : logical unit no for 'new' CIF ! AUNIT : logical unit no for alias_config.fits file ! CALFEXP : name (+path) of `old' CIF ! CIFTMP : name (+path) of 'new' CIF ! TELEVAL : name of mission ! INSTVAL : name of instrument ! TRANS() : array containing the 'alias' values for instrument ! NTRANS : number of 'alias' values ! ! user i/ps (prompted for): ! none ! ! Called routines : ! subroutine FCECHO : (FITSIO) write to STDOUT ! subroutine CGETLUN : (CALLIB) get free FORTRAN logical unit no ! subroutine CFRELUN : (CALLIB) free FORTRAN logical unit no ! subroutine WT_FERRMSG : (CALLIB) dumps error messages if necessary ! subroutine WTINFO : (CALLIB) dumps error messages if necessary ! subroutine FTOPEN : (FITSIO) opens FITS file ! subroutine FTCLOS : (FITSIO) closes FITS file ! subroutine FTMAHD : (FITSIO) moves to 1st extension in FITS file ! subroutine RDCNFG : (CALLIB) reads the caldb.config file for ! given mission/instrument ! compilation & linking : ! link with XPI, FITSIO & CALLIB ! ! Origin: Written for the Calibration Database. ! ! Authors/Modification History: ! Lorraine Breedon (1.0.0:97 Jan 15) original version ! Lorraine Breedon (1.1.0:98 Apr 23) removed crtcif routine due to ! problems with ftcopy not ! clobbering 1st extn data in ! cif.tmp character(7) version parameter (version = '1.1.0') !- ! Internals character(6) subname parameter (subname = 'opcifs') character(10) aliasvar character(160) alsfil, cif character(200) context integer fcstln, errstat, hdutype, aplen integer blcksz, j, i logical simple, extend integer bitpix, naxis, naxes(2), pcount, gcount ! initialise and set up defaults ierr = 0 aliasvar = 'CALDBALIAS' cif = calfexp ounit = 0 cunit = 0 aunit = 0 call cgetlun(cunit) call cgetlun(ounit) call cgetlun(aunit) ! type *, '*** IN OPCIFS ***' ! type *, 'cunit,ounit,aunit=',cunit,ounit,aunit ! Give user info if requested context = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, context) ! Translate the ALIASVAR environment/logicals call ctrlog(aliasvar, fcstln(aliasvar), alsfil, aplen) ! Open the configuration file containing the telescop alias values call ftopen(aunit, alsfil, 0, blcksz, errstat) if (errstat .ne. 0) then context = 'Cannot open the CAF' call wtferr(subname, version, errstat, context) context = 'Offending file: ' // & alsfil(:fcstln(alsfil)) call wtinfo(chatter, 1, 2, context) ierr = 1 goto 999 endif aopen = .true. ! See whether we have the CIF open. If not, then open it, and make ! a "back-up" copy (which is actually the guys we'll be working in) ! ------------------------------------------------------------ if (.not. oopen) then ! ........ Open the old calibration index file and move to the first extension. call ftopen(cunit, cif(:fcstln(cif)), 1, blcksz, errstat) if (errstat .eq. 0) then copen = .true. else context = 'Cannot open the CIF' call wtferr(subname, version, errstat, context) context = 'offending file: ' // cif call wtinfo(chatter, 1, 1, context) ierr = 1 goto 999 endif call ftmahd(cunit, 2, hdutype, errstat) If (errstat .ne. 0) then context = 'Cannot move within the CIF' call wtferr(subname, version, errstat, context) context = 'offending file: ' // cif call wtinfo(chatter, 1, 1, context) ierr = 1 goto 999 endif ! .........For safety, create a new cif called 'cif.tmp' which will contain ! all the entries -- old and new. call wtinfo(chatter, 10, 1, 'Making back-up copy of CIF') j = index(cif, 'caldb.indx') ciftmp = cif(:j - 1) // 'cif.tmp ' simple = .true. blcksz = 0 bitpix = 8 naxis = 0 naxes(1) = 0 naxes(2) = 0 pcount = 0 gcount = 0 extend = .true. call ftinit(ounit, ciftmp, blcksz, errstat) if (errstat .eq. 0) oopen = .true. if (errstat .eq. 105) then context = 'Please remove the file cif.tmp' goto 999 endif call ftphpr(ounit, simple, bitpix, naxis, naxes, & pcount, gcount, extend, errstat) call ftpdef(ounit, bitpix, naxis, naxes, pcount, & gcount, errstat) ! ......... Copy all the data from the old cif to the new cif call ftcrhd(ounit, errstat) if (errstat .ne. 0) then context = 'Cannot create new FITS header' // & ' in back-up copy' call wtferr(subname, version, errstat, context) context = 'offending file: ' // ciftmp call wtinfo(chatter, 1, 1, context) ierr = 1 goto 999 endif call ftcopy(cunit, ounit, 0, errstat) if (errstat .ne. 0) then errstat = 0 if (oopen) then call ftclos(ounit, errstat) oopen = .false. call cfrelun(ounit) call delfil(ciftmp) endif context = 'Cannot copy data from CIF to back-up copy' call wterrm(subname, version, context) ierr = 1 goto 999 endif call ftclos(cunit, errstat) if (errstat .ne. 0) then context = 'Cannot close index file: caldb.indx' call wtferr(subname, version, errstat, context) errstat = 0 copen = .true. else call cfrelun(cunit) copen = .false. endif endif ! ------------------------------------------------------------ !........ read the alias file call rdcaf1(chatter, aunit, televal, instval, ntrans, trans, ierr) if(ierr.ne.0) then context = 'Problem reading CAF' call wterrm(subname, version, context) goto 999 endif ! ....... no alias found, so put in the defaults if (ntrans.eq. 0) then ntrans = 1 trans(1) = instval context = 'No alias found for ' // televal(:fcstln(televal)) // & ' ' // instval(:fcstln(instval)) call wtinfo(chatter, 20, 2, context) else context = 'Following aliases found for ' // & televal(:fcstln(televal)) // & ' ' // instval(:fcstln(instval)) call wtinfo(chatter, 20, 2, context) do i = 1, ntrans context = televal(:fcstln(televal)) // & ' ' // trans(i)(:fcstln(trans(i))) call wtinfo(chatter, 20, 3, context) enddo endif 999 if(ierr.ne.0) then context = 'Unable to continue ' // & ' -- attempting to shut down & clean up' call wtinfo(chatter, 1, 1, context) ! Close the instrument alias configuration file if (aopen) then call ftclos(aunit, errstat) if (errstat .ne. 0) then context = 'Cannot close config file' call wtferr(subname, version, errstat, context) errstat = 0 endif call cfrelun(aunit) endif ! close the new calibration index file if (oopen) then call ftclos(ounit, errstat) if (errstat .ne. 0) then context = 'Cannot close index file: cif.tmp' call wtferr(subname, version, errstat, context) errstat = 0 endif call cfrelun(ounit) endif ! Close the old calibration index file if (copen) then call ftclos(cunit, errstat) if (errstat .ne. 0) then context = 'Cannot close index file: caldb.indx' call wtferr(subname, version, errstat, context) errstat = 0 endif call cfrelun(cunit) endif endif ! type *, 'cunit,ounit,aunit=',cunit,ounit,aunit return end !-------End of subroutine OPCIFS---------------------------------------- !+CLCIFS subroutine clcifs(calfexp, copen, oopen, aopen, cunit, ounit, aunit, & ciftmp, chatter, status) implicit none character *(*) calfexp, ciftmp logical copen, aopen, oopen integer status, chatter, cunit, ounit, aunit ! Description: ! closes 2 CIFS ('old' original and 'new' modified copy). ! Moves 'new' CIF onto 'old' one. ! closes the alias_config.fits file for the mission/instrument ! ** note *** ! it is assumed that the subroutine OPCIFS (Open CIFS) has been ! called prior to this routine ! passed parameters: ! STATUS : error flg (0=OK) ! CHATTER : chattiness flag for o/p (5 low,10 normal,15 high) ! COPEN : logical flag indicating wether 'old' CIF open ! OOPEN : logical flag indicating wether 'new' CIF open ! AOPEN : logical flag indicating wether alias_config.fits ! file open ! CUNIT : logical unit no for 'old' CIF ! OUNIT : logical unit no for 'new' CIF ! AUNIT : logical unit no for alias_config.fits file ! CALFEXP : name (+path) of `old' CIF ! CIFTMP : name (+path) of 'new' CIF ! ! user i/ps (prompted for): ! none ! ! Called routines : ! subroutine FCECHO : (FITSIO) write to STDOUT ! subroutine CGETLUN : (CALLIB) get free FORTRAN logical unit no ! subroutine CFRELUN : (CALLIB) free FORTRAN logical unit no ! subroutine WT_FERRMSG : (CALLIB) dumps error messages if necessary ! compilation & linking : ! link with XPI, FITSIO & CALLIB ! ! Origin: Written for the Calibration Database. ! Based on code written by Ron Zellar for routine UPDCIF ! Authors/Modification History: ! Lorraine Breedon (1.0.0:97 Jan 15) original version character(7) version parameter (version = '1.0.0') !- ! Internals character(6) subname parameter (subname = 'clcifs') character(160) alsfil, context, cif integer fcstln, errstat ! initialise and set up defaults errstat = 0 cif = calfexp ! Give user info if requested context = ' using ' // subname // ' ' // version call wtinfo(chatter, 20, 1, context) ! Close the alias_config.fits file errstat = 0 call ftclos(aunit, errstat) if (errstat .ne. 0) then context = 'Cannot close alias_config.fits file '& // alsfil(:fcstln(alsfil)) call wtferr(subname, version, errstat, context) status = errstat return else call cfrelun(aunit) aopen = .false. endif ! close the new calibration index file call ftclos(ounit, errstat) if (errstat .ne. 0) then context = 'Cannot close index file: cif.tmp' call wtferr(subname, version, errstat, context) status = errstat return else call cfrelun(ounit) oopen = .false. endif ! Move the new cal index file onto the old one call mvfile(ciftmp, cif) ! Close the old calibration index file if (copen) then call ftclos(cunit, errstat) if (errstat .ne. 0) then context = 'Cannot close index file: caldb.indx' call wtferr(subname, version, errstat, context) status = errstat return endif call cfrelun(cunit) endif return end !-------End of subroutine CLCIFS----------------------------------------