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

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

-+-+-+-+-+-+-+-+ START OF PART 5 -+-+-+-+-+-+-+-+
XCOMPUTE DAY OF YEAR
X      DO 20 I = 1,12
X      IF (RMON .EQ. RMNTHS(I)) GO TO 25
X   20 ID = ID + IMLS(I)
X   25 ENCODE (5,5,HDT) ID
X      HDT(1) = HDT(8)
X      HDT(2) = HDT(9)
X      DO 30 I = 1,5
X      IF (HDT(I) .EQ. BL) HDT(I) = ZER
X   30 CONTINUE
X      CALL PROCNM(PNAM,LPNAM)
X      IF (MODE - 1) 35,40,55
X   35 ENCODE (80,1,OWRT) VNAME
X      CALL WRT370(OWRT)
XC
X   40 ISHOLD = MAX0(1,ISEQ)
X      ENCODE (80,2,OWRT) HDR1,OFN,VNAME,ISHOLD,(HDT(I),I=1,5),NULL
X      GO TO 60
X   45 ENCODE (80,3,OWRT) HDR2,IBLKSZ,ILRECL,ODEN
X      ILHOLD = ILRECL
X      GO TO 80
X   50 OLRECL = ILRECL
X      OBLKSZ = IBLKSZ
X      OBC = 0
X      RETURN
XC
X   55 ENCODE (80,2,OWRT) EOF1,OFN,VNAME,ISHOLD,(HDT(I),I=1,5),OBC
X   60 DO 65 I = 32,34
X      IF (OWRT(I) .EQ. BL) OWRT(I) = ZER
X   65 CONTINUE
X      DO 70 I = 55,60
X      IF (OWRT(I) .EQ. BL) OWRT(I) = ZER
X   70 CONTINUE
X      CALL WRT370(OWRT)`009`009! WRITE HDR1/EOF1
X      IF (MODE .LE. 1) GO TO 45
X      ENCODE (80,3,OWRT) EOF2,IBLKSZ,ILHOLD,ODEN
X   80 DO 81 I=18,25
X   81 OWRT(I) = BL
X      DO 82 I=1,LPNAM
X   82 OWRT(17+I) = PNAM(I)
X      DO 85 I = 6,15
X      IF (OWRT(I) .EQ. BL) OWRT(I) = ZER
X   85 CONTINUE
X      IF (CC .EQ. V) GO TO 90
X      IF (CC .EQ. A) OWRT(37) = A
X      GO TO 95
X   90 OWRT(5) = V
X      OWRT(39) = R
X   95 CALL WRT370(OWRT)`009`009! WRITE HDR2/EOF2
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOEOF),,,,,,,,,)`009! WRITE EOF
X      IF (MODE .LE. 1) GO TO 50
X      RETURN
XC
X      END
$ CALL UNPACK WRTLBL.TAP;12 1193097503
$ create/nolog 'f'
X      SUBROUTINE WRTVBS(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),IND,BYTE(2),OK
X      EQUIVALENCE (IWORD,BYTE(1))
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 25
X      ILRECL = OLRECL
X      IND = 0
X      IF (ORC .NE. 4) GO TO 15
X   10 DO 11 J=1,OBLKSZ
X   11 OUTPUT(J) = 0
X   15 MLRECL = OBLKSZ - ORC - 4
X      MLRECL = MIN0(MLRECL,ILRECL)
X      DO 17 J=1,MLRECL
X   17 OUTPUT(ORC+J+4) = LRECRD(ORECL-ILRECL+J)
X      IF (MLRECL .LT. ILRECL) IND = IND .OR. 1
X      O = ORC + MLRECL + 4
X      ILRECL = ILRECL - MLRECL
X      MLRECL = MLRECL + 4
X      IWORD = MLRECL
X      OUTPUT(ORC+1) = BYTE(2)
X      OUTPUT(ORC+2) = BYTE(1)
X      OUTPUT(ORC+3) = IND
X      OUTPUT(ORC+4) = 0
X      ORC = O
X      IF (ORC+5 .LT. OBLKSZ) RETURN
X   25 IWORD = ORC
X      OUTPUT(1) = BYTE(2)
X      OUTPUT(2) = BYTE(1)
X      OUTPUT(3) = 0
X      OUTPUT(4) = 0
XC      AND NOW TO WRITE A RECORD
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOWLB),OSTAT,,,OUTPUT,
X     1 %VAL(ORC),,,,)
X      OEOF = .FALSE.
X      OBC = OBC + 1`009!UPDATE RECORD COUNT
X      ORC = 4`009`009!RESET BYTE POINTER IN BUFFER
X      IND = 2`009`009!SET IN CASE THE RECORD IS SPANNED
X      IF (OSTAT(1) .EQ. INORM) GO TO 40`009! INORM MEANS ALL IS WELL
X      WRITE (LUNTT,1) OSTAT(1),OSTAT(2)`009! DARN
X      READ (LUNTT,2) OK
X      IF (.NOT.OK) OEOF = .TRUE.`009!FLAG IT FOR CALLING PROGRAM
X   40 IF (ILRECL .GT. 0) GO TO 10 `009!IF MORE TO RECORD, GO BACK
X      RETURN
X      END
$ CALL UNPACK WRTVBS.TAP;7 873419935
$ v=f$verify(v)
$ EXIT

