subroutine dtcrdappt (eofflg, indflg) c search through appointment files for entries matching range of hash values. c opens files if EOFFLG set on entry. INDFLG controls whether indirect files c should be opened as encountered, and whether caller wants to look at indirect c entry or not: c INDFLG c -1 No processing @ c 0 Normal processing c +1 Return before opening @ c EOFFLG Entry Exit c -1 Initialize EOF return c 0 Normal re-entry Normal return, valid entry c +1 Open @ file Return for @ filename found c Processes both old- and new-format files c Old: yymmddhhh appt (possibly no blank between HHH & APPT) c New: yyyymmddhhhh appt c Created 19850802, CG, using some code removed from DAY subroutine implicit none integer eofflg, indflg ! i/o, i only include 'comdtc.inc/nolist' include 'apptdtc.inc/nolist' include 'defcentry.inc/list' ! Default century for old format character*1 nullch /0/ ! Old old files had trailing NULs integer i, ij, lth, istrend, nunit include 'stmtfunc.for/nolist' c Begin code c *** type 950, irqhash c 950 format(2z9.8) if (eofflg .lt. 0) ! Start scan 1 then nunit=1 close(1) Open (unit=nunit, file=FNAME, status='OLD', 1 form='FORMATTED', readonly, err=99) eofflg = 0 c *** type *, ' Opened file' end if c loop back up here to continue reading and processing input file: do while (eofflg .ge. 0) 900 format(q, a) ! Read all 901 format(3i2, i3) ! Decode old 902 format(i4, 2i2, i3) ! Decode new if (eofflg .gt. 0) ! must open indirect file 1 then eofflg = 0 c *** type 951, work(istart) c *** 951 format (' ', a) nunit = 2 close(2) Open (unit=nunit, file=work(istart), status='old', 1 form='formatted', readonly, 2 carriagecontrol='LIST', err=1067) end if read (nunit, 900, end=400), lth, workstr c *** type *, ' ', workstr do i = min0(lth, iwrkln), 1, -1 if ((workstr(i:i) .ne. ' ') ! Look for non-blank 1 .and. (workstr(i:i) .ne. nullch)) ! & non-null 2 go to 10 ! Break end do i = 1 ! All blank entry ??? 10 lth = i c String is filled with blanks regardless of length of record if (chnumeric(workstr(10:10))) 1 then ! new format read(workstr, 902, err=30) ihy, ihm, ihd, iht istart = 12 ! Index of first valid character c *** type *, ' New format' else ! Old format 30 continue ! Retry old read(workstr, 901, err=300) ihy, ihm, ihd, iht ihy = ihy + icntry ! Insert current century istart = 10 ! Assume old, old format c *** type *, ' Old format' end if ! (workstr(10) is numeric) if (workstr(istart:istart) .eq. ' ') 1 istart = istart + 1 ! Index of first valid character iwkln = max0((lth - istart) + 1, 1) istrend = (istart + iwkln) - 1 iaptln = max0(min0(iwkln, icmln), 1) if (ihm .eq. 99) 1 then ihy = 9999 ! set all fields ihd = 99 iht = 999 if ((indflg .ge. 0) .and. (nunit .eq. 1)) 1 then call fnscan(work(istart), icmln - istart + 1, 1 iwkln, ij) ! Common code to check filename if (ij .ne. 0) 1 then ! Skip if no file c *** type *, ' IJ = ', ij eofflg = 1 if (indflg .gt. 0) 1 then apptstr = workstr(istart:istrend) return ! DAY, STRIP want a look end if ! Found 1 end if ! non-null file-name end if ! valid place for indirect else ! not filename flag in record irchash = ihymd(ihy, ihm, ihd) ! Compute hash for record c *** type 950, irchash if ((irchash .ge. irqhash(1)) 1 .and. (irchash .le. irqhash(2))) 2 then ! Found record within range, exit apptstr = workstr(istart:istrend) c *** type *, ' Returning' return ! Break out of loop 400 continue ! no more appointments left in file. c *** type *, ' EOF' if (nunit .eq. 1) ! Which file were we reading? 1 then eofflg = -1 ! real end of file else 1067 close (2) ! Error opening indirect file nunit=1 end if ! Which unit had EOF end if ! Hash range test end if ! type of record 300 continue ! Error decoding y/m/d/t fields end do ! Read next line from current file close (1) ! Close first-level 99 continue ! Failed first open end