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

Message-Id:  <8908041455.AA26089@crdgw1.ge.com>
Received: From KL.SRI.COM by CRVAX.SRI.COM with TCP; Fri,  4 AUG 89 07:18:32 PDT
Received: from CUNYVM.CUNY.EDU by KL.SRI.COM with TCP; Fri, 4 Aug 89 07:08:54 PDT
Received: from NIHKLMB.BITNET by CUNYVM.CUNY.EDU (IBM VM SMTP R1.2.1MX) with BSMTP id 8827; Fri, 04 Aug 89 10:02:44 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 3 of 5
To: greg@HMCVAX.BITNET, INFO-VAX@KL.SRI.COM
X-Vms-To: IN%"greg@hmcvax",INFO-VAX,GHC

-+-+-+-+-+-+-+-+ START OF PART 3 -+-+-+-+-+-+-+-+
X      DATA VOL1/'VOL1'/,HDR1/'HDR1'/,HDR2/'HDR2'/,EOF1/'EOF1'/,
X     1 EOF2/'EOF2'/
X      DATA IOSPF/'25'X/,BL/"40/
X    1 FORMAT (5X2I5)
X    2 FORMAT (' NOT STANDARD LABEL ***')
X    3 FORMAT (54XI6)
X    4 FORMAT (' READ'I6,' RECORDS BUT EXPECTED'I6,' RECORDS ***')
X    5 FORMAT (X80A1/(X16O7))
XC
X      IBCH = IBC
X      ILRECL = 80
X      IBLKSZ = 80
X      IOSTAT(5) = 80
X      IRC = 80
X      IF (MODE .GT. 0) GO TO 20
X      CALL RD370(IREAD)
X      IF (TEST .NE. VOL1) GO TO 100
X      DO 15 I=1,6
X   15 IVOL(I) = IREAD(4+I)
X   20 IF (MODE .GT. 1) GO TO 60
X      CALL RD370(IREAD)
X      IF (TEST .NE. HDR1) GO TO 100
X      DO 25 I=1,17
X   25 IFN(I) = IREAD(4+I)
X      DO 30 I = 1,17
X      J = 18 - I
X      IF (IFN(J) .NE. BL) GO TO 40
X   30 IFN(J) = 0
X   40 CALL RD370(IREAD)
X      IF (TEST .NE. HDR2) GO TO 100
X      DECODE (80,1,IREAD) IBLKSZ
X`009ilrecl = 16382
X      FV = IREAD(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(IREAD)
X      IF (TEST .NE. EOF1) GO TO 100
X      DECODE (80,3,IREAD) IBLK
X      CALL RD370(IREAD)
X      IF (TEST .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,5) IREAD,IREAD
X      RETURN
X      END
$ CALL UNPACK MLTAPE.FOR;1 389547849
$ create/nolog 'f'
X`009.TITLE`009NUMCON
X`009.sbttl`009ibm/vax internal date type conversions
X`009.PSECT`009NUMCON
X
X;this set of routines converts data from the IBM internal format
X;to that of the VAX.
X
X;Each routine is FORTRAN callable as a subroutine and will convert
X;consecutive cells as determined from the call list.  If the number
X;of conversions is omitted the call defaults to one.
X
X;format`009CALL RTN(BUFFER,N)
X;where:
X;`009RTN is the conversion type
X;
X;`009IBM to VAX conversions
X;
X;`009`009I2V`009integer*2
X;`009`009I4V`009integer*4
X;`009`009R4V`009real*4
X;`009`009R8V`009real*8
X;`009`009L1V`009logical*1
X;`009`009L2V`009logical*2
X;`009`009L4V`009logical*4
X;`009`009chi`009character
X;
X;`009VAX to IBM conversions
X;
X;`009`009i2i`009integer*2
X;`009`009i4i`009integer*4
X;`009`009r4i`009real*4
X;`009`009r8i`009real*8
X;`009`009l1i`009logical*1
X;`009`009l2i`009logical*2
X;`009`009l4i`009logical*4
X;`009`009chi`009character
X
X;`009BUFFER is the address of the first cell to convert
X
X;`009N is the number of conversions to perform
X`009.sbttl`009I2V integer*2 conversion
X
Xi2i::`009.entry`009i2v,`094m<r2,r3,r4>
X`009bsbb`009get_parms`009;get the input parameters
X10$:`009movb`009(r4)+,-(sp)`009;build VAX integer
X`009movb`009(r4)+,-(sp)
X`009movw`009(sp)+,-2(r4)`009;and return it
X`009sobgtr`009r3,10$`009`009;gtr..keep going
X`009ret
X
X
X`009.sbttl`009I4V integer*4
X
Xi4i::`009.entry`009I4V,`094M<R2,R3,R4>
X`009bsbb`009get_parms`009;get the input parameters
X10$:`009.REPT`0094`009`009;BUILD THE INTEGER*4
X`009MOVB`009(R4)+,-(SP)
X`009.ENDR
X`009MOVL`009(SP)+,-4(R4)`009;AND RETURN IT
X`009SOBGTR`009R3,10$`009`009;GTR..MORE TO CONVERT
X`009ret
X
X
X
X
X
X`009.sbttl`009get_parms loads registers with call parameters
X
Xget_parms:
X`009movl`009#1,r3`009`009;assume one cell conversion
X`009movl`0094(ap),r4`009;get the cell address
X`009cmpl`009(ap),#2`009`009;N default to 1?
X`009bLSS`00920$`009`009;LSSl..default
X`009movl`009@8(ap),r3`009;get number of conversions N
X`009bgtr`00920$`009`009;gtr..all is ok
X10$:`009tstl`009(sp)+`009`009;drop return address
X`009ret`009`009`009;and exit to original caller
X20$:`009rsb`009`009`009;finish the conversion
X`009.sbttl`009R4V real*4 conversion
X
X`009.entrY`009r4v,`094m<r2,r3,r4>
X`009bsbb`009get_parms
X`009movl`009#3,r2`009`009;load loop counter
X`009brb`009vaxreal
X
X
X`009.sbttl`009R8V real*8 convsersion
X
X`009.ENTRY`009R8V,`094M<R2,R3,R4>
X`009bsbb`009get_parms`009;get the input parameters
X`009movl`009#7,r2`009`009;load loop count for 64 bit number
X
Xvaxreal:
X
X`009CLRQ`009-(SP)`009`009;MAKE ROOM ON THE STACK
X`009SUBL3`009R2,#7,R1`009;POSITION THE BYTES
X`009movl`009r2,r0`009`009;remember number of bytes
X10$:`009movb`009(r4)`091r0`093,(sp)`091R1`093;get a byte
X`009INCL`009R1`009`009;POINT TO NEXT BYTE
X`009sobgtr`009r0,10$`009`009;gtr..more to get
X`009extzv`009#0,#7,(r4),r0`009;get hexadecimal exponent
X`009ashl`009#2,r0,R0`009;convert to binary
X`009subl`009#128,r0`009`009;and excess 128
X20$:`009bbs`009#55,(sp),30$`009;bs..normalized for VAX
X`009ashq`009#1,(sp),(sp)`009;shift to normalize
X`009SOBGTR`009R0,20$`009`009;GTR..KEEP GOING
X30$:`009bgtr`00940$`009`009;gtr..no underflow
X`009CLRL`009R0`009`009;ZERO THE EXPONENT
X`009clrq`009(sp)`009`009;return true zero
X`009clrb`009(r4)`009`009;zero the sign
X`009brb`00960$
X40$:`009cmpl`009r0,#255`009`009;overflow?
X`009bleq`00950$`009`009;leq..no
X`009movzbl`009#255,r0`009`009;set to maximum
X`009movq`009#`094x00FFFFFFFFFFFFFF,(sp);floating number
X50$:`009bbc`009#7,(r4),60$`009;bs..sign bit set => negative
X`009bisb`009#`094x80,7(sp)`009;so set it here
X60$:`009insv`009r0,#55,#8,(sp)`009;and insert the exponent
X`009movq`009(sp)+,r0`009;copy the number and clean stack
X`009rotl`009#16,r1,(r4)+`009;and return the number
X`009bbc`009#2,r2,70$`009;bc..single precision
X`009rotl`009#16,r0,(r4)+
X70$:`009sobgtr`009r3,vaxreal`009;gtr..more to do
X`009ret
X`009.sbttl`009r4i`009real*4 conversion VAX to IBM
X
X`009.entry`009r4i,`094m<r2,r3,r4>
X`009bsbw`009get_parms`009`009;get input parameters
X`009movl`009#1,-(sp)`009`009;set for single precision
X`009brb`009ibmreal
X
X`009.sbttl`009r8i`009real*8 conversion VAX to IBM
X
X`009.entry`009r8i,`094m<r2,r3,r4>
X`009bsbw`009get_parms
X`009clrl`009-(sp)`009`009`009;clear for double precision
X
Xibmreal:
X
X`009extzv`009#7,#8,(r4),r2`009`009;get the vax exponent
X`009insv`009#1,#7,#8,(r4)`009`009;and insert the hidden bit
X`009rotl`009#16,(r4)+,r1`009`009;get bits 0-31
X`009blbs`009(sp),10$`009`009;lbs..single precision
X`009rotl`009#16,(r4)+,r0`009`009;get bits 32-63
X10$:`009extzv`009#0,#2,r2,-(sp)`009`009;get fraction of 16
X`009beql`00920$`009`009`009;eql..exact
X`009addl`009#4,r2`009`009`009;adjust hex exponent
X`009subl`009#4,(sp)`009`009`009;get shift count
X`009ashq`009(sp),r0,r0`009`009;position mantissa
X20$:`009tstl`009(sp)+`009`009`009;drop shift count
X`009ashl`009#-2,r2,r2`009`009;position exponent
X`009addl`009#32,r2`009`009`009;make excess 64
X`009insv`009r2,#24,#7,r1`009`009;insert into ibm format
X`009movl`009#8,r2`009`009`009;set loop count
X60$:`009movb`009r0,-(sp)`009`009;set up the bytes
X`009ashq`009#-8,r0,r0
X`009sobgtr`009r2,60$
X`009blbs`0098(sp),70$`009`009;lbs..single precision
X`009movq`009(sp)+,-8(r4)`009`009;return ibm value
X`009brb`00980$
X70$:`009movl`009(sp)+,-4(r4)
X`009tstl`009(sp)+
X80$:`009sobgtr`009r3,ibmreal
X`009tstl`009(sp)+
X`009ret
X`009.SBTTL`009CHARACTER CONVERSION
X
X`009.ENTRY`009CHV,`094M<R2,R3,R4,R5,R6,R7>
X`009pushab`009ascii`009`009`009`009;use vax translation table
X`009brb`009characters
X
X`009.entry`009chi,`094m<r2,r3,r4,r5,r6,r7>
X`009pushab`009ebcdic`009`009`009`009;use ibm translation table
X
Xcharacters:
X
X`009movq`0094(ap),r6`009`009`009;get arguments
X`009movtc`009(r7),(r6),#0,@(sp)+,(r7),(r6)`009;convert the characters
X`009ret
X
Xascii:`009.ASCII`009/                                /
X`009.ASCII`009/                                /
X`009.ASCII`009/          \.<(+`124&         !$*);`094/
X`009.ASCII`009\-/        `124,%_>?         `096:#@'="\
X`009.ASCII`009/ abcdefghi       jklmnopqr      /
X`009.ASCII`009/ `126stuvwxyz                      /
X`009.ASCII`009/`123ABCDEFGHI      `125JKLMNOPQR      /
X`009.ASCII`009/\ STUVWXYZ      0123456789`124     /
Xebcdic:
X`009.rept`0094
X`009.byte`009`094x40,`094x40,`094x40,`094x40,`094x40,`094x40,`094x40,`094x40
X`009.endr
X`009.byte`009`094x40,`094x5a,`094x7f,`094x7b,`094x5b,`094x6c,`094x50,`094x7d
X`009.byte`009`094x4d,`094x5d,`094x5c,`094x4e,`094x6b,`094x60,`094x4b,`094x61
X`009.byte`009`094xf0,`094xf1,`094xf2,`094xf3,`094xf4,`094xf5,`094xf6,`094xf7
X`009.byte`009`094xf8,`094xf9,`094x7a,`094x5e,`094x4c,`094x7e,`094x6e,`094x6f
X`009.byte`009`094x7c,`094xc1,`094xc2,`094xc3,`094xc4,`094xc5,`094xc6,`094xc7
X`009.byte`009`094xc8,`094xc9,`094xd1,`094xd2,`094xd3,`094xd4,`094xd5,`094xd6
X`009.byte`009`094xd7,`094xd8,`094xd9,`094xe2,`094xe3,`094xe4,`094xe5,`094xe6
X`009.byte`009`094xe7,`094xe8,`094xe9,`094x4d,`094xe0,`094x5d,`094x57,`094x6d
X`009.byte`009`094x79,`094x81,`094x82,`094x83,`094x84,`094x85,`094x86,`094x87
X`009.byte`009`094x88,`094x89,`094x91,`094x92,`094x93,`094x94,`094x95,`094x96
X`009.byte`009`094x97,`094x98,`094x99,`094xa2,`094xa3,`094xa4,`094xa5,`094xa6
X`009.byte`009`094xa7,`094xa8,`094xa9,`094xc0,`094xfa,`094xd0,`094x20,`094x20
X`009.SBTTL`009LOGICAL CONVERSION
X
Xl1i::`009.ENTRY`009L1V,`094M<R2,R3,R4>
X`009BSBW`009GET_PARMS
X10$:`009CVTBL`009(R4),R0`009`009;GET THE LOGICAL VALUE
X`009BEQL`00920$`009`009;EQL..FALSE LEAVE AS IS
X`009MNEGL`009#1,R0`009`009;MAKE IT TRUE FOR THE VAX
X20$:`009MOVB`009R0,(R4)+`009;RETURN WITH THE CONVERTED NUMBER
X`009SOBGTR`009R3,10$`009`009;GTR..MORE TO DO
X`009RET
X
Xl2i::`009.entry`009l2v,`094m<r2,r3,r4>
X`009bsbw`009get_parms
X10$:`009movl`009(r4),r0`009`009;get the 370 logical value
X`009beql`00920$`009`009;eql..false, leave as is
X`009mnegl`009#1,r0`009`009;make a true vax logical value
X20$:`009movw`009r0,(r4)`009`009;and return it
X`009sobgtr`009r3,10$`009`009;gtr..moe to do
X`009ret
X
Xl4i::`009.ENTRY`009L4V,`094M<R2,R3,R4>
X`009BSBW`009GET_PARMS
X10$:`009MOVL`009(R4),R0`009`009;GET THE 370 LOGICAL VALUE
X`009BEQL`00920$`009`009;EQL..FALSE, LEAVE AS IS
X`009MNEGL`009#1,R0`009`009;MAKE A TRUE VAX LOGICAL VALUE
X20$:`009MOVL`009R0,(R4)+`009;AND RETURN IT
X`009SOBGTR`009R3,10$`009`009;GTR..MORE TO DO
X`009RET
X
X`009.END
$ CALL UNPACK NUMCON.MAR;2 424246510
$ create/nolog 'f'
X      SUBROUTINE OUTTRM
XCHANGES MADE 21-JAN-1980 ***
XC
XC      SUBROUTINE TO TERMINATE OUTPUT ACTIVITY ON 'TAPE'.
XC      CALLS WRT370 TO CLEAR OUT LAST BUFFER IF NECESSARY.
XC      CALLS WRTLBL TO WRITE EOF LABELS AND CLOSES 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 V
X      DATA IORWD/'24'X/,IOEOF/'28'X/,V/"126/
XC  FORCE OUT LAST BUFFER ONLY IF NECESSARY
X      OEOF = .TRUE.
X      IF (ORC .EQ. 0) GO TO 20
X      IF (CC .EQ. V) GO TO 10
X      CALL WRT370(V)`009`009! WRITE LAST BUFFER, FB TYPE
X      GO TO 20
X   10 IF (ORC .GT. 4) CALL WRTVBS(V) ! WRITE LAST BUFFER, VBS TYPE
X   20 CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOEOF),,,,,,,,,)`009! WRITE EOF
X      IF (.NOT.OLAB) GO TO 30
X      CALL WRTLBL(2,I)`009`009! WRITE TRAILER
X   30 CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IOEOF),,,,,,,,,)`009! WRITE EOF
X      CALL SYS$QIOW(,%VAL(LUNMT),%VAL(IORWD),,,,,,,,,)`009! REWIND TAPE
X      CALL SYS$DASSGN(%VAL(LUNMT))`009! RELEASE CHANNEL
X      RETURN
X      END
$ CALL UNPACK OUTTRM.TAP;6 808870308
$ create/nolog 'f'
X`009SUBROUTINE PROCNM(PNAM,LPNAM)
XCHANGES MADE 10-JAN-1980 ***
XC
XC`009SUBROUTINE TO GET PROCESS NAME.
XC`009PNAM IS A 15 BYTE ARRAY
XC`009LPNAM IS THE LENGTH OF INFORMATION RETURNED IN PNAM
XC
X`009INTEGER*4 PLIST(4)
X`009INTEGER*2 LIST(2)
X`009LOGICAL*1 PNAM(15)
X`009EQUIVALENCE (PLIST(1),LIST(1))
X`009DATA LIST/15,'31C'X/,PLIST(4)/0/
X`009PLIST(2) = %LOC(PNAM)
X`009PLIST(3) = %LOC(LPNAM)
X`009CALL SYS$GETJPI(,,,PLIST,,,)
X`009RETURN
X`009END
$ CALL UNPACK PROCNM.FOR;2 995560742
$ create/nolog 'f'
X      SUBROUTINE RD370(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
X      DATA IORLB/'21'X/,INORM/1/,IENDF/'870'X/
X    1 FORMAT (' ERROR IN READ ***'/'0CODE ='Z6,','I6,
X     1 ' BYTES TRANSFERRED'/'$SHALL WE CONTINUE READING? (T/F)  ')
X    2 FORMAT (L1)
X      IEOF = .FALSE.
X      IF (IRC .LT. IBLKSZ) GO TO 40
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
X   30 IBC = IBC + 1
X      IBLKSZ = IOSTAT(2)`009!USE ACTUAL BLOCKSIZE
X      IRC = 0
X   40 IF (TRAN) GO TO 50
X      DO 45 J=1,ILRECL
X   45 LRECRD(J) = INPUT(IRC+J)
X      GO TO 70
X   50 CALL EBTASC(ILRECL,INPUT(IRC+1),LRECRD)
X   70 IRC = IRC + ILRECL
X      RETURN
X      END
$ CALL UNPACK RD370.TAP;12 1618019346
$ create/nolog 'f'
X      SUBROUTINE RDLBL(MODE)
XCHANGES MADE 07-Jan-1983 ***
XC
XC      SUBROUTINE TO READ AND VERIFY STANDARD IBM TAPE LABELS, BOTH
XC      HEADER AND TRAILER LABELS ARE INCLUDED. VERIFICATION IS LIMITED
XC      TO CHECKING THE FIRST FOUR CHARACTERS OF EACH RECORD. IN`032
XC      ADDITION THE ROUTINE GETS THE LRECL AND BLKSIZE FROM HDR2, THE
XC      FILENAME FROM HDR1, THE TOTAL BLOCK COUNT FROM EOF1, THE
XC      VOLUME SERIAL IS READ FROM VOL1 AND IT IS RECORDED IF THE
XC      FILE HAS FIXED OR VARIABLE BLOCKS.
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,FV
X      LOGICAL*1 IFN,TRAN,LAB,IEOF,IVOL,FV
X      LOGICAL*1 BL
X      CHARACTER*80 IREAD
X      DATA IOSPF/'25'X/,BL/"40/
X    2 FORMAT (' NOT STANDARD LABEL ***')
X    4 FORMAT (' READ'I6,' RECORDS BUT EXPECTED'I6,' RECORDS ***')
XC
X      IBCH = IBC
X      ILRECL = 80
X      IBLKSZ = 80
X      IOSTAT(5) = 80
X      IRC = 80
X      IF (MODE .GT. 0) GO TO 20
X      CALL RD370(%REF(IREAD))
X      IF (IREAD(1:4) .NE. 'VOL1') GO TO 100
X      CALL STR$COPY_DX(%DESCR(IVOL),IREAD(5:10))
X   20 IF (MODE .GT. 1) GO TO 60
X      CALL RD370(%REF(IREAD))
+-+-+-+-+-+-+-+-  END  OF PART 3 +-+-+-+-+-+-+-+-

