From:	CRDGW2::CRDGW2::MRGATE::"SMTP::CRVAX.SRI.COM::RELAY-INFO-VAX"  4-AUG-1989 19:40
To:	MRGATE::"ARISIA::EVERHART"
Subj:	RE: Reading IBM tapes on VAX - part 4 of 5

Message-Id:  <8908042328.AA04313@crdgw1.ge.com>
Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Fri,  4 AUG 89 07:18:55 PDT
Received: from CUNYVM.CUNY.EDU by KL.SRI.COM with TCP; Fri, 4 Aug 89 07:09:06 PDT
Received: from NIHKLMB.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.2.1MX) with BSMTP id 8831; Fri, 04 Aug 89 10:03:36 EDT
Date: Fri, 4 Aug 89 09:56 EDT
From: Gerson H Cohen <GHC%NIHKLMB.BITNET@CUNYVM.CUNY.EDU>
Subject: RE: Reading IBM tapes on VAX - part 4 of 5
To: greg@HMCVAX.BITNET, INFO-VAX@KL.SRI.COM
X-Vms-To: IN%"greg@hmcvax",INFO-VAX,GHC

-+-+-+-+-+-+-+-+ START OF PART 4 -+-+-+-+-+-+-+-+
X      IF (IREAD(1:4) .NE. 'HDR1') GO TO 100
X      CALL STR$TRIM(IREAD(5:21),IREAD(5:21),IL)
X      CALL STR$COPY_DX(%DESCR(IFN),IREAD(5:4+IL))
X      DO 30 I = IL+1,17
X   30 IFN(J) = 0
X   40 CALL RD370(%REF(IREAD))
X      IF (IREAD(1:4) .NE. 'HDR2') GO TO 100
X      READ (IREAD(6:10),'(I5)',ERR=100) IBLKSZ
X      READ (IREAD(11:15),'(I5)',ERR=42) ILRECL
X      GO TO 45
X42    IF (IREAD(5:5).EQ.'V') THEN
X        ILRECL = '7FFF'X
X      ELSE
X        GO TO 100
X      END IF
X45    FV = ICHAR(IREAD(5:5))`009! RECORD WHETHER FIXED OR VARIABLE BLOCKS.
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOSPF),,,,%VAL(1),,,,,)`009! SKIP TRAI
VLING EOF
X      IBC = 0
X      RETURN
XC
X   60 CALL RD370(%REF(IREAD))
X      IF (IREAD(1:4) .NE. 'EOF1') GO TO 100
X      READ (IREAD(55:60),'(I6)',ERR=100) IBLK
X      CALL RD370(%REF(IREAD))
X      IF (IREAD(1:4) .NE. 'EOF2') GO TO 100
X      IF (MODE .EQ. 3 .AND. IBLK .NE. IBCH) GO TO 90
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOSPF),,,,%VAL(1),,,,,)`009! SKIP TRAI
VLING EOF
X      RETURN
XC
X   90 WRITE (LUNTT,4) IBC,IBLK
X      RETURN
XC
X  100 IBLKSZ = 1
X      WRITE (LUNTT,2)
X      WRITE (LUNTT,'(A)') IREAD
X      WRITE (LUNTT,'(20Z3.2)') (ICHAR(IREAD(I:I)),I=1,80)
X      RETURN
X      END
$ CALL UNPACK RDLBL.TAP;8 338482617
$ create/nolog 'f'
X      SUBROUTINE RDVBS(LRECRD)
XCHANGES MADE 08-JAN-1980 ***
XC
XC      SUBROUTINE TO DO THE ACTUAL READ FROM 'TAPE'.
XC
X      IMPLICIT INTEGER*2 (I-N)
X      LOGICAL*1 LRECRD(1),INPUT(8000),OK
X      COMMON /GHCITP/ IRC,IBC,LUNMT,LUNTT,ILRECL,IBLKSZ,IOSTAT(5),
X     1 IFN(17),IVOL(6),TRAN,LAB,IEOF
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,IVOL,MORE,BYTE(2)
X      EQUIVALENCE (IWORD,BYTE(1))
X      DATA IORLB/'21'X/,INORM/1/,IENDF/'870'X/
X    1 FORMAT (' ERROR IN READ ***'/'0FCS CODE ='I5,','I6,
X     1 ' BYTES TRANSFERRED'/'$SHALL WE CONTINUE READING? (T/F)  ')
X    2 FORMAT (L1)
X      IEOF = .FALSE.
X      ILRECL = 0
X   10 IF (IRC .LT. IBLKSZ) GO TO 40
X      IRC = 4
XC      AND NOW TO READ A RECORD
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IORLB),IOSTAT,,,INPUT,
X     1 %VAL(IOSTAT(5)),,,,)
X      IF (IOSTAT(1) .EQ. INORM) GO TO 30
XC      CHECK FOR EOF
X      IF (IOSTAT(1) .EQ. IENDF) GO TO 20
X      WRITE (LUNTT,1) IOSTAT(1),IOSTAT(2)
X      READ (LUNTT,2) OK
X      IF (OK) GO TO 30
X   20 IEOF = .TRUE.
X      RETURN
XC  UPDATE BLOCK COUNT
X   30 IBC = IBC + 1
XC  GET BLOCKSIZE FROM "BDW"
X      BYTE(1) = INPUT(2)
X      BYTE(2) = INPUT(1)
X      IBLKSZ = IWORD
XC  GET LENGTH OF RECORD SEGMENT FROM "SDW"
X   40 BYTE(1) = INPUT(IRC+2)
X      BYTE(2) = INPUT(IRC+1)
X      ILREC = IWORD
X      J = ILREC - 4
X      DO 50 I=1,J
X   50 LRECRD(ILRECL+I) = INPUT(IRC+I+4)
X      ILRECL = ILRECL + ILREC - 4
XC  MORE = .TRUE. IF SPANNED RECORD IS STILL INCOMPLETE
X      MORE = (INPUT(IRC+3) .AND. 1) .EQ. 1
XC  UPDATE BYTE COUNT
X      IRC = IRC + ILREC
X      IF (MORE) GO TO 10
X      RETURN
X      END
$ CALL UNPACK RDVBS.TAP;8 843197400
$ create/nolog 'f'
X$ SET NOVERIFY
X$ SET NOON
X$ ON CONTROL_Y THEN GOTO DISMOUNT
X$ INQUIRE M "Is tape already mounted with name TAPE (T/F)
X$ IF M THEN GOTO MOUNTED
X$ ALLOCATE MT: TAPE
X$ TYPE SYS$INPUT
X`009Place tape to be used on drive,
X`009when done, hit RETURN
X$ INQUIRE DONE DONE
X$ MOUNT/FOREIGN TAPE TAPE TAPE
X$ MOUNTED:
X$ RUN X$:SPOUT
X$ DISMOUNT:
X$ INQUIRE DISM "Is tape to be dismounted (T/F)
X$ IF .NOT.DISM THEN EXIT
X$ DISMOUNT TAPE
X$ DEALLOCATE TAPE
X$ DEASSIGN TAPE
X$ EXIT
$ CALL UNPACK SPOUT.COM;5 225315706
$ create/nolog 'f'
XC      PROGRAM SPOUT
XCHANGES MADE 30-Jul-1981 ***
XC
XC      THIS IS A PROGRAM TO WRITE "SPOUT" TAPES TO PRINT,
XC      PUNCH OR MICROFICHE AT THE IBM CENTRAL FACILITY.
XC      THE PROGRAM CAN ALSO WRITE STANDARD "FB" FILES.
XC
X      IMPLICIT INTEGER*2 (I-N,O)
X`009EXTERNAL GET_RAT_SIZ
X      COMMON /GHCITP/ IRC,IBC,LUNMT,LUNTT,ILRECL,IBLKSZ,IOSTAT(5),
X     1 IFN(17),IVOL(6),TRAN,LAB,IEOF
X      COMMON /GHCOTP/ ORC,OBC,OLRECL,OBLKSZ,OSTAT(4),OFN(17),
X     1 VNAME(6),OTRAN,OLAB,CC,ODEN,OEOF
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,OFN,OTRAN,OLAB,CC,ODEN,OEOF,VNAME,IVOL
X`009CHARACTER BUF1*300,BUF2*300,INIT*3,LAST*16,TYPE(3)*8,
X`0091 CTLNM*50,CCAR,CRNT*50
X      BYTE INOTAP,MORE,RATT,CA,CAR
X      INTEGER RSIZ*2,COUNT*4
X`009COMMON /RATSIZ/ RSIZ,RATT
X      DATA TYPE/'   PRINT','   PUNCH','MICRO105'/,CCAR/"61/
XC
X    1 FORMAT (' THIS IS THE SPOUT PROGRAM TO SEND 11/70 FILES TO THE'/
X     1 ' IBM CENTRAL FACILITY FOR PRINT, PUNCH OR MICROFICHE,'/
X     2 ' OR TO WRITE FB TAPES IN ASCII OR EBCDIC'//
X     3 '$TYPE: 1=PRINT/2=PUNCH/3=MICRO/4=FB (1/2/3/4) ')
X    2 FORMAT (I5)
X    3 FORMAT ('0'A,' TAPES REQUIRE A FIXED FORMAT.'/
X     1 ' A) ASCII TO EBCDIC TRANSLATION'/
X     2 ' B) OUTPUT FILE #1'/
X     3 ' C) LABELED TAPE'/
X     4 ' D) DSNAME='A,'.IIINNNNN'/
X     5 ' E) RECFM=FBA (EXCEPTING PUNCH FILES)'/
X     6 ' F) 1600BPI TAPE'/
X     7 ' G) LRECL<=',I3/)
X    4 FORMAT ('0WARNING, OLRECL TOO SMALL. MAX RECORD FOR THIS FILE IS'
X     1 I5)
X    5 FORMAT ('0THE NAMES OF THE FILES TO BE COPIED MAY BE ENTERED FROM'
X     1 /'$1=TERMINAL/2=A FILE PREVIOUSLY CONSTRUCTED (1/2) ')
X    6 FORMAT ('$WHAT IS THE NAME OF THE CONTROL FILE? ')
X    8 FORMAT (' TYPE A FILE NAME FOR EACH PROMPT. TYPE `094Z IN ANSWER'/
X     1 ' TO THE PROMPT AFTER ALL FILE NAMES HAVE BEEN ENTERED.'/)
X    9 FORMAT ('$NAME: ')
X   10 FORMAT (Q,A)
X   11 FORMAT (A)
X   12 FORMAT (' JOB DONE. ALL FILES TRANSFERED.')
X   13 FORMAT ('$MAX # LINES PER PAGE (-1 => NO LIMIT): `09160`093 ')
X   14 FORMAT (' &%&L'I3,124X)
X   15 FORMAT (1X,A)
X   16 FORMAT (' &%&I ',A,6X,'QAD1',17X,A,'218',77X)
X   17 FORMAT (' &%&F USE STANDARD PAPER',108X)
X   18 FORMAT (' &%&P USE STANDARD CARDS',108X)
X   19 FORMAT (' &%&MP360',123X)
X   20 FORMAT (' &%&D',I1,126X)
X   21 FORMAT ('$YOUR REGISTERED INITIALS = ')
X   22 FORMAT ('$YOUR LAST NAME = ')
X   23 FORMAT ('$#(<10) OF DUPLICATES `0910`093 ')
X   24 FORMAT (' ERROR IN ACCESSING FILE: 'A)
X   25 FORMAT (I10,' RECORDS TRANSFERED.')
X   26 FORMAT ('$# COPIES TO BE GENERATED (<10): `0911`093 ')
X   27 FORMAT (' &%&'I1,127X)
XC
X      COUNT = 0
X      LUNTT = 1
X`009OPEN (UNIT=LUNTT,NAME='TT',STATUS='UNKNOWN')
X      WRITE (LUNTT,1)
X      READ (LUNTT,2) MODE
X      IF (MODE .LT. 1 .OR. MODE .GT. 4) STOP 'MODE=?'
X      L = 133
X      IF (MODE .EQ. 2) L = 80
X      IF (MODE .LT. 4) WRITE (LUNTT,3) TYPE(MODE),TYPE(MODE),L
X      IF (.NOT.INOTAP(0)) STOP 'CANT INIT TAPE'
XC
X      IF (MODE .EQ. 4) GO TO 70
X      WRITE (LUNTT,21)
X      READ (LUNTT,11) INIT
X      CALL STR$UPCASE(INIT,INIT)
X      WRITE (LUNTT,22)
X      READ (LUNTT,11) LAST
X      CALL STR$UPCASE(LAST,LAST)
X      WRITE (BUF1,16) INIT,LAST
X      CALL WRT370(%REF(BUF1))
X`009if (oeof) stop '** Fatal error on tape'
X      IF (MODE .NE. 1) GO TO 50
X      ENCODE (132,17,BUF1)
X      CALL WRT370(%REF(BUF1))
X`009if (oeof) stop '** Fatal error on tape'
X      WRITE (LUNTT,13)
X      READ (LUNTT,2) LPP`009`009!LINES PER PAGE
X      IF (LPP .EQ. -1) GO TO 45`009!-1 MEANS NO LIMIT
X      IF (LPP .EQ. 0) LPP = 60`009!DEFAULT TO 60.
X      ENCODE (132,14,BUF2) LPP`009!ENCODE IT INTO BUF2
X      IF (BUF2(6:6) .EQ. ' ') BUF2(6:6) = '0' !REPLACE BLANK BY ZERO
X      IF (BUF2(7:7) .EQ. ' ') BUF2(7:7) = '0' !REPLACE BLANK BY ZERO
X      CALL WRT370(%REF(BUF2))`009`009!PUT IT OUT
X`009if (oeof) stop '** Fatal error on tape'
X   45 WRITE (LUNTT,26)`009!HOW MANY COPIES
X      READ (LUNTT,2) NC`009!# COPIES
X      IF (NC .EQ. 0) GO TO 70`009!DEFAULT TO ONE
X      ENCODE (132,27,BUF1) NC`009!ENCODE IT
X      CALL WRT370(%REF(BUF1))`009!PUT IT OUT
X`009if (oeof) stop '** Fatal error on tape'
X      GO TO 70
X   50 IF (MODE .NE. 2) GO TO 60
X      ENCODE (132,18,BUF1)
X      CALL WRT370(%REF(BUF1))
X`009if (oeof) stop '** Fatal error on tape'
X      GO TO 70
X   60 IF (MODE .NE. 3) STOP 'MODE=?'
X      ENCODE (132,19,BUF1)
X      CALL WRT370(%REF(BUF1))
X`009if (oeof) stop '** Fatal error on tape'
X      WRITE (LUNTT,23)
X      READ (LUNTT,2) ID
X      IF (ID .EQ. 0) GO TO 70
X      ENCODE (132,20,BUF1) ID
X      CALL WRT370(%REF(BUF1))
X`009if (oeof) stop '** Fatal error on tape'
XC
X   70 LUNFL = 4
X      WRITE (LUNTT,5)
X      READ (LUNTT,2) IN
X      CAR = MOD(MODE,2) .EQ. 0
X      CA = CAR
X   75 LUNCTL = LUNTT
X      IF (IN .EQ. 1) GO TO 80
X      LUNCTL = 3
X      WRITE (LUNTT,6)
X      READ (LUNTT,11) CTLNM
X`009OPEN (UNIT=LUNCTL,NAME=CTLNM,TYPE='OLD',READONLY,ERR=76)
X      GO TO 90
X   76 IF (IN .EQ. 1) GO TO 80
X      WRITE (LUNTT,24) CTLNM
X      CLOSE (UNIT=LUNCTL)
X      GO TO 75
X   80 WRITE (LUNTT,8)
X   90 IF (IN .EQ. 1) WRITE (LUNTT,9)
X      READ (LUNCTL,11,ERR=76,END=150) CRNT
X      IF (IN .EQ. 2) WRITE (LUNTT,15) CRNT
X      OPEN (UNIT=LUNFL,NAME=CRNT,TYPE='OLD',READONLY,ERR=115,
X`0091 USEROPEN=GET_RAT_SIZ)
X      IF (RSIZ .GT. OLRECL) WRITE (LUNTT,4) RSIZ
X      MORE = .FALSE.
X`009IF (.NOT.CAR) THEN
X      CA = RATT .EQ. "1
X`009BUF2 = CCAR
X      CALL WRT370(%REF(BUF2))
X`009if (oeof) then
X`009`009type *,'** Fatal error on tape **'
X`009`009go to 150
X`009end if
X`009END IF
X100`009IF (.NOT.MORE) READ (LUNFL,10,ERR=115,END=120) LRECL,BUF1
X      CALL SPLREC(BUF1,BUF2,CA,LRECL,OLRECL,MORE)
X      CALL WRT370(%REF(BUF2))
X      COUNT = COUNT + 1
X      GO TO 100
X  115 WRITE (LUNTT,24) CRNT
X  120 CLOSE (UNIT=LUNFL)
X      GO TO 90
X  150 WRITE (LUNTT,12)
X      CALL OUTTRM
X      WRITE (LUNTT,25) COUNT
X      IF (IN .EQ. 2) CLOSE (UNIT=LUNCTL)
X      CALL EXIT
X      END
X      SUBROUTINE SPLREC(BUF1,BUF2,CAR,LRECL,OLRECL,MORE)
XCHANGES MADE 26-MAR-1981 ***
XC
XC      SUBROUTINE TO EXTRACT LOGICAL RECORDS FOR SPOUT PROGRAM
XC      FROM "FILES 11" STYLE RECORDS.
XC
X`009CHARACTER*(*) BUF1,BUF2
X`009CHARACTER B,CR,LF,FF,TAB,NULL,NP,BL
X      BYTE CAR,MORE
X      INTEGER*2 OLRECL,LRECL
X      DATA BL/"40/,CR/"15/,LF/"12/,FF/"14/,TAB/"11/,NP/"61/,NULL/0/
XC
X`009BUF2 = BL
X      K = 2
X      IF (CAR) K = 1
X      IF (MORE) GO TO 40
XC TRIM OFF TRAILING BLANKS, TABS, NULLS, AND CR
X      J = LRECL + 1
X      DO 30 I = 1,LRECL
X      J = J - 1
X      B = BUF1(J:J)
X      IF (B .EQ. BL .OR. B .EQ. TAB .OR. B .EQ. NULL .OR. B .EQ. CR)
X     1 GO TO 30
X      LREC1 = J
X      GO TO 40
X   30 CONTINUE
X      GO TO 170
XC
X   40 DO 100 I = 1,LREC1
X      IF (K .GT. OLRECL) GO TO 100
X      B = BUF1(I:I)
X      IF (B .EQ. CR) GO TO 100
X      IF (B .EQ. LF) GO TO 50
X      IF (B .EQ. FF) GO TO 60
X      IF (B .EQ. TAB) GO TO 70
X      IF (B .EQ. NULL) GO TO 100
X      BUF2(K:K) = B
X      K = K + 1
X      GO TO 100
XC
X   50 LPOSIT = I + 1
X      GO TO 150
XC
X   60 IF (I .GT. 1) GO TO 65
X      BUF2(1:1) = NP
X      IF (CAR) GO TO 100
X      LPOSIT = I + 1
X      GO TO 150
X   65 LPOSIT = I
X      GO TO 150
XC
X   70 IF (CAR) K = ((K-1)/8+1)*8+1
X      IF (.NOT.CAR) K = ((K-2)/8+1)*8+2
XC
X  100 CONTINUE
X      GO TO 170
XC
X  150 LREC1 = LREC1 - LPOSIT + 1
X      MORE = LREC1.GT.0
X      IF (MORE) BUF1 = BUF1(LPOSIT:)
X      RETURN
XC
X  170 MORE = .FALSE.
X      RETURN
X      END
$ CALL UNPACK SPOUT.FOR;22 712956542
$ create/nolog 'f'
X      SUBROUTINE TAPTRM
XCHANGES MADE 21-JAN-1980 ***
XC
XC      SUBROUTINE TO TERMINATE ACTIVITY ON 'TAPE'.
XC      CALLS RDLBL TO CHECK EOF LABELS AND REWINDS TAPE.
XC
X      IMPLICIT INTEGER*2 (I-N)
X      COMMON /GHCITP/ IRC,IBC,LUNMT,LUNTT,ILRECL,IBLKSZ,IOSTAT(5),
X     1 IFN(17),IVOL(6),TRAN,LAB,IEOF
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,IVOL
X      DATA IORWD/'24'X/
X      IF (LAB) CALL RDLBL(3)
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IORWD),,,,,,,,,)
X      CALL SYS$DASSGN(%VAL(LUNMT))
X      RETURN
X      END
$ CALL UNPACK TAPTRM.TAP;6 1197098148
$ create/nolog 'f'
X      SUBROUTINE WRT370(LRECRD)
XCHANGES MADE 30-Jul-1981 ***
XC
XC      SUBROUTINE TO DO THE ACTUAL WRITE ON 'TAPE'.
XC
X      IMPLICIT INTEGER*2 (I-N,O)
X      COMMON /GHCITP/ IRC,IBC,LUNMT,LUNTT,ILRECL,IBLKSZ,IOSTAT(5),
X     1 IFN(17),IVOL(6),TRAN,LAB,IEOF
X      COMMON /GHCOTP/ ORC,OBC,OLRECL,OBLKSZ,OSTAT(4),OFN(17),
X     1 VNAME(6),OTRAN,OLAB,CC,ODEN,OEOF
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,OFN,OTRAN,OLAB,CC,ODEN,OEOF,VNAME,IVOL
X      LOGICAL*1 LRECRD(1),OUTPUT(8000)
X      DATA IOWLB/'20'X/,INORM/1/
X    1 FORMAT (' ERROR IN WRITE ***'/'0CODE ='Z6,','I6,
X     1 ' CHARACTERS WRITTEN'/'$SHALL WE CONTINUE? (T/F)  ')
X    2 FORMAT (L1)
X      IF (OEOF) GO TO 35
X      IF (OTRAN) GO TO 10
X      DO 5 J=1,OLRECL
X    5 OUTPUT(ORC+J) = LRECRD(J)
X      GO TO 30
X   10 CALL ASTEBC(OLRECL,LRECRD,OUTPUT(ORC+1))
X   30 ORC = ORC + OLRECL
X      IF (ORC .LT. OBLKSZ) RETURN
XC      AND NOW TO WRITE A RECORD
X   35 CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOWLB),OSTAT,,,OUTPUT,
X     1 %VAL(ORC),,,,)
X      OEOF = .FALSE.
X      IF (OSTAT(1) .EQ. INORM) GO TO 40
XC      DARN !
X      WRITE (LUNTT,1) OSTAT(1),OSTAT(2)
X`009READ (LUNTT,2) OK
X      IF (.NOT.OK) OEOF = .TRUE.
X   40 OBC = OBC + 1
X      ORC = 0
X      RETURN
X      END
$ CALL UNPACK WRT370.TAP;6 1477078740
$ create/nolog 'f'
X      SUBROUTINE WRTLBL(MODE,ISEQ)
XCHANGES MADE 21-JAN-1980 ***
XC
XC      SUBROUTINE TO WRITE STANDARD IBM TAPE LABELS.
XC
X      IMPLICIT INTEGER*2 (I-N,O)
X      COMMON /GHCITP/ IRC,IBC,LUNMT,LUNTT,ILRECL,IBLKSZ,IOSTAT(5),
X     1 IFN(17),IVOL(6),TRAN,LAB,IEOF
X      COMMON /GHCOTP/ ORC,OBC,OLRECL,OBLKSZ,OSTAT(4),OFN(17),
X     1 VNAME(6),OTRAN,OLAB,CC,ODEN,OEOF
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,OFN,OTRAN,OLAB,CC,ODEN,OEOF,VNAME,IVOL
X      LOGICAL*1 OWRT(80),BL,ZER,NULL,HDT(9),V,A,R,PNAM(15)
X      INTEGER*2 IMLS(12),LPNAM
X      REAL RMNTHS(12)
X      EQUIVALENCE (RMON,HDT(3))
X      DATA IMLS/31,28,31,30,31,30,31,31,30,31,30,31/,
X     1 RMNTHS/'-JAN','-FEB','-MAR','-APR','-MAY','-JUN','-JUL',
X     2        '-AUG','-SEP','-OCT','-NOV','-DEC'/
X      DATA HDR1/'HDR1'/,HDR2/'HDR2'/,EOF1/'EOF1'/,EOF2/'EOF2'/
X      DATA BL/"40/,IOEOF/'28'X/,ZER/"60/,NULL/0/,V/"126/,A/"101/,R/"122/
X    1 FORMAT ('VOL1',6A1,'0',30X,'NIH-2/219 ',29X)
X    2 FORMAT (A4,17A1,6A1,'0001'I4,7X,5A1,' 000000',I6,'LMB:MOL_STRUC',
X     1 7X)
X    3 FORMAT (A4,'F',2I5,I1,'0',8X'/'12X,'B',41X)
X    4 FORMAT (I2,5X,I2)
X    5 FORMAT (2X,I3)
XC
X      OEOF = .FALSE.
X      ILRECL = OLRECL
X      IBLKSZ = OBLKSZ
X      OLRECL = 80
X      OBLKSZ = 80
X      ORC = 0
X      CALL DATE(HDT)
X      DECODE (9,4,HDT) ID,IY
X      IF (IY-IY/4*4 .EQ. 0) IMLS(2) = 29`009!IF LEAP YEAR
+-+-+-+-+-+-+-+-  END  OF PART 4 +-+-+-+-+-+-+-+-

