!+UDCIF subroutine udcif() use calutils implicit none !----------------------------------------------------------------------- ! Revision 3.27 2018/02/02 17:42:37 corcoran ! when ciftmp can't be written, added name of file to the ! error string that's written to console to inform user ! updated context to 240 characters in all routines ! updated taskname to udcif3.27 ! removed non-conforming tabs from code ! ! Revision 3.26 2010/07/30 21:42:37 irby ! Oops, amend the previous commit: leave 'comment' & 'cclsval' at 80 chars. ! ! Revision 3.25 2010/07/30 21:32:16 irby ! String 'context' must be large enough (240 char) to hold the contents ! of 'dummystring'. Was leading to an "End of record" Fortran runtime ! error for long directory paths. ! ! Revision 3.24 2006/07/11 18:56:45 irby ! Submitted by M.Corcoran: ! If a telescope has more than one instrument, udcif won't allow the ! caldb.indx file to be updated (when it finds the first value of instrume ! in the caldb.indx which doesn't match the INSTRUME keyword the execution ! is halted). This revision should fix the problem. ! ! Revision 3.23 2006/06/16 17:43:50 irby ! Updated documentation from M.Corcoran. ! ! Revision 3.22 2006/03/29 21:08:21 irby ! Submitted by Mike Corcoran - UDCIF VERSION 3.0: ! ! Mike Corcoran Nov 2005 - Substantially changed the logic by which calibration ! conflicts are determined. Now for "base conflicts" (where cnam, reftime, ! detnam, telescop, filter all match) it will check all the boundary keywords ! for overlaps. If a parameter name is missing it will alert the user. If a ! parameter name matches but the parameter has different UNITS, it will alert ! the user. For "base conflicts", the boundary parameter names are checked. ! If for any matching boundary parameter name, the values overlap, then there's ! a CONFLICT. If none of the matching boundary parameter names have overlapping ! values, then there's NO CONFLICT. ! ! Also updates checksum and datasums in 1st extension of caldb.indx file. ! ! Also added check to make sure calibration files TELESCOP values ! match all those in the CIF, to avoid the "suzaku" vs. "sazuku" problem ! ! Jan 2006 - Removed option of including "duplicate" data files (added in ! CVS rev. 3.18) since the CBD block is now correctly checked. ! ! Revision 3.21 2005/08/26 19:36:31 irby ! Purely cosmetic changes to allow compilation with gfortran/g95, mostly ! involving fixes to lines longer than 72 chars that were being truncated, ! but in the case of the CGRO code, also moving misplaced (tabbed) line ! continuation characters to their appropriate position in column 6. ! Revision 3.20 2005/08/08 13:30:53 irby ! Version 2.6.1, submitted by Mike Corcoran 2005/08/05: ! Moved CASE conversion implemented in 3.19 before the check for duplication ! done by subroutine ckcif - this is necessary to compare "ASTRO-E2" to ! "ASTRO-E2", not "Astro-E2' to 'ASTRO-E2'. ! ! Revision 3.19 2005/06/07 20:08:21 irby ! Submitted by Mike Corcoran: version 2.6 ! Mike Corcoran, Jun 3, 2005 -- Remove case sensitivity from ! CALDB retrieval/query actions by changing the case of televal, ! detval, filtval, ccnmval, cbdval to uppercase. Needed since ! quzcif changes inputs into upper case before checking the CIF ! for a match, so that a value of TELESCOP='Astro-E2' in the ! CIF would not match %quzcif mission='Astro-E2' otherwise. ! ! Revision 3.18 2004/07/23 18:48:07 irby ! Submitted by Mike Corcoran July 16 2004: ! Allowed user option of including a file to be indexed in the CALDB even ! if it seems to be a "duplicate" of another entry in the caldb index file. ! This is useful since the determination of a duplicate does not currently ! check for differences in the CBD block, which can be used to distinguish files. ! ! Revision 3.17 2003/08/26 20:40:42 irby ! Fixes submitted by M. Corcoran for the following bugs: ! ! - CIFs have a 40 character limit on the CAL_FILE column; however, ! udcif seems to have no such limit (it apparently accepts file names ! up to 160 characters); thus if you update a cif with a file whose ! name is more than 40 characters the filename (in the CAL_FILE column) ! is truncated in the cif, and thus the file can't be found in the ! CALDB. At minimum udcif should warn the user that the file name is ! being truncated. ! ! - udcif seems to require that the alias_config.fits file needs to be ! under $CALDB no matter what value the CALDBALIAS variable contains. ! ! Revision 3.16 2001/11/23 19:21:15 irby ! Fix uninitialized variables to prevent warnings. ! ! Revision 3.15 1999/09/27 16:53:21 pwilson ! Strengthen restrictions on duplicate entries ! ! Revision 3.14 1999/02/24 03:02:11 guerber ! Can't call ftgstm with a constant arg. ! ! Revision 3.13 1998/08/20 18:13:20 breedon ! replace ftdt2s with fttm2s ! ! Revision 3.12 1998/07/27 21:39:35 breedon ! y2k changes ... ! ! Revision 3.10 1998/03/11 19:04:25 pwilson ! Same old 0 -> 0.D0 oedipus problem! ! ! Revision 3.9 1997/12/19 16:45:28 peachey ! Moved ckcbd routine to callib to remove redundancy with mudcif ! ! Revision 3.8 1997/12/18 21:30:39 breedon ! calcrt duplicity problem ! ! Revision 3.7 1996/08/07 10:47:37 oneel ! More uninited varables, again loses on Irix and g77 ! ! Revision 3.6 1996/08/06 18:03:41 oneel ! Forgot to init a status variable before calling uclgst. This loses on ! Irix (and probably g77 as well). ! ! ============================================================================ ! ! Description: Adds an entry to a Calibraiton Index File, for each ! dataset found in the input FITS file. ! ! Arguments: NONE ! ! Origin: Written for the Calibration Database ! ! Authors/Modification History: ! Ron Zellar (1993 June 8), Original fortran version ! adapted from the caldb IRAF script udcif.cl ! Ron Zellar May 23, 1994 -- Added Filter and Detnam check ! Ron Zellar May 24, 1994 -- Added cmpcbd routine, modified ! ckcif to call cmpcbd ! Ron Zellar May 25, 1994 -- Added error checking to ckcif ! and wtcif, and improved ! comments in ckcif. Added CBD ! check to updcif using ckcbd. ! Ron Zellar Jun 13, 1994 -- Modified fcecho text and if ! blocks so that single good ! quality entry is no longer ! required in CIF ! ! Lorraine Breedon 23 Jun 1998 - modifications for y2k ! problem ! version 1.1 ! version 1.1.2 Lorraine Breedon 20 Aug 1998 - replace ftdt2s with fttm2s ! ! version 2.4 PDW 27 Sep 1999 - Enforce better duplicates control ! Delete cif.tmp when erroring out ! ! version 2.5 Mike Corcoran, Aug 26, 2003 -- get CALDBALIAS value from ! CALDBALIAS environment variable; Warn user if cal_file ! value is being truncated and stop update; also translate ! caldb alias file name directly from CALDBALIAS ! environment variable ! ! version 2.5.1 Mike Corcoran July 16 2004 - Allowed user option of including ! a file to be indexed in the CALDB even if it seems to be a ! "duplicate" of another entry in the caldb index file. This ! is useful since the determination of a duplicate does not ! currently check for differences in the CBD block, which can ! be used to distinguish files. ! ! version 2.6 Mike Corcoran June 3 2005 - Remove case sensitivity from ! CALDB retrieval/query actions by changing the case of televal, ! detval, filtval, ccnmval, cbdval to uppercase. Needed since ! quzcif changes inputs into upper case before checking the CIF ! for a match, so that a value of TELESCOP='Astro-E2' in the ! CIF would not match %quzcif mission='Astro-E2' otherwise. ! ! version 2.6.1 Mike Corcoran Aug 8 2005 - Moved CASE conversion implemented ! in 3.19 before the check for duplication done by subroutine ! ckcif - this is necessary to compare "ASTRO-E2" to "ASTRO-E2", ! not "Astro-E2' to 'ASTRO-E2'. ! ! version 3.0 Mike Corcoran Nov 2005 - Substantially changed the logic by ! which calibration conflicts are determined. Now for "base ! conflicts" (where cnam, reftime, detnam, telescop, filter all ! match) it will check all the boundary keywords for overlaps. ! If a parameter name is missing it will alert the user. If a ! parameter name matches but the parameter has different UNITS, ! it will alert the user. ! ! For "base conflicts", if either boundary parameter array is ! completely filled with NONE, then there's a boundary overlap ! and the files conflict: CONFLICT.EQ.TRUE ! ! For "base conflicts", the boundary parameter names are checked. ! If all the matching parameter names have overlapping values ! then conflict.eq.true; otherwise there's at least one parameter ! who's values don't overlap which means conflict=.false. ! ! Also updates checksum and datasums in 1st extension ! of caldb.indx file ! ! Also added check to make sure calibration files TELESCOP ! and INSTRUME values match all those in the CIF, to avoid ! the "suzaku" vs. "sazuku" problem ! ! Added CHATTER parameter ! ! Jan 2006 - Removed option of including "duplicate" data ! files (added in CVS rev. 3.18) since the CBD block is now ! correctly checked. ! ! Version 3.27.1 changed fcerr to fcecho if errstat = 0 on update ! ! MFC version 4.0 2021-03-26 ! included specification of CALDBVER parameter to uniquely specify the release version ! should be of the form 'YYYYMMDD' as used in caldb.indxYYYYMMDD ! removes temporary cif.tmp file if it exists before updating ! if caldbver='NONE' then write a blank value to the CALDBVER keyword ! !-Version 4.0.2 character(160) infile, cif, envar integer errstat, chatter character(len=7), parameter:: version='4.0.2' character(len=40) :: taskname = 'udcif '//version debug = 2 write(*, *) 'UDCIF version ', taskname envar = 'CALDB' ! Get the parameters from the par file errstat = 0 call gpudcf(infile, cif, chatter, caldbver, errstat) ! if there's a problem getting parameters, return if(errstat/=0)return ! Update the CIF call updcif(infile, cif, envar, caldbver, chatter) return end !------END of subroutine UDCIF------------------------------------------ !+GPUDCF ! subroutine gpudcf(infile, cif, chatter, calver, status) use calutils implicit none character*(*) infile, cif character(len=*), intent(out):: calver ! character*(*) version integer status, chatter !----------------------------------------------------------------------- ! Description: Gets the parameters from the udcif par file and returns ! them to the calling program. ! ! Arguments: infile (r): the value of the infile parameter ! cif (r): the value of the cif parameter ! chatter(r): the value of the chatter parameter ! ! Origin: Written for the Calibration Database ! ! Authors/Modification History: ! Ron Zellar (1993 June 8), original version !----------------------------------------------------------------------- !-Version 1.0 integer errstat ! Set the status flag to OK status = 0 ! get the infile paramter errstat = 0 call uclgst('infile', infile, errstat) ! if there's an error getting the infile param, return if(errstat/=0)then call fcerr('Cannot get infile parameter') status = 1 return endif ! get the cif parameter call uclgst('cif', cif, errstat) ! if there's an error getting the cif param, return if(errstat/=0)then call fcerr('Cannot get cif parameter') status = 1 return endif ! get the caldbver parameter call uclgst('caldbver', calver, errstat) ! if there's an error getting the caldbver param, return !print*,'MFC: caldbver = '//calver if(errstat/=0)then call fcerr('Cannot get caldbver parameter') status = 1 return endif ! get the chatter paramter errstat = 0 call uclgsi('chatter', chatter, errstat) ! if there's an error getting the chatter param, return if(errstat/=0)then call fcerr('Cannot get chatter parameter') status = 1 return endif return end !-------End of the GPUDCF subroutine------------------------------------ ! !+UPDCIF ! subroutine updcif(infile, cif, envar, calver, chatter) use debugvars use calutils implicit none character*(*) infile, cif, envar, calver !----------------------------------------------------------------------- ! Description: Accesses the file, infile, and searches for OGIP Caldb ! datasets. When one is found, an entry for it is made in ! the Calibration Index File, cif. ! ! Arguments: infile (i): the name of the FITS file containing a ! Calibration dataset ! cif (i): the name of the Calibration Index File ! envar (i): Environment variable pointing at the top ! directory of the Caldb ! ! Origin: Written for the OGIP Calibration Database ! ! Authors/Modification History: ! Ron Zellar (1993 June 9) Original version ! Ron Zellar (1994 Aug 8) Added envar variable for cgdr !-Version 1.0 !----------------------------------------------------------------------- ! Lorraine Breedon 23 Jun 1998 - modifications for y2k ! problem ! version 1.1 ! Lorraine Breedon 20 Aug 1998 - replace ftdt2s with fttm2s ! etc ! version 2.0 ! MFC 2021-03-25 allows specifying a CALDBVER keyword to be included in the caldb.indx headers !----------------------------------------------------------------------- character(7), parameter :: version='2.0.0' character(len=40) :: taskname = 'updcif '//version ! integer, parameter :: fillenlimit = 40 ! allowed total length of filenames character(240) context !character(80) comment, cclsval character(240) comment, cclsval character(160) alsfil, ciftmp integer fillen, dirlen, ciflen, fcstln, errstat, hdutype, extnum, iunit character(240) dummystring integer cunit, telecol, instcol, filtcol, devcol, dircol, detcol integer filecol, cbdcol, xnocol, aunit, chatter integer refcol, qualcol, datecol, cdescol integer ounit, oldrows, newrows, qualval, ntrans integer blcksz, bitpix, naxis, naxes(2), pcount, gcount, extval, i, j integer cclscol, cdtpcol, ccnmcol, cvsdcol, cvstcol, row, width, size ! these parameters now defined in calutils.mod !integer, parameter :: fillenlimit = 40 ! allowed length of filename !parameter (fillenlimit = 40) !integer, dirlenlimit !parameter (dirlenlimit = 70) character(10) televal, instval, trans(10) ! character(2) dd,mm character(4) cdtpval, cval ! character(4) yy character(20) ccnmval, filtval, detval, devval character(10) cvsdval, date character(68) cvsdatval character(8) cvstval character(70) cdesval, cbdval(9), dirval character(40) fileval double precision reftime, second logical exact, copen, simple, extend, aopen, iopen, oopen, result logical modcif character(160) message integer iyear, imon, iday, ihour, imin, decimals, utmode character(30) timestr logical :: file_exists ! character(1) answer ! Initialize the variables extnum = 0 fillen = 0 dirlen = 0 iunit = 34 ounit = 48 cunit = 29 aunit = 56 copen = .false. aopen = .false. iopen = .false. oopen = .false. modcif = .false. oldrows = 0 newrows = 0 iyear = 0 imon = 0 iday = 0 ihour = 0 imin = 0 second = 0.0 decimals = 0 utmode = 0 ! Open the configuration file containing the telescop alias ! values alsfil = 'alias_config.fits' errstat = 0 ! call cpthnm(envar,'software/tools',alsfil,errstat) call getenv('CALDBALIAS', alsfil) ! write(*,*) 'CALDBALIAS =',alsfil errstat = 0 call ftopen(aunit, alsfil, 0, blcksz, errstat) if (errstat /= 0) then context = 'Cannot open the config file: ' // & alsfil(:fcstln(alsfil)) goto 999 endif aopen = .true. ! Get length of the cal filename and the cif filename infile = stripstringlt(infile) fillen = fcstln(infile) ! write(*,*) 'infile, fillen = ',infile(:fillen), fillen ! infile = stripstringlt(infile) ! write(*,*) 'length of stripped filename = ',fcstln(infile) ciflen = fcstln(cif) ! open the calibration file call ftopen(iunit, infile(:fillen), 0, blcksz, errstat) If (errstat /= 0) then context = 'Cannot open the input file: ' // & infile(:fillen) goto 999 endif ! Top of the cal file extension searching loop 1000 continue errstat = 0 ! keep track of the extension number extnum = extnum + 1 extval = extnum - 1 ! write(*,*) 'A) fillen is now ', fillen ! move to the extension given by extnum call ftmahd(iunit, extnum, hdutype, errstat) ! If errstat does not = 0, then end of file if (errstat /= 0) then if (modcif) goto 9000 context = 'No datasets indexed' goto 999 endif ! Look in the cal file for the CCLS0001 keyword call ftgkys(iunit, 'CCLS0001', cclsval, comment, errstat) if (errstat /= 0) goto 1000 ! Get the required calibration keywords call ftgkys(iunit, 'CCNM0001', ccnmval, comment, errstat) if (errstat /= 0) then call rqkyer('CCNM0001', extnum) goto 1000 endif write(*, *)' ' context = 'Dataset: ' // ccnmval call fcecho(context) call ftgkys(iunit, 'TELESCOP', televal, comment, errstat) if (errstat /= 0) then call rqkyer('TELESCOP', extnum) goto 1000 endif call ftgkys(iunit, 'INSTRUME', instval, comment, errstat) if (errstat /= 0) then call rqkyer('INSTRUME', extnum) goto 1000 endif call ftgkys(iunit, 'CDTP0001', cdtpval, comment, errstat) if (errstat /= 0) then call rqkyer('CDTP0001', extnum) goto 1000 endif call ftgkys(iunit, 'CVSD0001', cvsdatval, comment, errstat) if (errstat /= 0) then call rqkyer('CVSD0001', extnum) goto 1000 endif if (fcstln(cvsdatval) /= 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 /= 0) then message = 'problem in fts2dt ' call fcecho(message) goto 1000 endif call fttm2s(iyear, imon, iday, ihour, & imin, second, decimals, cvsdatval, errstat) if (errstat /= 0) then message = 'problem in fttm2s ' call fcecho(message) goto 1000 endif endif cvsdval = cvsdatval(1:10) call ftgkys(iunit, 'CVST0001', cvstval, comment, errstat) if (errstat /= 0) then call rqkyer('CVST0001', extnum) goto 1000 endif ! Calculate the reference time for input into the ! REF_TIME column call calcrt(cvsdatval, cvstval, reftime, errstat) if (errstat /= 0) then write(cval, '(I4)')extval context = 'Error calculating the REF_TIME value' // & ' in extension:' // cval call fcerr(context) goto 1000 endif call ftgkys(iunit, 'CDES0001', cdesval, comment, errstat) if (errstat /= 0) then call rqkyer('CDES0001', extnum) goto 1000 endif ! Get the non-required keywords call ftgkys(iunit, 'FILTER', filtval, comment, errstat) if (errstat /= 0) filtval = 'NONE' errstat = 0 call ftgkys(iunit, 'DETNAM', detval, comment, errstat) if (errstat /= 0) detval = 'NONE' errstat = 0 ! Get all the CBDnxxxx keywords from the calibration file call ftgkys(iunit, 'CBD10001', cbdval(1), comment, errstat) if (errstat /= 0) cbdval(1) = 'NONE' call ftgkys(iunit, 'CBD20001', cbdval(2), comment, errstat) if (errstat /= 0) cbdval(2) = 'NONE' call ftgkys(iunit, 'CBD30001', cbdval(3), comment, errstat) if (errstat /= 0) cbdval(3) = 'NONE' call ftgkys(iunit, 'CBD40001', cbdval(4), comment, errstat) if (errstat /= 0) cbdval(4) = 'NONE' call ftgkys(iunit, 'CBD50001', cbdval(5), comment, errstat) if (errstat /= 0) cbdval(5) = 'NONE' call ftgkys(iunit, 'CBD60001', cbdval(6), comment, errstat) if (errstat /= 0) cbdval(6) = 'NONE' call ftgkys(iunit, 'CBD70001', cbdval(7), comment, errstat) if (errstat /= 0) cbdval(7) = 'NONE' call ftgkys(iunit, 'CBD80001', cbdval(8), comment, errstat) if (errstat /= 0) cbdval(8) = 'NONE' call ftgkys(iunit, 'CBD90001', cbdval(9), comment, errstat) if (errstat /= 0) cbdval(9) = 'NONE' errstat = 0 ! 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 fcerr(context) goto 1000 endif ! write(*,*) 'B) fillen is now ',fillen ! Assign input file name to variable written to CIF fileval = infile ! ! make sure the file name is less than the fillenlimit character limit for ! cal_file in the CIF ! ! write(*,*)'C) fillen is now ',fillen if (fillen > fillenlimit) then dummystring = 'Calibration file name ' // infile write(context, '(A)') dummystring call fcerr(context) write(*,*)'has length',fillen,' characters' write(dummystring, '(A25,I3,A20)') 'Greater than the allowed ',fillenlimit,' character limit' context = 'Greater than the allowed '//dummystring//' character limit' call fcerr(context) goto 1000 endif ! Get dir part of system independent specification for the ! current working directory ! MFC START ! write(*, *) 'envar = ', envar call cgdr(envar, dirval, errstat) dirval = stripstringlt(dirval) ! write(*, *) 'dirval, len(dirval) = ', dirval, fcstln(dirval) if (errstat /= 0) then context = 'STOPPING: Cannot get directory from CGDR' call wterrm(taskname, version, context) context = 'Error accessing '//trim(envar)//'; Check that '//trim(envar)//' is defined' call wterrm(taskname, version, context) return endif dirlen = fcstln(dirval) ! write(*,*) 'dirlen = ',dirlen if (dirlen > dirlenlim) then dummystring = 'Calibration directory name ' // dirval write(*, *) dummystring write(dummystring, '(I3)') dirlenlim context = 'Greater than the allowed '//dummystring//' character limit ' call fcerr(context) goto 1000 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 /= 0) then context = 'Cannot get quality parameter' call fcerr(context) goto 1000 endif ! Make a new entry in the index file containing the keyword ! values gotten above. if (.not. oopen) then ! open the old calibration index file and move to the ! first extension. call ftopen(cunit, cif(:ciflen), 1, blcksz, errstat) if (errstat .eq. 0) copen = .true. call ftmahd(cunit, 2, hdutype, errstat) ! create a new cif called 'cif.tmp' which will ! contain all the entries -- old and new. 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. ! see if ciftmp exists; if it does, unlink (remove) it INQUIRE(FILE=trim(ciftmp), EXIST=file_exists) if (file_exists) then call wtinfo(chatter, 2, 2, trim(ciftmp)//' EXISTS; Removing file') call unlink(ciftmp, status = errstat) if (errstat /= 0) then call wterrm(taskname,'','Problem deleting '//trim(ciftmp)//' STOPPING') print*, 'ERROR STATUS = ',errstat return end if end if call ftinit(ounit, ciftmp, blcksz, errstat) !print*, 'MFC: ftinit errstat', errstat if (errstat .eq. 0) oopen = .true. if (errstat .eq. 105) then context = 'Could not create file ' // trim(ciftmp)//'; STOPPING' call wterrm(taskname, ' ',context) print*,'STATUS = ',errstat return 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 (cunit) to the temporary cif (ounit) call ftcrhd(ounit, errstat) call ftcopy(cunit, ounit, 0, errstat) !print*,'MFC: ftcopy errstat = ',errstat if (errstat /= 0) then context = 'Cannot copy data from CIF to temporary file '& // trim(ciftmp)//'; STOPPING' call wterrm(taskname,'', context) print*,' MFC Error status = ', errstat errstat = 0 if (oopen) then call ftclos(ounit, errstat) oopen = .false. call delfil(ciftmp) endif return endif call ftclos(cunit, errstat) if (errstat /= 0) copen = .false. ! Get the column numbers from the index file exact = .true. call ftgcno(ounit, exact, 'TELESCOP', telecol, errstat) call ftgcno(ounit, exact, 'INSTRUME', instcol, errstat) call ftgcno(ounit, exact, 'DETNAM', detcol, errstat) call ftgcno(ounit, exact, 'FILTER', filtcol, errstat) call ftgcno(ounit, exact, 'CAL_DEV', devcol, errstat) call ftgcno(ounit, exact, 'CAL_DIR', dircol, errstat) call ftgcno(ounit, exact, 'CAL_FILE', filecol, errstat) call ftgcno(ounit, exact, 'CAL_CLAS', cclscol, errstat) call ftgcno(ounit, exact, 'CAL_DTYP', cdtpcol, errstat) call ftgcno(ounit, exact, 'CAL_CNAM', ccnmcol, errstat) call ftgcno(ounit, exact, 'CAL_CBD', cbdcol, errstat) call ftgcno(ounit, exact, 'CAL_XNO', xnocol, errstat) call ftgcno(ounit, exact, 'CAL_VSD', cvsdcol, errstat) call ftgcno(ounit, exact, 'CAL_VST', cvstcol, errstat) call ftgcno(ounit, exact, 'REF_TIME', refcol, errstat) call ftgcno(ounit, exact, 'CAL_QUAL', qualcol, errstat) call ftgcno(ounit, exact, 'CAL_DATE', datecol, errstat) call ftgcno(ounit, exact, 'CAL_DESC', cdescol, errstat) if (errstat /= 0) then context = 'Cannot find index file columns' goto 999 endif ! get the number of rows in the cif call ftgkyj(ounit, 'NAXIS2', oldrows, comment, errstat) endif ! Search config file for the extension which has the EXTNAME ! keyword equal to televal call mvxnam(aunit, televal, errstat) if (errstat .eq. -1) then context = 'Error searching alias config file' goto 999 endif if (errstat .eq. 1) then errstat = 0 ! Keep track of the number of new entries made newrows = newrows + 1 row = newrows + oldrows call wtcif(ounit, row, 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, & chatter, errstat) if (errstat /= 0) then errstat = 0 newrows = newrows - 1 row = row - 1 else modcif = .true. endif else call ckinst(instval, aunit, ntrans, trans) if (ntrans .eq. 0) then ntrans = 1 trans(1) = instval endif Do 2000 i = 1, ntrans instval = trans(i) ! Keep track of the number of new entries made newrows = newrows + 1 row = newrows + oldrows call wtcif(ounit, row, 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, chatter, errstat) if (errstat /= 0) then errstat = 0 newrows = newrows - 1 row = row - 1 else modcif = .true. endif 2000 continue endif ! Search for the next dataset goto 1000 ! Bottom of extension searching loop 9000 continue ! close the calibration file errstat = 0 call ftclos(iunit, errstat) if (errstat /= 0) then context = 'Cannot close calibration file: '& // infile(:fillen) call fcerr(context) endif ! Close the config file errstat = 0 call ftclos(aunit, errstat) if (errstat /= 0) then context = 'Cannot close configuration file '& // alsfil(:fcstln(alsfil)) call fcerr(context) endif ! reset the data definition keywords call ftmkyj(ounit, 'NAXIS2', row, '&',errstat) call ftgkyj(ounit, 'NAXIS1', width, comment, errstat) size = width * row call ftddef(ounit, size, errstat) ! update the CHECKSUM and DATASUM keywords call ftpcks(ounit, errstat) if (errstat /= 0) then context = 'Cannot update the CHECKSUM and DATASUM: cif.tmp' call fcerr(context) errstat = 0 endif ! update CALDBVER if (calver == 'NONE') then !set value to empty string if NONE specified calver = '' end if call ftmkys(ounit,'CALDBVER',calver, 'CALDB version, if specified ',errstat) if (errstat == 202) then ! errstat =202 means keyword not found so insert it errstat=0 if (chatter > 2) then write(*,*) 'CALDBVER keyword missing from header; inserting CALDBVER' end if call ftikys(ounit,'CALDBVER',calver, 'CALDB version, if specified ',errstat) end if if (errstat /= 0) then call wterrm(taskname, version, 'Error writing CALDBVER keyword: STOPPING') return end if ! close the new calibration index file call ftclos(ounit, errstat) if (errstat /= 0) then context = 'Cannot close index file: cif.tmp' call fcerr(context) errstat = 0 endif ! Move the new cal index file onto the old one call mvfile(ciftmp, cif) ! Write 'newrows' into the .par file call uclpsi('newentries', newrows, errstat) if (errstat /= 0) then context = 'Cannot record newentries into par file' call fcerr(context) errstat = 0 endif return 999 continue call fcerr(context) errstat = 0 ! Close the instrument alias configuration file if (aopen) then call ftclos(aunit, errstat) if (errstat /= 0) then context = 'Cannot close config file' call fcerr(context) errstat = 0 endif endif ! close the calibration file if (iopen) then call ftclos(iunit, errstat) if (errstat /= 0) then context = 'Cannot close calibration file: ' // & infile(:fillen) call fcerr(context) errstat = 0 endif endif ! close the new calibration index file if (oopen) then call ftclos(ounit, errstat) if (errstat /= 0) then context = 'Cannot close index file: cif.tmp ' // ciftmp call fcerr(context) errstat = 0 endif call unlink(ciftmp) endif ! Close the old calibration index file if (copen) then call ftclos(cunit, errstat) if (errstat /= 0) then context = 'Cannot close index file: ' // cif call fcerr(context) errstat = 0 endif endif return end !-------End of subroutine UPDCIF---------------------------------------- !+RQKYER ! subroutine rqkyer(keyword, extnum) implicit none character(8) keyword integer extnum !----------------------------------------------------------------------- ! Description: Sends an error message to stderr using fcerr. Used when ! a required keyword is missing from a CIF. ! ! Arguments: keyword (i) : the keyword which is missing ! extnum (i) : the extnum in which the keyword is missing ! ! Origin: Written for the calibration database ! ! Authors/Modification History: ! Ron Zellar 8 Sept, 1993 -- Original Version !---------------------------------------------------------------------- !-Version 1.0 character(240) context character(4) cval write(cval, '(I4)')extnum context = 'Cannot find ' // keyword // ' keyword in ext: ' // cval call fcerr(context) return end !------------------------End of RQKYER subroutine---------------------- !+MVXNAM ! subroutine mvxnam(lun, extname, status) implicit none integer lun, status character*(*) extname !----------------------------------------------------------------------- ! Description: Will move through a fits file until the extension which ! contains the EXTNAME keyword with the value extname is ! found. ! ! Arguments: lun (i) : the logical unit number which the file ! was opened with ! extname (i) : the EXTNAME keyword value to look for ! status (r) : the success status of this routine ! 0 = OK ! 1 = extname not found in file ! -1 = error when moving through file ! ! Origin: Written for the Caldb ! ! Authors/Modification History: ! Ron Zellar Oct 1, 1993 -- Original Version !----------------------------------------------------------------------- !- Version 1.0 integer errstat, hdutype, fcstln character(80) comment, value status = 0 errstat = 0 call ftgkys(lun, 'EXTNAME', value, comment, errstat) if ((errstat.eq.0).and.& (value(:fcstln(value)).eq.extname(:fcstln(extname))))then return endif errstat = 0 call ftmahd(lun, 1, hdutype, errstat) if (errstat /= 0) then status = -1 return endif 1000 continue call ftgkys(lun, 'EXTNAME', value, comment, errstat) if ((errstat.eq.0).and.& (value(:fcstln(value)).eq.extname(:fcstln(extname))))then return endif errstat = 0 call ftmrhd(lun, 1, hdutype, errstat) if (errstat.eq.0) then goto 1000 else status = 1 return endif end !-----------------End of MVXNAM subroutine------------------------------ !+CKINST ! subroutine ckinst(instval, aunit, ntrans, trans) implicit none character*(*)instval character(10) trans(10) integer ntrans, aunit !----------------------------------------------------------------------- ! 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: televal (i) : the value for which translations are made ! aunit (i) : the logical unit number for the previously ! opened configuration file ! ntrans (r) : the number of translations for instval ! trans (r) : the translations for instval ! ! Origin: Written for the Caldb ! ! Authors/Modifiction History: ! Ron Zellar Oct 1, 1993 -- Original Version !----------------------------------------------------------------------- !- Version 1.0 character(10) alias character(80) comment logical anyf integer errstat, i, nalias, fcstln ntrans = 0 errstat = 0 call ftgkyj(aunit, 'NAXIS2', nalias, comment, errstat) Do 1000 i = 1, nalias call ftgcvs(aunit, 1, i, 1, 1, ' ', alias, anyf, errstat) if(alias(:fcstln(alias)).eq.instval(:fcstln(instval)))then call ftgcvj(aunit, 2, i, 1, 1, 0, ntrans, anyf, errstat) call ftgcvs(aunit, 3, i, 1, ntrans, ' ', trans, anyf, errstat) endif 1000 continue return end !+WTCIF subroutine wtcif(ounit, row, 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, chatter, status) implicit none integer ounit, row, status integer extval, qualval double precision reftime character*(*)televal, instval, detval, filtval, devval, dirval, & fileval, cclsval, cdtpval, ccnmval, cbdval(9), cvsdval, cvstval, date, & cdesval integer telecol, instcol, detcol, filtcol, devcol, dircol, filecol, & cclscol, cdtpcol, ccnmcol, cbdcol, xnocol, cvsdcol, cvstcol, refcol, & qualcol, datecol, cdescol !----------------------------------------------------------------------- ! 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 ! ! Origin: written for the caldb ! ! Authors/Modification History ! Ron Zellar Oct 1, 1993 -- Original version ! Ron Zellar May 24, 1994 -- Modified ckcif call to include ! cbd values ! Ron Zellar May 25, 1994 -- Added error checking ! Mike Corcoran Feb 9 2006 -- convert to upper case; ! Version 1.2 !----------------------------------------------------------------------- !- Version 1.2 integer nrows, errstat character(240) context character(4) cval character(3) extvalchar integer fcstln, chatter ! Initialize the errstat and status variables errstat = 0 status = 0 extvalchar = '***' write(extvalchar, 101) extval 101 format(i2) ! Convert to upper case ! write(*,*) 'Converting to upper case BEFORE check' call ftupch(televal) call ftupch(instval) call ftupch(ccnmval) call ftupch(detval) call ftupch(filtval) call ftupch(cbdval) ! Check the other entries to make sure that ! there are no conflicting datasets nrows = row - 1 call ckcif(ounit, nrows, telecol, televal, instcol, instval, & refcol, reftime, ccnmcol, ccnmval, qualcol, qualval, filtcol, & filtval, detcol, detval, cbdcol, cbdval, dircol, dirval, & filecol, fileval, xnocol, extval, cdescol, chatter, errstat) if (errstat /= 0) then status = 1 context = 'DATASET ' // fileval(:fcstln(fileval)) // & '[' // extvalchar // ']' // ' not written to CIF' ! write(*,*) context call fcerr(context) return else context = 'DATASET ' // fileval(:fcstln(fileval)) // & '[' // extvalchar // ']' // ' written to CIF' call fcecho(context) endif ! make necessary fitsio calls to add the data 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) if (errstat /= 0) then write(cval, '(I4)')errstat context = 'WTCIF error: returned value = ' // cval call fcerr(context) context = 'Unable to write entry to CIF' call fcerr(context) status = 1 endif return end ! !+CKCIF ! subroutine ckcif(lun, nrows, telecol, televal, instcol, instval, & refcol, reftime, ccnmcol, ccnmval, qualcol, qualval, filtcol, filtval, & detcol, detval, cbdcol, cbdval, dircol, dirval, filecol, fileval, & xnocol, extval, descol, chatter, status) implicit none integer lun, nrows, telecol, instcol, refcol, ccnmcol, qualcol, qualval integer filtcol, detcol, filecol, descol, cbdcol, status integer xnocol, extval, dircol, chatter character(10) televal, instval, filtval character(20) ccnmval, detval character*(*) cbdval(9), dirval, fileval 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 its 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 ! fileval (i) : the CAL_FILE col value ! descol (i) : the col number of the CAL_DESC col ! ! Origin: Written for the Caldb ! ! Authors/Modification History: ! Ron Zellar Oct 2, 1993 -- Original Version ! Ron Zellar May 23, 1994 -- Added FILTER and DETNAM search ! Ron Zellar May 24, 1994 -- Added CBD search, cmpcbd call ! Ron Zellar May 25, 1994 -- Added error checking and ! improved comments ! Ron Zellar Jun 13, 1994 -- Modified fcecho text and if ! blocks so that single good ! quality entry is no longer ! required ! PD Wilson Sep 01, 1999 -- Merge the many if-blocks together ! Enforce stricter duplicate control... ! Cannot change current quality, but ! can force old record to qual=5. !----------------------------------------------------------------------- !- Version 1.2 integer qval, errstat, i, extnval, fcstln character(4) crow, cerr character(10) tval, ival, fval character(20) cval, dval character(40) file character(80) desc, text, bval(9), dir character(240) context double precision rval logical anyf, ans, duplicate, samefile integer pmatch(9) logical valtest(9), unitstest(9) errstat = 0 Do i = 1, nrows ! Get Dir/File/Extn of this record call ftgcvs(lun, dircol, i, 1, 1, ' ', dir, anyf, errstat) call ftgcvs(lun, filecol, i, 1, 1, ' ', file, anyf, errstat) call ftgcvj(lun, xnocol, i, 1, 1, 0, extnval, anyf, errstat) ! Get quality value from CIF and call ftgcvj(lun, qualcol, i, 1, 1, 0, qval, anyf, errstat) ! Get codename value from CIF and call ftgcvs(lun, ccnmcol, i, 1, 1, ' ', cval, anyf, errstat) ! Get instrument value from CIF and call ftgcvs(lun, instcol, i, 1, 1, ' ', ival, anyf, errstat) ! Get telescope value from CIF and call ftgcvs(lun, telecol, i, 1, 1, ' ', tval, anyf, errstat) ! Get reftime value from CIF and call ftgcvd(lun, refcol, i, 1, 1, 0.D0, rval, anyf, errstat) ! Get filter value from CIF and call ftgcvs(lun, filtcol, i, 1, 1, ' ', fval, anyf, errstat) ! Get detnam value from CIF and call ftgcvs(lun, detcol, i, 1, 1, ' ', dval, anyf, errstat) ! Get boundary values from CIF and call ftgcvs(lun, cbdcol, i, 1, 9, ' ', bval, anyf, errstat) if (errstat /= 0) then write(cerr, '(I4)')errstat write(crow, '(I4)')i context = 'CKCIF error: returned value = ' // cerr call fcerr(context) context = 'Unable to get info from row ' // crow call fcerr(context) status = 1 return endif ! Check if this file has already been added if(dir(1:fcstln(dir)).eq.dirval(1:fcstln(dirval)) .and.& file(1:fcstln(file)).eq.fileval(1:fcstln(fileval)) .and.& extval.eq.extnval) then samefile = .true. else samefile = .false. endif ! Warn user if telescop values are not the same if (TVAL/=TELEVAL) then WRITE(*, *) 'TELESCOPE VALUE in FILE NOT THE SAME as CIF' // & 'VALUES' write(*, *) ' CIF TELESCOP =', TVAL write(*, *) 'FILE TELESCOP =', TELEVAL write(*, *) 'RETURNING' STATUS = 1 return endif ! Compare this row's values to the dataset if (cval .eq. ccnmval .and.& ival .eq. instval .and.& tval .eq. televal .and.& rval .eq. reftime .and.& fval .eq. filtval .and.& dval .eq. detval) then ! If all the above are matched, then check the boundary values ! using cbdcma2 to see if there's a conflict call cbdcma(bval, 9, cbdval, 9, chatter, duplicate, pmatch, & valtest, unitstest, errstat) if (errstat /= 0) then write(cerr, '(I4)')errstat write(crow, '(I4)')i context = 'Unable to compare boundary info from ' // & 'row ' // crow call fcerr(context) status = 1 return endif else duplicate = .false. endif if(duplicate .and. samefile) then call fcecho(' ') text = '*********************************************' // & '****************************' call fcecho(text) text = 'This record is already present in the CIF ' call fcecho(text) write(text, '(a,i4,a)') ' File: '& // file(:fcstln(file)) // '[', extnval, ']' call fcecho(text) text = 'Instrument: ' // ival call fcecho(text) text = ' Code Name: ' // ccnmval call fcecho(text) write(text, '(a,i2)') ' Quality: ', qval call fcecho(text) text = 'If this file''s flags have changed, use caldbflag'& // ' to modify the CIF entry' call fcecho(text) text = '*********************************************' // & '****************************' call fcecho(text) call fcecho(' ') status = 1 return else if (duplicate .and.& qval .eq. qualval .and. qval .eq. 0) then ! If all the comparisons above are true then ! there is a conflict which the user needs to ! know about call ftgcvs(lun, descol, i, 1, 1, ' ', desc, anyf, & errstat) call fcecho(' ') text = 'Another dataset has been found which ' // & 'is valid for ALL the same ' call fcecho(text) text = 'conditions as the dataset being indexed' call fcecho(text) call fcecho(' ') text = 'The conflicting dataset: ' call fcecho(text) text = '----------------------------------------'& // '--------------------' call fcecho(text) text = ' Instrument: ' // ival call fcecho(text) text = ' Code Name: ' // ccnmval call fcecho(text) write(text, '(a,i4,a)') ' File: ' // & file(:fcstln(file)) // '[', extnval, ']' call fcecho(text) call fcecho('Description:') call fcecho(desc) text = '----------------------------------------'& // '--------------------' call fcecho(text) call fcecho(' ') ! Ask if the duplicate should be flagged as bad call uclgsb('editc', ans, errstat) if (ans) then ! Change quality of old record to 5 qval = 5 call ftpclj(lun, qualcol, i, 1, 1, qval, & errstat) else status = 1 ! MFC: Give option to include new record, leaving old record valid too ! write(*,'(A$)') 'Include new data file in CALDB.INDX (Y/N)> ' ! read(*,*) answer ! if (answer.eq.'Y')then ! call uclgsb('overide',ans,errstat) ! if (ans) then ! status=0 ! else ! Leave old record as valid, skip new entry ! status = 1 ! endif return endif call fcecho(' ') endif end do ! 5000 continue return end