************************************************************** PROGRAM DSKLST ! [27,3] FLX FUNCTION -- SORT AND LIST FILE DIRECTORIES ORIGINAL VERSION -- 10/14/79 ORIGINAL PROGRAMMER -- P.M.CHAMBERLAIN COLOR PRINT AND PROCESSING DIV. EASTMAN KODAK CO. DALLAS, TX LAST CHANGE DATE, BY -- 9/30/80, PMC ************************************************************** INTEGER WORK (4096) DESCRIBE-SORT-FILE DEFINE-CONSTANTS DEFINE-FILE-HEADER-EQUIVALENCES FORMAT-STATEMENTS ==== START OF EXECUTABLE PROGRAM STEPS GET-SORT-TYPE IF (SORT.EQ.1) LIST-INSTRUCTIONS IF (SORT.EQ.5) REV = .TRUE. DEFINE-SORT-FILE ENTER-FILES-TO-BE-LISTED GET-DEFAULT-UIC REPEAT UNTIL (DONE) CHECK-FOR-DEVICE-REQUEST WHEN (SORT.EQ.6) LIST-LOCKED-FILES ELSE CHECK-FOR-UIC-REQUEST CHECK-FOR-NAME-REQUEST CHECK-FOR-TYPE-REQUEST ==== GET ADDRESS OF MASTER DIRECTORY HEADER ==== (MASTER DIRECTORY IS ALWAYS FILE 4) CALL HEDBLK (3,IDXHED,4,IREC,IERR,1) READ-MASTER-DIRECTORY-HEADER ==== READ EACH BLOCK OF RECORDS IN THE MASTER DIRECTORY CALL DBLKS (1,MSTHED) REPEAT UNTIL (ICOUNT.EQ.0) ==== MADR IS THE ADDRESS OF THE FIRST LOGICAL BLOCK ==== IN A CONTIGUOUS GROUP. ICOUNT IS THE NUMBER OF ==== BLOCKS IN THE CONTIGUOUS GROUP. CALL DBLK (1,MADR,ICOUNT) UNLESS (ICOUNT.EQ.0) ==== READ EACH BLOCK IN THE MASTER DIRECTORY DO (MBLK=0,ICOUNT-1) READ-MASTER-DIRECTORY-FILE-RECORD ==== CHECK ALL THE UIC'S INDEXED BY THE MASTER DIRECTORY ==== CHECK EACH ENTRY IN THIS BLOCK OF THE MASTER DO (MX=1,256,8) CALL R50ASC (3,MSTREC(MX+3),TEST) WHEN (TEST(3).GE."60.AND.TEST(3).LE."67) MORE = .FALSE. ELSE MORE = .TRUE. UNLESS (MORE) UNLESS (MSTREC(MX).EQ.0.OR.MSTREC(MX+2).NE.0) WHEN (ALLGRP) FOUND = .TRUE. ELSE CHECK-GROUP-NUMBER IF (FOUND) WHEN (ALLMEM) FOUND = .TRUE. ELSE CHECK-MEMBER-NUMBER IF (FOUND) OUTPUT-UIC UNLESS (ERROR) GET-DIRECTORY-FILE-NUMBER ==== FIND FILE LOCATION ON DISK AND READ UIC DIRECTORY HEADER CALL HEDBLK (3,IDXHED,FILNUM,DADR,IERR) READ-UIC-DIRECTORY-HEADER ==== LOOP THRU THE ENTIRE DIRECTORY CALL DBLKS (2,UICHED) REPEAT UNTIL (JCOUNT.EQ.0) CALL DBLK (2,JADR,JCOUNT) UNLESS (JCOUNT.EQ.0) DO (UBLK = 0,JCOUNT-1) READ-UIC-FILE-RECORD ==== CHECK EACH ENTRY IN UIC DIRECTORY DO (UX=0,255,8) UNLESS (UICREC(UX+1).EQ.0.OR.UICREC(UX+3).NE.0) MOVE-NAME MOVE-TYPE WHEN (ALLNAM) FOUND = .TRUE. ELSE CHECK-NAME IF (FOUND) WHEN (ALLTYP) CONTINUE ELSE CHECK-TYPE FIN IF (FOUND) WRITE-DATA-TO-SORT-FILE FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN FIN SORT-OUTPUT-FILE PRINT-AND-DELETE-OUTPUT-FILE IF (SORT.EQ.6) WRITE (3,112) LEND,LEND,INUSE STOP TO DESCRIBE-SORT-FILE BYTES 1-2 A1 2-DIGIT YEAR BYTE 3 MONTH (1-12) BYTES 4-5 A1 2-DIGIT DAY OF MONTH BYTES 6-14 A1 FILE NAME BYTES 15-17 A1 FILE TYPE BYTES 18-19 INTEGER FILE VERSION NUMBER BYTES 21-22 INTEGER DISK BLOCKS ALLOCATED BYTE 23 A1 BLANK OR L, FOR LOCKED FILE BYTE 24 A1 BLANK OR C, FOR CONTIGUOUS FILES BYTES 25-28 A1 PHYSICAL UNIT DESCRIPTION BYTES 29-30 OCTAL GROUP NUMBER OF UIC BYTES 31-32 OCTAL MEMBER NUMBER OF UIC FIN TO DEFINE-CONSTANTS INTEGER CHAR, FILHED(256), FILNUM, IDXHED(256) INTEGER IOUT(16), IOSTAT(2), KIND1(3), KIND2(4), KIND3(4) INTEGER LENTH1(3), LENTH2(4), LENTH3(4), LOC1(3), LOC2(4) INTEGER LOC3(4), MSTHED(256), MSTREC(256), PAGE, SORT, TI, Y INTEGER UBLK, UBLKND, UICHED(256), UICREC(256), UPT INTEGER MSTART(2), MADR(2), FILADR(2), IADR(2) INTEGER UPTCT, USTART(2), UX, IREC(2), DADR(2), FADR(2) INTEGER JADR(2) DATA TI/1/, IX/1/, LAST/80/, MASK/"377/ BYTE ALLGRP, ALLMEM, ALLNAM, ALLTYP, ASTER BYTE BFILHED(512), BIDXHED(512), BMSTHED(512), BMSTREC(512) BYTE BUICHED(512), BUICREC(512), BLANK, COLON, COMMA BYTE CONTIG, DEVICE(4), DONE, FOUND, GRP(3), INPUT(80) BYTE LBRAK, LOCKED, MARK, MEM(3), MONTH(36), NAME(9), NAMEND BYTE OPEN, OUTPUT(32), PERIOD, POUND, RBRAK, RDATE(9) BYTE REV, SAVDAT(3), SAVNAM(12), SAVTYP(3), STAT(4) BYTE SAVUIC (4), MORE, TEST(3) BYTE STRING(9), TYPE(3), ZERO DATA LOC1/15,6,10/,LENTH1/2,12,1/,KIND1/1,2,3/ DATA LOC2/15,15,6,10/, LENTH2/2,3,9,1/, KIND2/1,2,2,3/ DATA LOC3/15,1,6,10/, LENTH3/2,5,12,1/, KIND3/1,4,2,3/ EQUIVALENCE (STAT(1),IOSTAT(1)) EQUIVALENCE (BIDXHED(1),IDXHED(1)) EQUIVALENCE (IDXHED(1),WORK(1)) EQUIVALENCE (BMSTREC(1),MSTREC(1)) EQUIVALENCE (MSTREC(1),WORK(257)) EQUIVALENCE (BUICHED(1),UICHED(1)) EQUIVALENCE (UICHED(1),WORK(513)) EQUIVALENCE (BUICREC(1),UICREC(1)) EQUIVALENCE (UICREC(1),WORK(769)) EQUIVALENCE (BMSTHED(1),MSTHED(1)) EQUIVALENCE (MSTHED(1),WORK(1025)) EQUIVALENCE (BFILHED(1),FILHED(1)) EQUIVALENCE (FILHED(1),WORK(1281)) EQUIVALENCE (OUTPUT(1),IOUT(1)) EQUIVALENCE (NAME(1),OUTPUT(6)) EQUIVALENCE (TYPE(1),OUTPUT(15)) EQUIVALENCE (KGRP ,OUTPUT(29)) EQUIVALENCE (KMEM ,OUTPUT(31)) DATA COMMA/','/, COLON/':'/, LBRAK/'['/, RBRAK/']'/ DATA ASTER/'*'/, PERIOD/'.'/, LOCKED/'L'/, CONTIG/'C'/ DATA DEVICE/'S','Y','0',':'/, POUND/'#'/ DATA MONTH/'J','A','N','F','E','B','M','A','R','A','P','R', 1 'M','A','Y','J','U','N','J','U','L','A','U','G','S','E', 2 'P','O','C','T','N','O','V','D','E','C'/ DATA ALLGRP/.FALSE./, ALLMEM/.FALSE./ DATA ALLNAM/.TRUE./, ALLTYP/.TRUE./, ZERO/"60/ DATA BLANK/"40/, INPUT/' ','D','E','F','A','U','L','T',72*' '/ CALL MOVEB (DEVICE,1,4,OUTPUT,25) FIN TO DEFINE-FILE-HEADER-EQUIVALENCES ===== OFFSETS IN BYTES IN FILE HEADER RECORDS. ===== DEFINED FOR FORTRAN BYTE ARRAYS IMPLICIT BYTE(Z) DATA ZIDA/46/, ZMA/92/ DATA ZIDOF/1/,ZMPOF/2/,ZFNUM/3/,ZFSEQ/5/,ZFLEV/7/ DATA ZPROG/9/,ZPROJ/10/,ZFPRO/11/,ZUCHA/13/,ZSCHA/14/ DATA ZUFAT/15/,ZFNAM/1/,ZFTYP/7/,ZFVER/9/,ZRVNO/11/ DATA ZRVDT/13/,ZRVTI/20/,ZCRDT/26/,ZCRTI/31/,ZEXDT/37/ DATA ZESQN/1/,ZERVN/2/,ZEFNU/3/,ZEFSQ/5/,ZCTSZ/7/ DATA ZLBSZ/8/,ZUSE/9/,ZMAX/10/,ZRTRV/11/ FIN TO FORMAT-STATEMENTS 01 FORMAT('1ENTER DESCRIPTION OF FILES TO BE LISTED IN "PIP" ', 1'FORMAT'/' SEPARATE MULTIPLE DESCRIPTIONS BY COMMAS') 02 FORMAT(' SELECT ACTION TO BE TAKEN, WHERE'/ 1'01 - LIST INSTRUCTIONS AND EXIT'/ 2'02 - SORT ALL FILES ALPHABETICALLY'/ 3'03 - SORT FILES ALPHABETICALLY WITHIN FILE TYPE'/ 4'04 - SORT FILES BY CREATION DATE'/ 5'05 - SORT FILES BY LATEST REVISION OR ACCESS DATE'/ 6/' 6 - LIST ALL LOCKED FILES AND FILES WITH "0" BLOCKS'/ 7/' (PRECEDE WITH "7" TO PRE-SORT BY UIC.)'/) 03 FORMAT('0I/O ERROR',I4,' ON LUN',I2,' BLOCK ',O7) 04 FORMAT(' ',10A1,'.',3A1,';',O3,1X,I5,'.',2X,2A1,'-',3A1,'-', 1 2A1,2X,2A1,2X,4A1,2(1X:,'[',3A1,',',3A1,']')) 05 FORMAT('1',T5,'LISTING OF ',80A1/' ',T50,'PAGE',I3/' ',T5, 1 9A1) 06 FORMAT(' ') 07 FORMAT(I3) 08 FORMAT('0',T10,F6.0,' BLOCKS IN',I5,' FILES') 09 FORMAT(Q,80A1) 10 FORMAT(O3) 11 FORMAT(' ',80A1) 12 FORMAT(' RECORD SIZE OF INDEX FILE =',I6,'(10)',O7,'(8)' / 1 ' TOTAL RECORDS IN USE =',I6,'(10)') 13 FORMAT(' ',10A1,'.',3A1,';',O3,1X,I5,'.',2X,O5,',',O5, 1 2X,2A1,2X,4A1,2(1X:,'[',O3,',',O3,']')) 14 FORMAT('0',T5,'ALPHABETIC SORT'/) 15 FORMAT('0',T5,'ALPHABETIC BY FILE TYPE'/) 16 FORMAT('0',T5,'SORTED BY CREATION DATE'/) 17 FORMAT('0',T5,'SORTED BY LAST REVISION DATE'/) 18 FORMAT('0',T5,'LOCKED AND ZERO BLOCK FILES'/ 1' (VERSION NUMBERS ARE FROM FILE HEADERS AND MAY'/ 2' NOT AGREE WITH DIRECTORY. SOME FILES MAY NOT BE'/ 3' LOCATED IN ANY DIRECTORY.)'/) 19 FORMAT('0ERROR IN WRITING TO TEMPORARY SORT FILE') 20 FORMAT('0ERROR IN READING TEMPORARY SORT FILE') FIN TO DEFINE-SORT-FILE OPEN (UNIT=2,NAME='DSKLST.TMP;1',TYPE='SCRATCH', 1 ACCESS='DIRECT',RECORDSIZE=8,INITIALSIZE=10, 2 EXTENDSIZE=5,ASSOCIATEVARIABLE=IR2) DATA IR2/1/ FIN TO ENTER-FILES-TO-BE-LISTED WRITE (TI,101) READ (TI,109) LAST,(INPUT(I),I=1,LAST) I = 9 IF (LAST.NE.0) I = LAST + 1 DO (J=I,80) INPUT(J) = BLANK CALL ERRSET (29,1,0,1,0) CALL ERRSET (30,1,0,1,0) CALL ERRSET (64,1,0,1,0,1000) FIN TO GET-SORT-TYPE WRITE (TI,102) Y = 2 N = 1 CALL VTINP(TI,'ENTER SORT TYPE ',INPUT,N,3) SORT = INPUT(1) - "60 WHEN (SORT.EQ.7) Y = 1 N = 1 CALL VTIN (TI,INPUT,N,,,12) SORT = INPUT(1) - "60 FIN ELSE CALL VTOUT (TI,' ',,12) UNLESS (SORT.GE.1.AND.SORT.LT.7) GO TO 1 FIN TO LIST-INSTRUCTIONS CALL ASSIGN (2,'DSKLST.DOC') WRITE (TI,106) REPEAT UNTIL(DONE) READ (2,109,END=6) I,INPUT WRITE (TI,111)(INPUT(J),J=1,I) FIN WRITE (TI,106) STOP FIN TO LIST-LOCKED-FILES CALL HEDBLK (3,IDXHED,1,IREC,IERR,1) CALL DBLKS (1,IDXHED) CALL DBLK (1,MADR,IDXHED) CALL DBLK (1,MADR,IDXHED) LEND = 0 REPEAT UNTIL (ICOUNT.EQ.0) CALL DBLK (1,MADR,ICOUNT) LEND = LEND + ICOUNT FIN WRITE (TI,112) LEND CALL HEDBLK (3,IDXHED,1,FADR,IERR,1) DO (FILNUM=7,LEND) CALL HEDBLK (3,IDXHED,FILNUM,FADR,IERR) READ-FILE-HEADER ==== CHECK FOR FILE NUMBER IF ((FILHED(2).NE.0) .AND.(FILHED(1).EQ."27027)) INUSE = INUSE + 1 ==== CHECK TO SEE IF ANY BLOCKS ALLOCATED, OR FILE LOCKED IF (FILHED(11).EQ.0.OR.(BFILHED(13).AND."100)) ==== GET FILE NAME, TYPE, VERSION I = (ZIDA + ZFNAM + 1) / 2 CALL R50ASC (9,FILHED(I),NAME) I = (ZIDA + ZFTYP + 1) / 2 CALL R50ASC (3,FILHED(I),TYPE) I = (ZIDA + ZFVER + 1) / 2 IOUT (10) = FILHED(I) COUNT-AND-OUTPUT-TOTAL-BLOCKS ==== SAVE FILE NUMBER AND FILE SEQUENCE NUMBER IOUT(1) = FILNUM I = (ZFSEQ+1)/2 IOUT(2) = FILHED(I) ==== SHOW WHETHER LOCKED AND OR CONTIGUOUS OUTPUT-FILE-CHARACTERISTICS ==== GET UIC GROUP AND MEMBER I = ZPROG OUTPUT(30) = BFILHED(I) I = ZPROJ OUTPUT(29) = BFILHED(I) WRITE-TO-FILE CONTINUE FIN FIN FIN DONE = .TRUE. FIN TO GET-DEFAULT-UIC CALL GETTSK (IDXHED) I = BIDXHED(15) I = I.AND.MASK J = BIDXHED(16) J = J.AND.MASK ENCODE (3,110,MEM) I ENCODE (3,110,GRP) J DO (I=1,3) IF (MEM(I).EQ.BLANK) MEM(I) = ZERO IF (GRP(I).EQ.BLANK) GRP(I) = ZERO FIN FIN TO CHECK-FOR-DEVICE-REQUEST GET-NEXT-CHARACTER IF (INPUT(IX).EQ.COMMA) INCREMENT-INDEX UNLESS (DONE) IF (INPUT(IX+3).EQ.COLON) REASSIGN-DEVICE GET-NEXT-CHARACTER FIN FIN TO GET-NEXT-CHARACTER UNTIL (IX.GE.LAST.OR.INPUT(IX).NE.BLANK) INCREMENT-INDEX IF (IX.GE.LAST) DONE = .TRUE. FIN TO REASSIGN-DEVICE CALL CLOSE (3) OPEN = .FALSE. CALL MOVEB (INPUT,IX,IX+3,DEVICE,1) NUM = DEVICE(3) - ZERO CALL ASNLUN (3,DEVICE,NUM,IDS) CALL MOVEB (DEVICE,1,4,OUTPUT,25) IX = IX + 4 FIN TO CHECK-FOR-UIC-REQUEST GET-NEXT-CHARACTER UNLESS (DONE) IF (INPUT(IX).EQ.COMMA) INCREMENT-INDEX IF (INPUT(IX).EQ.LBRAK) ALLGRP = .FALSE. ALLMEM = .FALSE. IF (INPUT(IX).EQ.LBRAK) INCREMENT-INDEX WHEN (INPUT(IX).EQ.ASTER) ALLGRP = .TRUE. INCREMENT-INDEX FIN ELSE GRP(2) = ZERO GRP(3) = ZERO UNTIL (INPUT(IX).EQ.COMMA.OR.IX.GT.LAST) GRP(1) = GRP(2) GRP(2) = GRP(3) GRP(3) = INPUT(IX) INCREMENT-INDEX FIN FIN INCREMENT-INDEX WHEN (INPUT(IX).EQ.ASTER) ALLMEM = .TRUE. INCREMENT-INDEX FIN ELSE MEM(2) = ZERO MEM(3) = ZERO UNTIL (INPUT(IX).EQ.RBRAK) MEM(1) = MEM(2) MEM(2) = MEM(3) MEM(3) = INPUT(IX) INCREMENT-INDEX FIN FIN INCREMENT-INDEX FIN FIN FIN UNLESS (ALLGRP) CALL IRAD50 (3,GRP,IGRP) UNLESS (ALLMEM) CALL IRAD50 (3,MEM,IMEM) FIN TO CHECK-FOR-NAME-REQUEST GET-NEXT-CHARACTER UNLESS (DONE) IF (INPUT(IX).EQ.COMMA) INCREMENT-INDEX UNLESS (INPUT(I+3).EQ.COLON) SELECT (INPUT(IX)) (LBRAK) CONTINUE (ASTER) INCREMENT-INDEX ALLNAM = .TRUE. FIN (POUND) ALLNAM = .FALSE. NTYPE = 2 INCREMENT-INDEX STORE-NAME FIN (OTHERWISE) ALLNAM = .FALSE. NTYPE = 1 STORE-NAME FIN FIN FIN FIN FIN TO STORE-NAME DO (I=1,12) SAVNAM(I) = BLANK NAMEND = .FALSE. ALLNAM = .FALSE. J = 1 REPEAT UNTIL (NAMEND.OR.J.EQ.10.OR.IX.GT.LAST) SELECT (INPUT(IX)) (BLANK) NAMEND = .TRUE. (COMMA) NAMEND = .TRUE. (PERIOD) NAMEND = .TRUE. (OTHERWISE) SAVNAM(J) = INPUT(IX) CHAR = J J = J + 1 INCREMENT-INDEX FIN FIN FIN FIN TO CHECK-FOR-TYPE-REQUEST GET-NEXT-CHARACTER UNLESS (DONE) IF (INPUT(IX).EQ.PERIOD) INCREMENT-INDEX WHEN (INPUT(IX).EQ.ASTER) INCREMENT-INDEX ALLTYP = .TRUE. FIN ELSE CALL MOVEB (INPUT,IX,IX+2,SAVTYP,1) IX = IX + 3 ALLTYP = .FALSE. FIN FIN GET-NEXT-CHARACTER FIN FIN TO INCREMENT-INDEX IX = IX + 1 TO READ-MASTER-DIRECTORY-HEADER CALL RLB (3,MSTHED,IREC(1),IREC(2),IOSTAT,IDS) IF (STAT(1).LT.0) WRITE (TI,121) STAT(1),IREC(1),IREC(2), MBLK 21 FORMAT (' ERROR IN READING MASTER DIRECTORY'/ 1 'ERR =',I4,' ADR =',2O7,' MBLK = ',I3) FIN FIN TO READ-MASTER-DIRECTORY-FILE-RECORD CALL RLB (3,BMSTREC,MADR(1),MADR(2),IOSTAT,IDS) IF (STAT(1).LT.0) WRITE (TI,122) STAT(1),MADR 22 FORMAT (' ERROR IN READING MASTER DIRECTORY FILE RECORD'/ 1 ' ERROR =',I4,' ADR =',2O7) FIN CALL DSKADD (MADR,MADR,1) FIN TO CHECK-GROUP-NUMBER FOUND = .FALSE. IF (MSTREC(MX+3).EQ.IGRP) FOUND = .TRUE. FIN TO CHECK-MEMBER-NUMBER FOUND = .FALSE. IF (MSTREC(MX+4).EQ.IMEM) FOUND = .TRUE. FIN TO OUTPUT-UIC ERROR = .FALSE. ==== DECODING ERRORS WILL OCCUR ON ALPHA ENTRIES IN ==== THE MASTER DIRECTORY. KGRP = MSTREC(MX+3) KMEM = MSTREC(MX+4) GO TO 7 ERROR = .TRUE. FIN TO GET-DIRECTORY-FILE-NUMBER FILNUM = MSTREC(MX) TO READ-UIC-DIRECTORY-HEADER CALL RLB (3,BUICHED,DADR(1),DADR(2),IOSTAT,IDS) IF (STAT(1).LT.0) WRITE (TI,123) STAT(S),DADR, MBLK,MX 23 FORMAT (' ERROR IN READING A UIC DIRECTORY HEADER'/ 1 ' ERROR =',I4,' ADR = ',2O7,' MBLK = ',I3,' MX = ',I3) FIN CALL DSKADD (DADR,DADR,1) FIN TO READ-UIC-FILE-RECORD CALL RLB (3,BUICREC,JADR(1),JADR(2),IOSTAT,IDS) IF (STAT(1).LT.0) WRITE (TI,125) STAT(1),JADR, UBLK 25 FORMAT (' ERROR IN READING UIC FILE RECORD'/ 1 ' ERROR =',I4,' ADR = ',2O7,' UBLK = ',I3) FIN CALL DSKADD (JADR,JADR,1) FIN TO CHECK-NAME FOUND = .FALSE. WHEN (NTYPE.EQ.1) IF(NCOMPB(NAME,1,9,SAVNAM,1).EQ.0) FOUND = .TRUE. FIN ELSE LIM = 10 - CHAR I = 1 J = 1 REPEAT UNTIL (FOUND.OR.J.EQ.LIM) WHEN (NCOMPB(SAVNAM,1,CHAR,NAME,I).EQ.0) FOUND=.TRUE. ELSE I = I + 1 J = J + 1 FIN FIN FIN FIN TO CHECK-TYPE WHEN (ALLTYP) FOUND = .TRUE. ELSE WHEN(NCOMPB(TYPE,1,3,SAVTYP,1).EQ.0) FOUND = .TRUE. ELSE FOUND = .FALSE. FIN FIN TO MOVE-NAME CALL R50ASC (9,UICREC(UX+4),NAME(1)) ISEC = 1 FIN TO MOVE-TYPE CALL R50ASC (3,UICREC(UX+7),TYPE(1)) FIN TO WRITE-DATA-TO-SORT-FILE OUTPUT-VERSION-NUMBER FILNUM = UICREC(UX+1) CALL HEDBLK (3,IDXHED,FILNUM,FADR,IERR) READ-FILE-HEADER COUNT-AND-OUTPUT-TOTAL-BLOCKS WHEN (REV) OUTPUT-REVISION-DATE ELSE OUTPUT-CREATION-DATE OUTPUT-FILE-CHARACTERISTICS WRITE-TO-FILE FIN TO OUTPUT-VERSION-NUMBER IOUT(10) = UICREC(UX+8) FIN TO READ-FILE-HEADER CALL RLB (3,FILHED,FADR(1),FADR(2),IOSTAT,IDS) IF (STAT(1).LT.0) WRITE (TI,126) STAT(1),FADR, FILNUM 26 FORMAT (' ERROR IN READING A DATA FILE HEADER'/ 1 ' ERROR = ',I4,' ADR = ',2O7,' FILNUM = ',O7) FIN FIN TO COUNT-AND-OUTPUT-TOTAL-BLOCKS IOUT(11) = FILHED(11) TOT = TOT + FILHED(11) FIN TO OUTPUT-CREATION-DATE I = ZIDA + ZCRDT MOVE-DATE FIN TO OUTPUT-REVISION-DATE I = ZIDA + ZRVDT MOVE-DATE FIN TO MOVE-DATE CALL MOVEB (BFILHED,I+5,I+6,OUTPUT,1) CALL MOVEB (BFILHED,I,I+1,OUTPUT,4) DO (J=1,12) UNLESS (NCOMPB(BFILHED,I+2,I+4,MONTH,J*3-2)) OUTPUT(3) = J J = 12 FIN FIN FIN TO OUTPUT-FILE-CHARACTERISTICS I = ZUCHA WHEN (BFILHED(I).AND."100) OUTPUT(23) = LOCKED ELSE OUTPUT(23) = BLANK WHEN (BFILHED(I).AND."200) OUTPUT(24) = CONTIG ELSE OUTPUT(24) = BLANK FIN TO WRITE-TO-FILE WRITE (2'IR2,ERR=2) (OUTPUT(I),I=1,32) GO TO 3 WRITE (TI,119) STOP CONTINUE FIN TO SORT-OUTPUT-FILE IEND = IR2 - 1 CALL CLOSE (3) CONDITIONAL (SORT.EQ.3) CALL DSORT(2,IEND,16,5-Y,LOC2(Y),LENTH2(Y),KIND2(Y),WORK,4096, 1 OUTPUT) FIN (SORT.EQ.4.OR.SORT.EQ.5) CALL DSORT(2,IEND,16,4-Y,LOC3(Y),LENTH3(Y),KIND3(Y),WORK,4096, 1 OUTPUT) FIN (OTHERWISE) CALL DSORT(2,IEND,16,4-Y,LOC1(Y),LENTH1(Y),KIND1(Y),WORK,4096, 1 OUTPUT) FIN FIN FIN TO PRINT-AND-DELETE-OUTPUT-FILE CALL ASSIGN (3,'LP:') CALL DATE (RDATE) START-NEW-PAGE UNLESS (IEND.EQ.0) DO (NUMREC=1,IEND) READ (2'NUMREC,ERR=4) OUTPUT IF (Y.EQ.1) IF (NCOMPB(OUTPUT,29,32,SAVUIC,1)) START-NEW-PAGE CALL MOVEB (OUTPUT,29,32,SAVUIC,1) FIN FIN CONDITIONAL (SORT.EQ.3) IF (NCOMPB(OUTPUT,15,17,SAVNAM,10)) WRITE (3,106) LINE = LINE + 1 FIN FIN (SORT.EQ.4.OR.SORT.EQ.5) UNLESS (SAVDAT(1).EQ.OUTPUT(3)) WRITE (3,106) LINE = LINE + 1 FIN FIN FIN WHEN (NCOMPB(OUTPUT,6,17,SAVNAM,1)) MARK = BLANK CALL MOVEB (OUTPUT,6,17,SAVNAM,1) FIN ELSE MARK = ASTER SAVDAT(1) = OUTPUT(3) J = OUTPUT(3) CALL R50ASC (3,KGRP,GRP) CALL R50ASC (3,KMEM,MEM) IF (MEM(1).EQ."60) MEM(1) = 0 IF (MEM(2).EQ."60) MEM(2) = 0 FIN IF (GRP(1).EQ."60) GRP(1) = 0 IF (GRP(2).EQ."60) GRP(2) = 0 FIN WHEN (SORT.NE.6) WRITE (3,104)MARK,(OUTPUT(I),I=6,17),(IOUT(I),I=10,11), 1 (OUTPUT(I),I=4,5),(MONTH(I),I=J*3-2,J*3),(OUTPUT(I), 2 I=1,2),(OUTPUT(I),I=23,28),GRP,MEM FIN ELSE WRITE (3,113)MARK,(OUTPUT(I),I=6,17),(IOUT(I),I=10,11), 1 (IOUT(I),I=1,2),(OUTPUT(I),I=23,30) FIN LINE = LINE + 1 ITOTF = ITOTF + 1 IF (LINE.GE.50) START-NEW-PAGE FIN FIN WRITE (3,108) TOT,ITOTF WRITE (3,106) GO TO 8 WRITE (TI,120) STOP FIN TO START-NEW-PAGE LINE = 0 PAGE = PAGE + 1 WRITE (3,105) INPUT,PAGE,RDATE SELECT (SORT) (2) WRITE (3,114) (3) WRITE (3,115) (4) WRITE (3,116) (5) WRITE (3,117) (6) WRITE (3,118) FIN FIN END