C PROGRAM PACK.FT C ================ C SUBROUTINE PACK(A,B,IB) C C C C P. LEMKIN C NATIONAL INSTITUTES OF HEALTH C BETHESDA, MD 20014 C C APRIL 4, 1972 C REVISED DECEMBER 5, 1972 C C C C C C C C PURPOSE C ======= C "PACK" THE 64A1 FILENAME ARRAY FOUND IN THE IBUF ARRAY INTO C THE ORDERED PAIR OF WORDS (A,B) IN PAL8 "FILENAME" FORMAT. C IB IS USED AS THE STARTING POINT IN THE IBUF ARRAY TO START C ASSEMBLING THE FILENAME. THE ARRAY IDYLM IS FILLED WITH C ZEROS INITIALLY. IF A SINGLE DATE WITH MODIFIERS IS C SPECIFIED IN [ ], THEN IDYLM(1) CONTAINS THE PACKED C DATE AND IDYLM(3) CONTAINS THE MODIFIERS. C EG: [3/4/45>] MEANS ALL DATES AFTER 3/4/45 C [3/4/45<] MEANS ALL DATES BEFORE 3/4/45 C IF A RANGE OF DATES IS SPECIFIED BY SEPARATION WITH A "-" C THEN THE FIRST (LOWER DATE) IS PUT INTO IDYLM(1), THE C SECOND INTO IDYLM(2), AND THE MODIFIERS INTO IDYLM(3). C EG: [3/4/45-12/19/45] MEANS ALL DATES BETWEEN 3/4/45 C AND 12/19/45. C IF THE MODIFIER "C" IS USED, THE RETREIVAL WILL BE C ON THE "C"REATION DATE, OTHERWISE ON THE ACCESS DATE. C C C C ARGUMENTS C ========= C A IS THE FILE NAME. C B IS THE EXTENSION IF IT EXISTS (EXTRA CHARACTERS ARE 0). C IB IS THE INDEX OF WHERE THE 12A1 STARTS IN THE IBUF C ARRAY. C C C C C C C EAE DEFINITIONS C =============== S OPDEF LSR 7417 S OPDEF MQA 7501 S OPDEF MQL 7421 S OPDEF MUY 7405 C C C C C COMMON IPNT,STACK,RES,SAV,DIR,HEL,APP,ISTACK,COP,LPTDEV COMMON SAVEF,KDEV,ITIME,IBUF,MAX,T,IDYLM,IBKNMB,ISTBLK,ICREATION DIMENSION FFF(2),III(6),STACK(241,2),IBUF(256),ISTACK(241,6) DIMENSION ITIME(2),IDYLM(3) EQUIVALENCE (FFF(1),III(1)) C C C C C 0.0 INITIAL THE CONSTANTS. FFF(1)=0 FFF(2)=0 DO 10 I=1,3 10 IDYLM(I)=0 S TAD (5540 /"- " S DCA \ITHRU S TAD (0340 /"C " S DCA \IC S TAD (5740 /"/ " S DCA \ISLSH S TAD (3340 /"[ " S DCA \ILBRK S TAD (3540 /"] " S DCA \IRBRK S TAD (7640 /"> " S DCA \IGT S TAD (7440 /"< " S DCA \ILT S TAD (5640 /"." S DCA \IPER S TAD (4040 /SPACE S DCA \ISPACE IMO=0 IDAY=0 IYR=0 LEFT=0 C C C C C 1.0 LOOK AT ALL 12 WORDS IN DOING THE PACKING C INTO FFF(1) UNTIL SEE: C A) 6 CHARACTERS. C B) A "." C C) A SPACE JB1=IB+5 JBLIM=IB+11 DO 100 I=IB,JB1 LEFT=1-LEFT IF(IBUF(I)-ISPACE)103,200,103 103 IF(IBUF(I)-IPER)101,200,101 101 J=(I-1)/2 IF(LEFT)104,104,102 C C C C 1.1 PACK THE FILENAME LEFT BYTE. 102 III(J+1)=IBUF(I)-32 GOTO 100 C C C C 1.2 PACK THE FILENAME RIGHT BYTE. 104 III(J+1)=III(J+1)+(IBUF(I)/64) 100 CONTINUE C C C C 2.0 LOOK FOR A "." OR END OF IBUF STRING. 200 DO 298 I=LI,JBLIM IF(IPER-IBUF(I))201,300,201 201 IF(ILBRK-IBUF(I))298,400,298 C C C C 2.1 WASTE ANOTHER CHARACTER UNTIL THE "." 298 CONTINUE C C C C 2.2 NO EXTEN SION GIVEN. GO COPY RESULTS AND EXIT. 299 A=FFF(1) B=FFF(2) RETURN C C C C 3. PICK UP THE EXTENSION. C DROP SPACES. 300 I=I+1 IF(IBUF(I)-ISPACE)301,299,301 301 III(4)=IBUF(I)-32 I=I+1 IF(IBUF(I)-ISPACE)302,299,302 302 III(4)=III(4)+(IBUF(I)/64) GOTO 299 C C C C C **PAGE C PAGE # 2 C 4. PICK UP THE DATE WORDS IF THEY EXIST.. 400 L=0 401 I=I+1 K=IBUF(I) L=L+1 S TAD \K /GET THE 1ST DIGIT OF THE MONTH S CPAGE 2 S LSR /SHIFT TO RIGHT BYTE S 5 S AND (0017 /ONLY LOW 4 BITS S DCA \K C C C C 4.1 LOOK FOR A SLASH ON THE MONTH I=I+1 J=IBUF(I) IF(J-ISLSH)403,402,403 402 I=I-1 J=K K=0 GOTO 1403 C C C C C 4.2 NO CREAT A 2 DIGIT MONTH S\403, TAD \J S CPAGE 2 S LSR S 5 /GET INTO RIGHT BYTE. S AND (0017 S DCA \J S\1403, TAD \K S CPAGE 2 /MULTIPLY BY 10 DECIMAL S MQL MUY S 12 /10 DECIMAL S MQA S TAD \J /ADD ON THE LOW ORDER BITS S CPAGE 2 /MOVE IT UP TO BITS 0 TO 3. S MQL MUY S 400 /256 S MQA S DCA \IMO /SAVE THE MONTH C C C C C C 4.3 LOOK FOR A SLASH AFTER THE MONTH. I=I+1 J=IBUF(I) IF(J-ISLSH)500,404,500 C C C C 4.4 ERROR RETURN WITH NULL DATE INFOR... 500 WRITE(KDEV,501)(IBUF(I),I=1,64) 501 FORMAT('PACK DATE ERROR=',64A1) RETURN C C C C C 4.5 GET THE DAY NUMBER S\404, TAD \J S CPAGE 2 S LSR /MAKE RIGHT BYTE S 5 S AND (0017 S DCA \J C C C C C 4.6 GET THE 2ND DIGIT OF THE DAY I=I+1 K=IBUF(I) IF(K-ISLSH)405,406,405 C C C C C 4.7 IT WAS A SLASH, REVERSE THE DIGITS. 406 I=I-1 K=J J=0 GOTO 1405 C C C C C 4.8 PROCESS THE DAY S\405, TAD \K /GET THE LOW BYTE S CPAGE 2 S LSR S 5 /MOVE TO RIGHT BYTE. S AND (0017 S DCA \K S\1405, TAD \J /MULTIPLY BY 10 DECINAL S CPAGE 2 S MQL MUY S 12 S MQA S TAD \K /GET THE LOW BYTE S CPAGE 2 S MQL MUY /MULTIPLY BY 8 DECIMAL S 10 S MQA S DCA \IDAY /SAVE THE DAY C C C C C 4.9 CHECK FOR THE LAST SLASH IF(J-ISLSH)500,407,500 C C C C C 4.10 GET THE YEAR DIGIT FOR "70". 407 I=I+2 J=IBUF(I) S TAD \J S CPAGE 2 S LSR /RIGHT BYTE S 5 S AND (0007 S TAD \IDAY S TAD \IMO S DCA \IYR C C C C C 4.11 TEST IF MORE THAN 2 DATES, ILLEGAL. IF(L-2)413,413,500 C C C C C 4.12 GO PACK IT. 413 IDYLM(L)=IYR C C C C 4.13 TEST FOR ANOTHER DATE OR MODIFIERS. 412 I=I+1 J=IBUF(I) C C C C C 4.14 IS IT THE RIGHT BRACKET "]"? IF SO EXIT. IF(J-IRBRK)408,299,408 C C C C 4.15 IS IT THE "-" THROUGH DATE SYMBOL? IF SO C GO BACK FOR ANOTHER DATE. 408 IF(J-ITHRU)409,401,409 C C C C C 14.16 IS IT THE ">" ? C IF SO PACK IT AN GO LOOK FOR A ] 409 IF(J-IGT)410,480,410 C C C C 14.7 IS IT THE "<"? IF SO PACK IT AND LOOK FOR A ] 410 IF(J-ILT)411,480,410 C C C C C 14.17 IS IT THE "C"? IF SO PACK MODIFIER AND LOOK FOR "]". 411 IF(J-IC)500,480,500 C C C C C 4.18 PACK THE MODIFIER AND LOOK FOR A "]" 480 IDYLM(3)=J GOTO 412 C C C C C END