!+QUZCIF subroutine quzcif2() !----------------------------------------------------------------------- ! Description: Displays entries from a Calibration Index File which are ! valid for the mission, instrument, codename, date, and ! time specified by the user. In addition, the user may ! conduct more restrictive searches using a boolean ! expression which selects on calibration boundary ! parameters. ! ! Arguments: None ! ! Origin: Written for the Calibration Database ! ! Authors/Modification History: ! Ron Zellar (1993 Feb 3), original version ! Ron Zellar (1993 Jun 14), added trinst subroutine ! Ron Zellar (1993 Jun 14), added prscreen param ! Ron Zellar (1994 Jan 20), Moved qzcif out of quzcif ! Moved ftupch calls to qzcif ! Moved gcfdir call to qzcif ! Ron Zellar (1994 Jul 15), Reconfigured to use gtcal ! subroutine. Moved "now" ! feature to gtcal, added params ! detector, filter, expr, maxret ! and nfound. Removed params ! prscreen, path, and extno. ! ! Lorraine Breedon 24 Jun 1998 - modifications for y2k ! problem version 1.2 ! Jeff Guerber (1999-03-26), Removed Lorraine's date parameter ! format check and reprompt loop (gpqzcf), which rejected ! old-style dates and looped forever if the bad date had ! been entered on the command line; lower-level routines ! (eg. dt2mjd) check the format anyway. Increased sizes ! of date and time strings. Version 1.3. ! PDW (1999-08-11), Replaced gtcal with gtcalf and added ! chatter parameter ! ! MFC (2008-12-09) VERSION 1.3 ! added "retrieve" parameter to allow user option of ! downloading remote files via ftp or http ! MFC (2009-09-15) version 1.4.1 ! if retrieve="yes" fecho the name of the local file ! (with the http://... stripped off) ! MFC (2009-10-07) version 1.4.2 ! fixed bug where retrieve="yes" gave an empty string ! if local caldb used ! MFC (2009-10-09) version 1.4.3 ! initialized "lun" variable to fix a segfault in ! Centos linux ! MFC (2009-10-12) version 1.4.3.1 ! restored behavior from 1.4.1 which was lost in 1.4.2 and ! 1.4.3, namely: ! retrieve+ with remote access: downloads file, reports ! root file name (with url stripped off) ! retrieve- with remote access: does not download but ! reports full url to file ! retrieve+, local access: does not download, reports ! full path to file ! retrieve-, local access: no download, reports ! full path to file ! MFC (2009-10-13) version 1.4.4 - added clobber param ! MFC (2017-05-01) version 1.4.5 - added quality param ! so users can search for caldb files where ! quality is not 0. this is useful for seeing ! the number of "bad" files in a cif, or for ! setting a non-zero quality to use if a calfile ! normally should not be used but may be ! appropriate in certain circumstances ! MFC: added https support when retrieve+; updated version ! to 1.46 ! MFC: added progress bar when downloading (H/T Craig Gordon) ! if chatter > 10 ! updated Version to 1.47 (06/14/18) ! MFC: converted to fortran 90 (04/15/20; version 1.5); set maxret ! to the number of rows in CIF instead of an arbitrary number ! MFC: converted to fortran 90 (03/17/21; version 1.6); use cifsl3 in gtcalf ! which returns diagnostic messages; added fix if date = '-' (in this case, ! don't check for date) ! MFC: (20220215, version 2.0) added caldbver parameter to allow user to easily select a prior version ! of the CALDB. The caldbver parameter is a string parameter of the same form as the index files ! in $CALDB/data///index subdirectory ! For example to find the clock correction for the nustar fpm ! from the caldb version caldb.indx20210202, do ! % quzcif2 nustar fpm - - CLOCK now now - caldbver=caldb.indx20210202 ! ! !----------------------------------------------------------------------- !-Version 2.0 implicit none character(7) version parameter (version = '0.9') integer charnum parameter(charnum=160) character(10) tele, instr, filter character(20) codenam, detnam, caldbver character(68) time, date character(charnum) expr character(charnum) instdir, cif character(5) ci integer errstat, maxret, nfound, chatter, quality integer status integer, parameter :: debug = 0 logical retrieve, delexist character(40) taskname !common /task/ taskname taskname = 'quzcif '// version ! print*, 'MFC: QUZCIF2 20221109 J' if (debug > 1) then print*, 'MFC: taskname ', taskname end if date = ' ' time = ' ' ! Get the parameters from the par file call gpqzcf2(tele, instr, detnam, filter, codenam, date, time, & expr, maxret, retrieve, chatter, quality, caldbver, delexist, errstat) if (debug > 1) then print*, 'MFC, quzcif: caldbver = ',caldbver end if ! if (debug.eq.2) then ! write(*,*) 'FINISHED GPQZCF2' ! end if ! if maxret = -1, set maxret to number of rows in cif if (maxret.lt.0) then call rdcnfg(tele, instr, .TRUE., cif, instdir, status) ! if (debug.gt.1) then ! print *, 'MFC: RDCNFG STATUS = ',status ! endif if (status.ne.0) then return end if if (chatter.gt.5) then write(*,*) 'Getting MAXRET from CIF '//cif endif call gtcifrows(cif,maxret, status) write(ci,'(I5)') maxret if (chatter.gt.5)then write(*,*) 'Setting maxret to =' // ci endif endif ! If there's an error getting parameters then return if (errstat .ne. 0) return ! Get the requested calibration filenames and display them if (debug.eq.3) then write(*,*) 'CALLING QCIF2' end if call qcif2(tele, instr, detnam, filter, codenam, date, time, & expr, chatter, maxret, retrieve, delexist, nfound, quality, & caldbver, errstat) if (debug.eq.3) then write(*,*) 'FINISHED QCIF' end if call ppqzcf(nfound) return end !----------------------------------------------------------------------- !----------------------------------------------------------------------- !+QCIF subroutine qcif2(tele, instr, detnam, filt, codenam, date, time, & expr, chatter, maxret, retrieve, delexist, nfound, quality, & caldbver, errstat) implicit none character*(*)tele, instr, detnam, filt, codenam, date, time, expr, caldbver integer maxret, nfound, errstat, chatter, quality logical retrieve, delexist !----------------------------------------------------------------------- ! Description: locates the requested files using the Caldb access ! software, then displays them to STDOUT. ! ! Arguments: tele (i): the name of the mission ! instr (i): the name of the instrument ! detnam (i): the name of the detector ! filt (i): the name of the filter ! codenam (i): the OGIP name of the dataset ! date (i): the date for which dataset should be valid ! time (i): the time for which dataset should be valid ! expr (i): boolean expression for selecting CBD values ! chatter (i): level of chattiness when working ! maxret (i): the maximum number of files to return ! retrieve (i,L): retrieve files via remote access if true ! delexist (i,L): clobbers file if set to true. ! nfound (r): the actual number of datasets found which ! meet the selection criteria ! errstat (r): the status code (0 = OK) ! ! optional input parameters ! quality (i): value of cal_qual to be searched (default:0) ! caldbver (i): string representing the caldb.indx version to use ! of the CALDB. The caldbver parameter is a string parameter of the same form as the index files ! in $CALDB/data///index subdirectory ! For example to find the clock correction for the nustar fpm ! from the caldb version caldb.indx20210202, do ! % quzcif nustar fpm - - CLOCK now now - caldbver=caldb.indx20210202 ! ! Origin: Written for the Calibration Database ! ! Authors/Modification History: ! Ron Zellar Jun 28, 1994 -- Original Version ! MFC 12/16/08 added ability to download remote files (version 1.1) ! MFC 06/14/18 show progress bar and other dignostic output ! if retrieve and chatter > 10 ! MFC 02/15/22 added debug statements and debug variable; added caldbver parameter; updated version to 1.2 !----------------------------------------------------------------------- integer charnum parameter(charnum = 160) ! character(charnum) cif ! character(charnum) instdir character(charnum) filenam(maxret) character(500) contxt, fname, contxt1 character(20) online(maxret) character(4) cextno character(5) ci integer extno(maxret), i, fillen, fcstln, nret ! integer status character(256) rootName, openedFile character(6) subname parameter (subname = 'QCIF') character(7) version parameter (version = '1.2') integer fnamelen, rootlen, endpos, lun, blocksz integer, parameter :: debug = 0 real curtime integer showbar showbar = 1 ! Initialize nret = 0 lun = 10 ! Interrogate the CIF for requested calibration if (debug > 1) then print*, 'MFC quzcif, call of gtcalfq: caldbver = ',caldbver end if call gtcalfq2(chatter, tele, instr, detnam, filt, codenam, date, time, date, time, & expr, caldbver, quality, maxret, filenam, extno, online, nret, nfound, errstat) if ((errstat /= 0).and.(errstat/=110)) return Do 500 i = 1, nret ! Get values needed for display fillen = fcstln(filenam(i)) fname = filenam(i) write(cextno, '(I4)')extno(i) ! Set up display format for file and extno. ! If an element is not 'ONLINE' prepend 'OFFLINE' and ! offline value to display, otherwise use standard display if(online(i).ne.'ONLINE') then contxt = 'OFFLINE: ' // online(i)(:fcstln(online(i))) // ' '& // filenam(i)(:fillen) // cextno else contxt = filenam(i)(:fillen) // cextno endif fnameLen = fcstln(filenam(i)) ! set rootName to the entire filenam string (including http:// or ftp:// path if present) rootLen = fnameLen rootName = filenam(i) ! ! download remote files if needed ! check for urls of form ftp:// or http:// ! ! retrieve=.TRUE. if (retrieve) then if ((filenam(i)(1:6) .eq. 'ftp://') .or.& (filenam(i)(1:7) .eq. 'http://') .or.& (filenam(i)(1:8) .eq. 'https://')) then ! Locate the final '/' in path do 305 endPos = fnameLen, 1, -1 if(filenam(i)(endPos:endPos).eq.'/') goto 405 305 continue 405 continue ! set rootName equal to the stripped off filename (stuff after the final "/" rootName = filenam(i)(endPos + 1:fnameLen) rootLen = fnameLen - endPos if (delexist) then contxt1 = 'Deleting ' // rootName call wtinfo(chatter, 10, 2, contxt1) CALL CLOBBER(rootName, errstat) IF(errstat.NE.0) THEN contxt1 = 'Cannot clobber file ' // rootName call fcecho(contxt1) endif endif contxt = ' Downloading ' // rootName call wtinfo(chatter, 10, 2, contxt) ! Build the CFITSIO extended filename for opening/copying it openedFile = filenam(i)(1:fnameLen) // & '(' // rootName(1:rootLen) // ')' ! openedFile = filenam(i)(1:fnameLen) ! ! Show download progress bar if (chatter.gt.10) then call ftshdwn(showbar) endif ! Show the current timeout setting if (chatter.gt.10) then call ftgtmo(curtime) call ftgiou(lun, errstat) endif call ftopen(lun, openedFile, 1, blocksz, errstat) call ftclos(lun, errstat) if(errstat.ne.0) then call wterrm(subname, version, 'Unable to ' // & 'download calibration file') contxt = ' Problem file is ' // rootName(1:rootLen) call wtinfo(chatter, 0, 1, contxt) contxt = 'Does File already Exist in'& // ' Working Directory?' call wtinfo(chatter, 0, 1, contxt) endif endif filenam(i) = rootName(1:rootLen) endif ! Write info to STDOUT contxt = rootName(:rootLen) // cextno call fcecho(contxt) 500 continue if ((nfound.gt.maxret)) then write(*, *) ' ' write(ci,'(I5)') nfound call stripstring(ci) contxt = 'WARNING: number of files found = ' //ci call fcecho(contxt) !write(ci, '(I5)') nfound contxt = 'To retrieve all entries, set the quzcif maxret parameter to '//ci call fcecho(contxt) write(*,*) ' ' endif return end !--------------------------------------------------------------------- !+GPQZCF2 subroutine gpqzcf2(tele, instr, detnam, filter, codenam, date, & time, expr, maxret, retrieve, chatter, quality, caldbver, delexist, status) implicit none character*(*) tele, instr, detnam, filter, codenam, date, time, expr, caldbver integer maxret, status, chatter, quality logical retrieve, delexist !--------------------------------------------------------------------- ! Description: Gets the parameters for QUZCIF from the parameter ! file. If date or time is input as 'NOW', the system ! date or time is returned from this routine. ! ! Arguments: tele (r) : The value of the 'mission' param ! instr (r) : The value of the 'instrument' param ! detnam (r) : The value of the 'detector' param ! filter (r) : The value of the 'filter' param ! codenam (r) : The value of the 'codename' param ! date (r) : The value of the 'date' param ! time (r) : The value of the 'time' param ! expr (r) : The value of the 'expr' param ! maxret (r) : The maximum number of files to return ! retrieve (r) : download files if true ! chatter (r) : chattiness of operations ! status (r) : The status of the subroutine ! = 0 --> OK ! = 1 --> Problem getting prameters ! ! Origin: Written for the Calibrtion Database ! ! Authors/Modification History: ! Ron Zellar (1993 Feb 3), original version ! Ron Zellar (1993 Jun 14), added prscreen param ! Ron Zellar Jun 28, 1994 -- removed prscreen param, ! path, and extno params. ! Added detnam, filter, expr ! and maxret params. Removed ! "now" feature from date and ! time parameters. ! Jeff Guerber 1999-03-26 -- Removed date param format check ! and reprompt loop, which didn't ! work. ! ! MFC 2008-12-09 -- added retrieve parameter (ver. 1.2) ! MFC 2009-10-13 -- added clobber parameter (ver. 1.3) ! MFC 2022-02-15 -- added caldbver parameter (ver 1.4) !--------------------------------------------------------------------- !-Version 1.4 character(80) contxt character(10), parameter :: version = '1.4' integer errstat integer, parameter :: debug = 0 character(30) subname ! Set Status flag to 'no problem!' status = 0 ! 3Feb00 (MJT) need to initialize errstat errstat = 0 ! initialize subname subname = 'gpqzcf2 '//version ! Get mission parameters call uclgst('mission', tele, errstat) ! If there's an error getting mission, return if(errstat/=0)then contxt = 'cannot get mission parameter' call fcerr(contxt) status = 1 return endif ! Get instrument parameter call uclgst('instrument', instr, errstat) ! If there's an error getting instrument, return if(errstat/=0)then contxt = trim(subname) // ' Cannot get instrument parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get detector parameter call uclgst('detector', detnam, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get detector parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get filter parameter call uclgst('filter', filter, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get filter parameter' call fcerr(trim(contxt)) return endif ! Get codename parameter call uclgst('codename', codenam, errstat) ! If there's an error getting codename, return if(errstat/=0)then contxt = trim(subname) // ' Cannot get codename parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get date parameter call uclgst('date', date, errstat) ! If there's an error getting date, return if(errstat/=0)then contxt = trim(subname) // ' Cannot get date parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get time parameter call uclgst('time', time, errstat) ! If there's an error getting time, return if(errstat/=0)then contxt = trim(subname) // ' Cannot get time parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the expr parameter call uclgst('expr', expr, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the expr parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the maxret parameter call uclgsi('maxret', maxret, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the maxret parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the retrieve parameter call uclgsb('retrieve', retrieve, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the retrieve parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the clobber parameter call uclgsb('clobber', delexist, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the clobber parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the chatter parameter call uclgsi('chatter', chatter, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the chatter parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the quality parameter call uclgsi('quality', quality, errstat) if (errstat/=0) then contxt = trim(subname) // ' Cannot get the quality parameter' call fcerr(trim(contxt)) status = 1 return endif ! Get the caldbver parameter call uclgst('caldbver', caldbver, errstat) if (debug > 1) then print*, 'MFC gpqzcf: caldbver = ',caldbver end if if (errstat/=0) then contxt = trim(subname) // ' Cannot get the caldbver parameter' call fcerr(trim(contxt)) status = 1 return endif return end !+PPQZCF subroutine ppqzcf(nfound) implicit none integer nfound !--------------------------------------------------------------------- ! Description: Returns the parameters for QUZCIF to the parameter ! file. ! ! Arguments: nfound (i): the number of entries matching inputs ! ! Origin: Written for the Calibrtion Database ! ! Authors/Modification History: ! Ron Zellar (1993 Feb 3), original version ! Ron Zellar Jun 28, 1994 -- path and extno are no ! longer returned parameters ! Param nfound added !--------------------------------------------------------------------- !-Version 1.1 character(80) contxt integer errstat ! Return the nfound param to par file ! 11Jan00 (MJT) add errstat initialization errstat = 0 call uclpsi('nfound', nfound, errstat) if(errstat.ne.0) then contxt = 'Problem returning nfound param' call fcerr(contxt) endif return end !****************************************************************************** ! SUBROUTINE: ! clobber ! ! DESCRIPTION: ! This routine clears the way to use the file named filenam. ! It deletes the file named filenam (under VMS, it deletes ! the highest numbered version of filenam.) Thus, it leaves ! filenam available for an OPEN(...,STATUS='NEW') statement. ! ! AUTHOR/DATE: ! Lawrence Brown 7/12/94 ! ! MODIFICATION HISTORY: ! ! NOTES: ! To add clobber (overwrite) capability to an ftool, put lines like ! the following in the parameter fetching routine: ! ! LOGICAL DELEXIST ! character(160) OUTFILE ! INTEGER STATUS ! CALL UCLGSB('CLOBBER', DELEXIST, STATUS) ! IF (STATUS .NE. 0) THEN !C Probably means there wasn't a clobber field in the .par file ! STATUS=0 ! ELSE IF(DELEXIST) THEN ! CALL CLOBBER(OUTFILE,STATUS) ! IF(STATUS.NE.0) THEN !C Do something appropriate. outfile is probably read only. ! ENDIF ! ! Then add: ! ! clobber,b,h,no,,,"Overwrite existing output file? (CAUTION)" ! ! to the par file. ! ! USAGE: ! call clobber(filenam,status) ! ! ARGUMENTS: ! filenam - the file to be "clobbered" ! status - returned error status ! ! PRIMARY LOCAL VARIABLES: ! exists - logical for inquire statements ! lun - logical unit number for clobbering ! ! CALLED ROUTINES: ! !****************************************************************************** subroutine clobber(filenam, status) character*(*) filenam integer status ! logical exists, opened integer lun if(status.ne.0) return inquire(file = filenam, exist = exists) if(exists) then ! get rid of it ! first look for a free logical unit number to use to commit the act with do 10 lun = 99, 10, -1 inquire(lun, opened = opened) if(.not.opened) goto 20 10 continue ! failed to find free lun status = 1 goto 999 20 continue open(lun, file = filenam, status = 'old', err = 30) close(lun, status = 'delete', err = 40) ! we're done goto 999 30 continue ! error opening file status = 2 goto 999 40 continue ! error closing and deleting file (This could really mess up the main ! code, so check for it status = 3 endif 999 continue return end