C - Find a file anywhere in the tree from here. C Written in Fortran IV, routine is PR1ME dependent. C Routine must NOT be built as an EPF as it relies upon the C implicit initialization of SEG or RESUME for some array analysis. C Modification History C --------------------------------------------------------------------------- C 10/ /85 Allen Egerton RN 1.0, Original Coding/Design. C Tree traversing routine lifted from CLEAN.DISK routine. C C 03/ /86 Allen Egerton RN 1.1, modified to use partial string as C input search parameter. C C 02/ /88 Allen Egerton RN 1.2, modified to handle error codes C from G$PASS against LUR rights. C C 09/26/89 Allen Egerton RN 2.0, Total re-write for Rev 20.2.8 C using newer file system routines. C C 11/21/89 Allen Egerton RN 2.1, Modified attach logic. C C 05/08/90 Allen Egerton RN 3.0, Added -M, -A, -C, C -MA, -AA, -CA, -MB, -AB, & -CB arguments. C Modified to use -NAME as an optional argument, rather than C the previous versions which just grabbed the command line. C Added -BRIEF option to suppress type/date info. C C 09/28/90 Allen Egerton RN 3.1, Fixed date checking logic C C 02/08/91 Allen Egerton RN 4.0, Real-Int float overflow problem. SUBROUTINE MAIN $INSERT SYSCOM>KEYS.INS.FTN $INSERT SYSCOM>ERRD.INS.FTN IMPLICIT INTEGER*2 (A-Z) INTEGER*2 RDBUFF(40), /* For parsing command line. + RDINFO(8), /* Ditto + RDBUF2(40), /* For parsing date. + RDINF2(8) /* Ditto. INTEGER*4 TOKEN4 /* Make parsing easy EQUIVALENCE (RDBUFF, TOKEN4) INTEGER*2 LFNAME(16), /* Name of file to look for. + HMF, /* How many found? + TYPES(28) /* File types to display LOGICAL*2 FLMOD, /* Flag Modified + FLACC, /* Flag Accessed + FLCRE, /* Flag Created + FLAFT, /* Flag After + FLBEF, /* Flag Before + FLNAME, /* Flag Name + LSUB$A, FOUND, /* For name comparisons + BRIEF /* Brief display? INTEGER*4 I4CBEF, /* CREATED BEFORE search value + I4MBEF, /* MODIFIED BEFORE search value + I4ABEF, /* ACCESSED BEFORE search value + I4CAFT, /* CREATED AFTER search value + I4MAFT, /* MODIFIED AFTER search value + I4AAFT, /* ACCESSED AFTER search value + I4CRE, /* CREATED + I4MOD, /* MODIFIED + I4ACC /* ACCESSED C *** Arrays for following the tree structure. PARAMETER LEVELS = 200 /* Max levels of file system INTEGER*2 T$NAME(39, LEVELS), /* File Names in PLP format + T$UNIT(LEVELS), /* Unit file opened on. + T$LEVL, /* Level currently on. + CAPNAM(320) /* Current Attach Point C *** Individual entry in file system. INTEGER*2 ENTRY(31), /* File system entry + ECW, /* Entry Control Word, Type and Length + FILNAM(21), /* Filename & password in PLP format + PWPBIT, /* Password protection bit + NDPB, /* Non default protection bit + FINFO, /* 16 bits of file info + SPARE, + SPARE2, + TRUNC, /* File truncated by fix_disk? + DATES(14) /* For display purposes. INTEGER*2 OPASS(3), /* Owner password to ufd + NPASS(3) /* Non-Owner password to ufd. C *** Equivalence entry info into component parts. EQUIVALENCE (ECW, ENTRY(1)), + (PWPBIT, ENTRY(18)), + (NDPB, ENTRY(19)), + (FINFO, ENTRY(20)), + (DATEM, ENTRY(21)), + (TIMEM, ENTRY(22)), + (SPARE1, ENTRY(23)), + (SPARE2, ENTRY(24)), + (TRUNC, ENTRY(25)), + (DATEB, ENTRY(26)), + (TIMEB, ENTRY(27)), + (DATEC, ENTRY(28)), + (TIMEC, ENTRY(29)), + (DATEA, ENTRY(30)), + (TIMEA, ENTRY(31)) DATA TYPES /'Sam Dam Segsam Segdam ', + 'Subufd Acat Unknown '/ C *** Program Header. WRITE (1, 1) 1 FORMAT (/, '[Find.File, Rev 20, RN 4.0, February 1991]') C *** See if software is licensed. CALL CHKLIC ('FIND.FILE ') C *** Initialize flags. FLMOD = .FALSE. FLACC = .FALSE. FLCRE = .FALSE. FLAFT = .FALSE. FLBEF = .FALSE. FLNAME = .FALSE. BRIEF = .FALSE. I4CBEF = 000000 I4MBEF = 000000 I4ABEF = 000000 I4CAFT = 000000 I4MAFT = 000000 I4AAFT = 000000 100 CONTINUE C *** Parse token from command line. CALL RDTK$$ (1, RDINFO, RDBUFF, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE', 5, 'FIND.FILE', 9) IF (RDINFO(2) .EQ. 0) GO TO 200 /* Finished parsing C *** Evaluate token. IF (TOKEN4 .EQ. '-NAM') GO TO 110 IF (TOKEN4 .EQ. '-BRI') GO TO 125 IF (TOKEN4 .EQ. '-C ') GO TO 140 IF (TOKEN4 .EQ. '-M ') GO TO 145 IF (TOKEN4 .EQ. '-A ') GO TO 150 IF (TOKEN4 .EQ. '-CA ') GO TO 155 IF (TOKEN4 .EQ. '-MA ') GO TO 160 IF (TOKEN4 .EQ. '-AA ') GO TO 165 IF (TOKEN4 .EQ. '-CB ') GO TO 170 IF (TOKEN4 .EQ. '-MB ') GO TO 175 IF (TOKEN4 .EQ. '-AB ') GO TO 180 IF (TOKEN4 .EQ. '-HEL') GO TO 195 C *** Unrecognized token. CALL TNOUA ('Unrecognized token: ''', 21) CALL TNOUA (RDBUFF, RDINFO(2)) CALL TNOUA ('''. ', 4) CALL ERRPR$ (K$NRTN, E$NULL, + 'Try FIND.FILE -HELP.', 20, 'FIND.FILE', 9) 110 CONTINUE C *** -NAM CALL RDTK$$ (1, RDINFO, LFNAME, 16, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE NAME', 10, 'FIND.FILE', 9) IF (RDINFO(2) .EQ. 0) CALL ERRPR$ (K$NRTN, E$NULL, + 'You must specify a filename for -NAME argument.', 47, + 'FIND.FILE', 9) LFFL = RDINFO(2) FLNAME = .TRUE. GO TO 100 125 CONTINUE C *** -BRIEF BRIEF = .TRUE. GO TO 100 140 CONTINUE C *** -Created CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 141, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 141 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4CBEF) I4CAFT = (I4CBEF - 000001) I4CBEF = (I4CBEF + 000001) FLCRE = .TRUE. FLBEF = .TRUE. FLAFT = .TRUE. GO TO 100 145 CONTINUE C *** -Modified CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 146, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 146 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4MBEF) I4MAFT = (I4MBEF - 000001) I4MBEF = (I4MBEF + 000001) FLMOD = .TRUE. FLAFT = .TRUE. FLBEF = .TRUE. GO TO 100 150 CONTINUE C *** -Accessed CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 151, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 151 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4ABEF) I4AAFT = (I4ABEF - 000001) I4ABEF = (I4ABEF + 000001) FLACC = .TRUE. FLAFT = .TRUE. FLBEF = .TRUE. GO TO 100 155 CONTINUE C *** -CA CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 156, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 156 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4CAFT) FLCRE = .TRUE. FLAFT = .TRUE. GO TO 100 160 CONTINUE C *** -MA CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 161, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 161 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4MAFT) FLMOD = .TRUE. FLAFT = .TRUE. GO TO 100 165 CONTINUE C *** -AA CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 166, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 166 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4AAFT) FLACC = .TRUE. FLAFT = .TRUE. GO TO 100 170 CONTINUE C *** -CB CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 171, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 171 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4CBEF) FLCRE = .TRUE. FLBEF = .TRUE. GO TO 100 175 CONTINUE C *** -MB CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 176, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 176 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4MBEF) FLMOD = .TRUE. FLBEF = .TRUE. GO TO 100 180 CONTINUE C *** -AB CALL RDTK$$ (1, RDINF2, RDBUF2, 40, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'PARSE DATE', 10, 'FIND.FILE', 9) DECODE (8, 181, RDBUF2, ERR = 190) TEMPMM, TEMPDD, TEMPYY 181 FORMAT (I2, X, I2, X, I2) CALL AIDATE (TEMPMM, TEMPDD, TEMPYY, I4ABEF) FLACC = .TRUE. FLBEF = .TRUE. GO TO 100 190 CONTINUE C *** Invalid format of date. CALL TNOUA ('Invalid date specified for ''', 28) CALL TNOUA (RDBUFF, RDINFO(2)) CALL TNOUA ('''.', 2) CALL ERRPR$ (K$NRTN, E$NULL, + 'Try FIND.FILE -HELP.', 20, 'FIND.FILE', 9) 195 CONTINUE C *** -HEL WRITE (1, 196) 196 FORMAT ('Help/Usage screen for Find.File', + //, 'Syntax: Find.File -Token arg -Token2 arg etc.', + //, 'Legitimate Tokens are:', + /, '-NAME filename Specifies name or partial name to ', + 'search for.', + /, '-C mm/dd/yy Find files CREATED ON specific date.', + /, '-M mm/dd/yy Find files MODIFIED ON specific date.', + /, '-A mm/dd/yy Find files ACCESSED ON specific date.', + /, '-CB mm/dd/yy Find files CREATED BEFORE date.', + /, '-MB mm/dd/yy Find files MODIFIED BEFORE date.', + /, '-AB mm/dd/yy Find files ACCESSED BEFORE date.', + /, '-CA mm/dd/yy Find files CREATED AFTER date.', + /, '-MA mm/dd/yy Find files MODIFIED AFTER date.', + /, '-AA mm/dd/yy Find files ACCESSED AFTER date.', + /, 'Combinations MAY be used, but at least ONE selective ', + 'argument is REQUIRED.', + /, '-BRIEF Suppress some output.', + /, '-HELP Produce this listing.', +) CALL EXIT CALL ERRPR$ (K$NRTN, E$NULL, 'No Re-Starts.', 12, + 'FIND.FILE', 9) 200 CONTINUE C *** Check first to see if we got any command line arguments. IF (FLMOD) GO TO 210 IF (FLACC) GO TO 210 IF (FLCRE) GO TO 210 IF (FLAFT) GO TO 210 IF (FLBEF) GO TO 210 IF (FLNAME) GO TO 210 CALL TNOUA ('At least ONE criteria-selective argument ', 41) CALL TNOU ('must be supplied on the command line.', 37) CALL ERRPR$ (K$NRTN, E$NULL, + 'Try FIND.FILE -HELP for syntax.', 31, 'FIND.FILE', 9) 210 CONTINUE C *** Check for conflicting arguments. IF ((I4MBEF .NE. 000000) .AND. (I4MAFT .NE. 000000) .AND. + (I4MBEF .LT. I4MAFT)) CALL ERRPR$ (K$NRTN, E$NULL, + 'Modify dates force null set.', 28, 'FIND.FILE', 9) IF ((I4CBEF .NE. 000000) .AND. (I4CAFT .NE. 000000) .AND. + (I4CBEF .LT. I4CAFT)) CALL ERRPR$ (K$NRTN, E$NULL, + 'Create dates force null set.', 28, 'FIND.FILE', 9) IF ((I4ABEF .NE. 000000) .AND. (I4AAFT .NE. 000000) .AND. + (I4ABEF .LT. I4AAFT)) CALL ERRPR$ (K$NRTN, E$NULL, + 'Access dates force null set.', 28, 'FIND.FILE', 9) CXX WRITE (1, 211) I4CAFT, I4CBEF, I4MAFT, I4MBEF, I4AAFT, I4ABEF 211 FORMAT ('Created after ', I8, ' and before ', I8, + /, 'Modified after', I8, ' and before ', I8, + /, 'Accessed after', I8, ' and before ', I8) C *** Initialize for search and display current attach point. T$LEVL = 1 NORITC = 0 CALL TONL CALL TNOUA ('''*''=', 4) CALL GPATH$ (K$CURA, DUMMY, CAPNAM, 320, CAPLEN, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'Unable to get Attach point.', 27, + 'FIND.FILE', 9) CALL TNOU (CAPNAM, CAPLEN) CALL TONL 250 CONTINUE C *** Open current directory for reading, (start processing new level). CALL SRCH$$ (K$READ+K$GETU, K$CURR, 0, T$UNIT(T$LEVL), T, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'Opening ufd', 11, 'FIND.FILE', 9) 275 CONTINUE C *** Read an entry in current directory. CALL DIR$RD (K$READ, T$UNIT(T$LEVL), LOC(ENTRY), 31, ERROR) IF (ERROR .EQ. E$EOF) GO TO 600 /* End dir, go Up a level CALL ERRPR$ (K$NRTN, ERROR, 'Reading Ufd', 11, 'FIND.FILE', 9) C *** Set filetype. TYPE = RT(FINFO, 8) + 1 IF (TYPE .GT. 6) TYPE = 7 C *** Move ENTRY into FILNAM, (PLP formatted variable). NWORDS = 0 DO 280 IW = 2, 17 FILNAM(IW) = ENTRY(IW) IF (FILNAM(IW) .NE. ' ') NWORDS = (NWORDS + 1) 280 CONTINUE NCHARS = LS(NWORDS, 1) IF (RT(FILNAM(NWORDS + 1), 8) .EQ. :240) NCHARS = (NCHARS - 1) FILNAM(1) = NCHARS 300 CONTINUE C *** Can we eliminate file on basis of name? IF (.NOT. (FLNAME)) GO TO 310 FOUND = LSUB$A (LFNAME, LFFL, 1, LFFL, + FILNAM(2), FILNAM(1), 1, FILNAM(1), + FNDBGN, FNDEND) IF (.NOT. (FOUND)) GO TO 480 /* Don't display 310 CONTINUE C *** Can we eliminate file on basis of date created? MMMCRE = RS(LS(DATEC,7),12) DDDCRE = RT(DATEC,5) YYYCRE = RS(DATEC,9) IF (.NOT. (FLCRE)) GO TO 320 CALL AIDATE (MMMCRE, DDDCRE, YYYCRE, I4CRE) IF ((I4CBEF .GE. 000000) .AND. (I4CRE .GE. I4CBEF)) + GO TO 480 IF ((I4CAFT .GT. 000000) .AND. (I4CRE .LE. I4CAFT)) + GO TO 480 320 CONTINUE C *** Can we eliminate file on basis of date modified? MMMMOD = RS(LS(DATEM,7),12) DDDMOD = RT(DATEM,5) YYYMOD = RS(DATEM,9) IF (.NOT. (FLMOD)) GO TO 330 CALL AIDATE (MMMMOD, DDDMOD, YYYMOD, I4MOD) IF ((I4MBEF .GT. 000000) .AND. (I4MOD .GE. I4MBEF)) + GO TO 480 IF ((I4MAFT .GT. 000000) .AND. (I4MOD .LE. I4MAFT)) + GO TO 480 330 CONTINUE C *** Can we elimininate file on basis of date accessed? MMMACC = RS(LS(DATEA,7),12) DDDACC = RT(DATEA,5) YYYACC = RS(DATEA,9) CALL AIDATE (MMMACC, DDDACC, YYYACC, I4ACC) IF (.NOT. (FLACC)) GO TO 340 IF ((I4ABEF .GT. 000000) .AND. (I4ACC .GE. I4ABEF)) + GO TO 480 IF ((I4AAFT .GT. 000000) .AND. (I4ACC .LE. I4AAFT)) + GO TO 480 340 CONTINUE C *** Next test!! 400 CONTINUE C *** File meets search criteria. HMF = (HMF + 1) /* (How Many Found?) C *** Display full output? IF (BRIEF) GO TO 410 C *** Display file TYPE literal. TPTR = ((TYPE - 1) * 4) + 1 CALL TNOUA (TYPES(TPTR), 8) C *** Move Dates CREATED, MODIFIED & ACCESSED into A2 format and display. ENCODE (28, 401, DATES) MMMCRE, DDDCRE, YYYCRE, + MMMMOD, DDDMOD, YYYMOD, + MMMACC, DDDACC, YYYACC 401 FORMAT (3(B'Z#', 2('/', B'##'), X), X) CALL TNOUA (DATES, 28) 410 CONTINUE C *** Output name. CALL TNOUA ('*>', 2) C *** See if interim levels to display. IF (T$LEVL .EQ. 1) GO TO 430 /* Nope! C *** Display interim levels. DO 420 I = 2, T$LEVL CALL OUTPUT(T$NAME(2, I), T$NAME(1, I)) CALL TNOUA ('>', 1) 420 CONTINUE 430 CONTINUE C *** Display the filename now. CALL TNOU (FILNAM(2), FILNAM(1)) 480 CONTINUE C *** See if file is a 'SPECIAL' one, (MFD, DKSRAT, BOOT or BADSPT). SPECL = RS(LS(FINFO, 3), 15) IF (SPECL .EQ. 1) GO TO 275 /* SPECIAL file IF (TYPE .NE. 5) GO TO 275 /* Not Sub-Ufd 500 CONTINUE C *** Found a subufd to attach down into. T$LEVL = (T$LEVL + 1) C *** Get the password. CALL GPAS$$ (FILNAM(2), FILNAM(1), OPASS, NPASS, ERROR) IF (ERROR .NE. 0) GO TO 520 C *** Move the password into array if needed. IF (OPASS(1) .EQ. ' ') GO TO 520 /* No password FILNAM(1) = (FILNAM(1) + 1) /* Add the space DO 510 ICPASS = 1, 6 /* Now add the password. IWP = RS((ICPASS + 1), 1) PWORD = OPASS(IWP) PCHAR = RS(PWORD, 8) IF (RT(ICPASS, 1) .EQ. 0) PCHAR = RT(PWORD, 8) FILNAM(1) = (FILNAM(1) + 1) IWF = RS((FILNAM(1) + 1), 1) FWORD = FILNAM(IWF + 1) FCHAR = LT(FWORD, 8) IF (RT(FILNAM(1), 1) .EQ. 1) FCHAR = RT(FWORD, 8) IF (RT(FILNAM(1), 1) .EQ. 1) PCHAR = LS(PCHAR, 8) FWORD = OR(FCHAR, PCHAR) FILNAM(IWF + 1) = FWORD 510 CONTINUE 520 CONTINUE C *** Move subufd name into array. DO 525 IW = 1, 21 T$NAME (IW, T$LEVL) = FILNAM(IW) 525 CONTINUE CALL AT$REL (K$SETC, FILNAM, ERROR) IF (ERROR .NE. 0) GO TO 590 GO TO 250 /* Open new level 590 CONTINUE C *** Error attaching down into new level. NORITC = (NORITC + 1) T$LEVL = (T$LEVL - 1) C *** Display meaningful error message. CALL TNOUA ('Error attaching to ', 19) CALL TNOUA (CAPNAM, CAPLEN) CALL TNOUA ('>', 1) C *** See if interim levels to display. IF (T$LEVL .EQ. 1) GO TO 596 /* Nope! C *** Display interim levels. TEMP = T$LEVL - 1 DO 595 I = 2, TEMP CALL OUTPUT(T$NAME(2, I), T$NAME(1, I)) CALL TNOUA ('>', 1) 595 CONTINUE 596 CONTINUE CALL TNOU (FILNAM(2), FILNAM(1)) GO TO 275 /* Continue current level 600 CONTINUE C *** Finished processing this level, time to go up a level. C *** Start by closing out current level. CALL SRCH$$ (K$CLOS, 0, 0, T$UNIT(T$LEVL), T, ERROR) C *** Set pointer to previous level. T$LEVL = (T$LEVL - 1) C *** Begin working towards level above, begin by going to top of tree. CALL AT$HOM (K$SETC, ERROR) CALL ERRPR$ (K$NRTN, ERROR, 'Going HOME', 10, 'FIND.FILE', 9) C *** At top of tree now, there are three possible situations: C *** 1) T$LEVL = 0 -> End of level 1 directory, End program. C *** 2) T$LEVL = 1 -> Reading top level of tree, keep going. C *** 3) T$LEVL > 1 -> Reading subordinate level of tree, keep going. IF (T$LEVL .EQ. 0) GO TO 1000 /* All done. IF (T$LEVL .EQ. 1) GO TO 275 /* Keep reading top level C *** We have to continue reading a subordinate level, so let's position C *** to the level from the top level before we continue reading. DO 610 LEVEL = 2, T$LEVL CALL AT$REL (K$SETC, T$NAME(1, LEVEL), ERROR) CALL ERRPR$ (K$NRTN, ERROR, T$NAME(2, LEVEL), + T$NAME(1, LEVEL), 'FIND.FILE', 9) 610 CONTINUE C *** Attached back to current level, go read next entry. GO TO 275 1000 CONTINUE C *** Done processing tree so let's close the first unit. CALL SRCH$$ (K$CLOS, 0, 0, T$UNIT(1), T, ERROR) C *** Now output a file count WRITE (1, 1001) HMF 1001 FORMAT (B'ZZ,ZZ#', ' files meeting search criteria found.') IF (NORITC .NE. 0) WRITE (1, 1002) NORITC 1002 FORMAT ('Ufds skipped, (insufficient access): ', B'ZZ,ZZ#') C *** & End program. CALL EXIT CALL ERRPR$ (K$NRTN, E$NULL, 'NO RESTARTS', 11, 'FIND.FILE', 9) END C - Output printable characters of a string. C Written in Fortran IV, routine is PR1ME dependent. C Allen Egerton, March 1989 SUBROUTINE OUTPUT (STRING, STRLEN) IMPLICIT INTEGER*2 (A-Z) INTEGER*2 STRING(1) DO 100 IC = 1, STRLEN IW = RS((IC + 1), 1) CHAR = RS(STRING(IW), 8) IF (RT(IC, 1) .EQ. 0) CHAR = RT(STRING(IW), 8) IF ((CHAR .GT. :237) .AND. + (CHAR .LT. :377)) CALL T1OU (CHAR) 100 CONTINUE RETURN END C - Subroutine to return absolute value of a date in I4 variable. C Given Numeric Month, Day, & Year, routine calculates an absolute value C and returns it in an I4 variable. If Date passed is invalid, routine C returns a -1 to be checked by caller. C Written in Fortran IV, routine is PR1ME dependent. C Modification History C --------------------------------------------------------------------------- C 04/ /84 Allen Egerton RN 1.0, Original design & coding for LFD C 05/08/90 Allen Egerton RN 1.1, cosmetic work on comments. C 02/08/91 Allen Egerton RN 1.2, real->integer mod because of C overflow, INT function removed. SUBROUTINE AIDATE (MONTH, DAY, YEAR, DAY4) IMPLICIT INTEGER*2 (A-Z) INTEGER*2 MONTH, /* Integer format + DAY, /* ditto + YEAR, /* ditto + DAYS(12) /* Array holding days to month. INTEGER*4 DAY4 /* Returned argument. REAL*4 RDAY4 /* Source for DAY4 DATA DAYS/31,28,31,30,31,30,31,31,30,31,30,31/ C *** Move values, so originals can be retained for caller. MM = MONTH DD = DAY YY = YEAR C *** checks for valid dates. IF ((MM .LT. 1) .OR. (MM .GT. 12)) GO TO 900 IF ((YY .LT. 0) .OR. (YY .GT. 99)) GO TO 900 C *** Find out if current year is leap year. DAYS(2) = 28 IF (MOD(YY,4) .EQ. 0) DAYS(2) = 29 /* Normal Leap Year IF (MOD(YY,100) .EQ. 0) DAYS(2) = 28 /* End-Century Adjust IF (MOD(YY,400) .EQ. 0) DAYS(2) = 29 /* Fourth Cent. Adjust C *** Check to see if day is valid. IF ((DD .LT. 1) .OR. (DD .GT. DAYS(MM))) GO TO 900 C *** Now find the Julian Date, (Day of Year) C *** Set up for Summing Loop. IMM = (MM - 1) IDOY = DD /* Internal Day of year = current day IF (MM .EQ. 1) GO TO 110 /* Skip Summing Loop C *** Sum the Days of Previous Months. DO 100 CNTR = 1, IMM IDOY = (IDOY + DAYS(CNTR)) 100 CONTINUE 110 CONTINUE C *** Now that we have the numerical Day of Year for this year, C *** Sum up the previous years, (those after 1900). RDAY4 = (((YY - 1) * 365.25) + IDOY) DAY4 = RDAY4 /* IMPLICIT CONVERSION C *** And Return to Calling Routine. RETURN 900 CONTINUE C *** Invalid date passed. DAY4 = -1 RETURN END