c **** comments concerning program qq22 for a vax ****
c
c this program was specifically altered to run on a microvax II
c system with access to the data from tape - note the open statement
c below. Subroutine GXBYTES (the VAX version of GBYTES) is used to
c unpack the binary data. This subroutine and the associated
c functions are attached to the bottom of the program. In order for
c GXBYTES to function properly it must be compiled and linked with a
c small piece of MACRO (VAX assembler) code. The MACRO code is
c attached to the end of the program - the first line reads " .title
c sgbit ". The assembler code lines should be editted out of this
c and place in another. Once there a command like : MACRO filename
c will create an oject code deck that can be linked with the other
c Fortran compiled code.
c
PROGRAM QQ22
C-----READ AND PRINT MSUG2 AND MSTG2 GROUPS 1-8
C
C-----RPTIN, BUFFER IN, UNIT, LENGTH, GBYTE/S, DATE AND TIME ARE
C MACHINE-DEPENDENT ROUTINES AND FUNCTIONS. SEE COADS RELEASE 1
C SUPPLEMENT H FOR A DESCRIPTION OF THEIR BEHAVIOR. BPW IS A
C PARAMETER WHICH MUST BE SET TO THE NUMBER OF BITS PER MACHINE
C WORD. GROUP IS A PARAMETER WHICH MUST BE SET TO THE GROUP
C NUMBER.
C ===1=========2=========3========4=========5=========6=========7==
C
C -----------REVISION HISTORY---------------------------------------
C LEVEL AUTHOR DATE DESCRIPTION
C ===== ====== ========== ====================
C .01A. SL 87/05/14. ORIGINAL VERSION.
C ------------------------------------------------------------------
C
C ===1=========2=========3========4=========5=========6=========7==
IMPLICIT INTEGER(A-E,G-Z)
C
PARAMETER(MAX=5,RPTOFF=0,FMISS=-9999.,INDEXCK=6,BPR=384,ID=0
+,BPW=32,DIM BUF=(1006*64-1)/BPW+1,DIM PK=(BPR-1)/BPW+1,DIM UN=38
+,GROUP=3,tape=10)
C
COMMON /MSTG2/FUNITS(38),FBASE(38),BITS(38),OFFSET(38)
C
DIMENSION BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN)
C
C-----2 DIMENSIONAL FTRUE
DIMENSION FTRUE2(4,8)
EQUIVALENCE (FTRUE(7),FTRUE2)
C
DATA LEVEL/4H.01A/,BUF/DIM BUF*0/
C
c specify VAX access from tape unit, msb0
open(unit=tape,form='formatted',recl=7200,blocksize=7200,
1 file='msb0:',status='old')
c
c comment out date and time functions
c
c CALL DATE(DTE)
c CALL TIME(TME)
c PRINT 1,LEVEL,DTE,TME
c 1 FORMAT('1QQ22',A4,2A9)
C
CALL DATA(GROUP)
100 CALL GETRPT(10,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID
+,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF)
IF(JEOF.NE.0)GOTO 900
C
c comment out hexidecimal write - used for checking only
c
c write(6,899) (pk(i),i=1,dim pk)
c899 format(5z12)
C
CALL WRMSTG2(FTRUE,GROUP)
IF(BUF(2).LT.MAX)GOTO 100
C
900 PRINT *,' REPORTS ',BUF(2),', EOF ',JEOF
END
C=======================================================================
SUBROUTINE WRMSTG2(FTRUE,GROUP)
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION FTRUE(38)
GOTO (1,2,3,4,5,6,7,8), GROUP
1 ASSIGN 101 TO IFMT
GOTO 100
2 ASSIGN 102 TO IFMT
GOTO 100
3 ASSIGN 103 TO IFMT
GOTO 100
4 ASSIGN 104 TO IFMT
GOTO 100
5 ASSIGN 105 TO IFMT
GOTO 100
6 ASSIGN 106 TO IFMT
GOTO 100
7 ASSIGN 107 TO IFMT
GOTO 100
8 ASSIGN 108 TO IFMT
100 PRINT IFMT,(FTRUE(I),I=1,6)
+,((FTRUE(6+(J-1)*4+I),J=1,8),I=1,4)
101 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+8X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'S',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'A',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'P',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'Q',2F8.2,F8.0,F8.2,2F8.0,2F8.1)
102 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+8X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'W',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'U',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'V',2F8.2,F8.0,F8.2,2F8.0,2F8.1/
+1X,'C',2F8.1,F8.0,F8.1,2F8.0,2F8.1)
103 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'S ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'A ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'Q ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'R ',2F8.1,F8.0,F8.1,F8.0,3F8.1)
104 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'W ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'U ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'V ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'P ',2F8.2,F8.0,F8.2,F8.0,3F8.1)
105 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'C ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'R ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'W*U ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'W*V ',2F8.1,F8.0,F8.1,F8.0,3F8.1)
106 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'S-A ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'(S-A)*W ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'QS-Q ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'(QS-Q)*W',2F8.1,F8.0,F8.1,F8.0,3F8.1)
107 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'U*A ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'V*A ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'U*Q ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'V*Q ',2F8.1,F8.0,F8.1,F8.0,3F8.1)
108 FORMAT(/' YEAR ',F5.0,' MONTH ',F3.0,' BOX2 ',F6.0
+,' BOX10 ',F4.0,' GROUP ',F3.0,' CHECKSUM ',F6.0/
+9X,7X,'3',7X,'M',7X,'N',7X,'E',7X,'D',7X,'H',7X,'X',7X,'Y'/
+1X,'S ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'A ',2F8.2,F8.0,F8.2,F8.0,3F8.1/
+1X,'W*U ',2F8.1,F8.0,F8.1,F8.0,3F8.1/
+1X,'W*V ',2F8.1,F8.0,F8.1,F8.0,3F8.1)
END
C=======================================================================
SUBROUTINE DATA(GROUP)
IMPLICIT INTEGER(A-E,G-Z)
C
COMMON /MSTG2/FUNITS(38),FBASE(38),BITS(38),OFFSET(38)
C
DATA FUNITS/1.,1.,1.,1.,1.,1.
+ ,.01,.01,.1,.1
+ ,.01,.01,.1,.1
+ ,1.,1.,1.,1.
+ ,.01,.01,.1,.1
+ ,2.,2.,2.,2.
+ ,.1,.1,.1,.1
+ ,.2,.2,.2,.2
+ ,.2,.2,.2,.2/
C
DATA FBASE/1799.,0.,0.,0.,0.,0.
+ ,-501.,-8801.,-30001.,-30001.
+ ,-501.,-8801.,-30001.,-30001.
+ ,0.,0.,0.,0.
+ ,-1.,-1.,-1.,-1.
+ ,0.,0.,0.,0.
+ ,-1.,-1.,-1.,-1.
+ ,-.5,-.5,-.5,-.5
+ ,-.5,-.5,-.5,-.5/
C
DATA BITS/8,4,14,10,4,8
+ ,16,16,16,16
+ ,16,16,16,16
+ ,16,16,16,16
+ ,16,16,16,16
+ ,4,4,4,4
+ ,4,4,4,4
+ ,4,4,4,4
+ ,4,4,4,4/
C
DATA OFFSET/16,24,28,42,52,56
+ ,64,80,96,112
+ ,128,144,160,176
+ ,192,208,224,240
+ ,256,272,288,304
+ ,320,324,328,332
+ ,336,340,344,348
+ ,352,356,360,364
+ ,368,372,376,380/
C
GOTO (1,2,3,4,5,6,7,8), GROUP
C
1 FUNITS(7)=.01
FUNITS(8)=.01
FUNITS(9)=.01
FUNITS(10)=.01
FUNITS(11)=.01
FUNITS(12)=.01
FUNITS(13)=.01
FUNITS(14)=.01
FUNITS(19)=.01
FUNITS(20)=.01
FUNITS(21)=.01
FUNITS(22)=.01
FUNITS(27)=2.
FUNITS(28)=2.
FUNITS(29)=2.
FUNITS(30)=2.
FBASE(7)=-501.
FBASE(8)=-8801.
FBASE(9)=86999.
FBASE(10)=-1.
FBASE(11)=-501.
FBASE(12)=-8801.
FBASE(13)=86999.
FBASE(14)=-1.
FBASE(27)=-.5
FBASE(28)=-.5
FBASE(29)=-.5
FBASE(30)=-.5
RETURN
C
2 FUNITS(7)=.01
FUNITS(8)=.01
FUNITS(9)=.01
FUNITS(10)=.1
FUNITS(11)=.01
FUNITS(12)=.01
FUNITS(13)=.01
FUNITS(14)=.1
FUNITS(19)=.01
FUNITS(20)=.01
FUNITS(21)=.01
FUNITS(22)=.1
FUNITS(27)=2.
FUNITS(28)=2.
FUNITS(29)=2.
FUNITS(30)=2.
FBASE(7)=-1.
FBASE(8)=-10221.
FBASE(9)=-10221.
FBASE(10)=-1.
FBASE(11)=-1.
FBASE(12)=-10221.
FBASE(13)=-10221.
FBASE(14)=-1.
FBASE(27)=-.5
FBASE(28)=-.5
FBASE(29)=-.5
FBASE(30)=-.5
RETURN
C
3 FUNITS(7)=.01
FUNITS(8)=.01
FUNITS(9)=.01
FUNITS(10)=.1
FUNITS(11)=.01
FUNITS(12)=.01
FUNITS(13)=.01
FUNITS(14)=.1
FUNITS(19)=.01
FUNITS(20)=.01
FUNITS(21)=.01
FUNITS(22)=.1
FBASE(7)=-501.
FBASE(8)=-8801.
FBASE(9)=-1.
FBASE(10)=-1.
FBASE(11)=-501.
FBASE(12)=-8801.
FBASE(13)=-1.
FBASE(14)=-1.
RETURN
C
4 FUNITS(7)=.01
FUNITS(8)=.01
FUNITS(9)=.01
FUNITS(10)=.01
FUNITS(11)=.01
FUNITS(12)=.01
FUNITS(13)=.01
FUNITS(14)=.01
FUNITS(19)=.01
FUNITS(20)=.01
FUNITS(21)=.01
FUNITS(22)=.01
FBASE(7)=-1.
FBASE(8)=-10221.
FBASE(9)=-10221.
FBASE(10)=86999.
FBASE(11)=-1.
FBASE(12)=-10221.
FBASE(13)=-10221.
FBASE(14)=86999.
RETURN
C
5 FUNITS(7)=.1
FUNITS(8)=.1
FUNITS(9)=.1
FUNITS(10)=.1
FUNITS(11)=.1
FUNITS(12)=.1
FUNITS(13)=.1
FUNITS(14)=.1
FUNITS(19)=.1
FUNITS(20)=.1
FUNITS(21)=.1
FUNITS(22)=.1
FBASE(7)=-1.
FBASE(8)=-1.
FBASE(9)=-30001.
FBASE(10)=-30001.
FBASE(11)=-1.
FBASE(12)=-1.
FBASE(13)=-30001.
FBASE(14)=-30001.
RETURN
C
6 FUNITS(7)=.01
FUNITS(8)=.1
FUNITS(9)=.01
FUNITS(10)=.1
FUNITS(11)=.01
FUNITS(12)=.1
FUNITS(13)=.01
FUNITS(14)=.1
FUNITS(19)=.01
FUNITS(20)=.1
FUNITS(21)=.01
FUNITS(22)=.1
FBASE(7)=-6301.
FBASE(8)=-10001.
FBASE(9)=-4001.
FBASE(10)=-10001.
FBASE(11)=-6301.
FBASE(12)=-10001.
FBASE(13)=-4001.
FBASE(14)=-10001.
RETURN
C
7 FUNITS(7)=.1
FUNITS(8)=.1
FUNITS(9)=.1
FUNITS(10)=.1
FUNITS(11)=.1
FUNITS(12)=.1
FUNITS(13)=.1
FUNITS(14)=.1
FUNITS(19)=.1
FUNITS(20)=.1
FUNITS(21)=.1
FUNITS(22)=.1
FBASE(7)=-20001.
FBASE(8)=-20001.
FBASE(9)=-10001.
FBASE(10)=-10001.
FBASE(11)=-20001.
FBASE(12)=-20001.
FBASE(13)=-10001.
FBASE(14)=-10001.
RETURN
C
8 END
C=======================================================================
SUBROUTINE GETRPT(TAPE,FMISS,FUNITS,FBASE,BITS,OFFSET,INDEXCK,ID
+,BPR,BPW,RPTOFF,BUF,DIM BUF,PK,DIM PK,UN,DIM UN,FTRUE,JEOF)
C
C-----RETURN FLOATING POINT VALUES IN FTRUE
C
C INPUT
C TAPE - RPTIN/RCDIN UNIT
C FMISS - MISSING VALUE
C FUNITS(DIM UN) - UNITS FOR UNCODING
C FBASE(DIM UN) - BASE FOR UNCODING
C BITS(DIM UN) - BITS FOR UNPACKING
C OFFSET(DIM UN) - OFFSET FOR UNPACKING
C INDEXCK - UN(INDEXCK) = CHECKSUM
C ID - GROUP NUMBER FOR IDENTIFICATION CHECKSUM
C BPR - BITS PER REPORT
C BPW - BITS PER WORD
C RPTOFF - 0=FALSE 1=TRUE
C OUTPUT
C BUF(DIM BUF) - RPTIN/RCDIN BUFFER
C PK(DIM PK) - PACKED REPORT
C UN(DIM UN) - UNPACKED REPORT
C FTRUE(DIM UN) - TRUE VALUES
C JEOF - 0=FALSE 1=TRUE
C
IMPLICIT INTEGER(A-E,G-Z)
DIMENSION FUNITS(DIM UN),FBASE(DIM UN),BITS(DIM UN),OFFSET(DIM UN)
+,BUF(DIM BUF),PK(DIM PK),UN(DIM UN),FTRUE(DIM UN)
C
C-----RPTIN/RCDIN
IF(RPTOFF.NE.0)GOTO 100
c
c use rcdin always
c
c CALL RPTIN(TAPE,BUF,PK,KWDS,1,DIM PK,JEOF)
c GOTO 110
100 CALL RCDIN(TAPE,BUF,DIM BUF,PK,DIM PK,BPR,BPW,JEOF)
110 IF(JEOF-1)200,900,800
C
C-----GBYTE AND CONVERT TO TRUE
200 CK=ID
DO 230 I=1,DIM UN
CALL GBYTE(PK(OFFSET(I)/BPW+1),UN(I),MOD(OFFSET(I),BPW),BITS(I))
IF(I.EQ.INDEXCK)GOTO 210
IF(UN(I).EQ.0)GOTO 220
FTRUE(I)=(UN(I)+FBASE(I))*FUNITS(I)
CK=CK+UN(I)
GOTO 230
210 FTRUE(INDEXCK)=UN(INDEXCK)
GOTO 230
220 FTRUE(I)=FMISS
230 CONTINUE
return
c
c avoid checksum verification
c
c IF(MOD(CK,2**BITS(INDEXCK)-1).EQ.UN(INDEXCK))RETURN
C
C-----ERROR
c PRINT *,' SUBROUTINE GETRPT -- CHECKSUM ERROR, TAPE = ',TAPE
c +,', REPORT = ',BUF(2)
c PRINT *,' FTRUE = ',FTRUE
800 STOP
C
900 END
C=======================================================================
SUBROUTINE RCDIN(TAPE,BUF,DIM BUF,RCD,DIM RCD,BPR,BPW,JEOF)
C
C-----RETURN ONE LOGICAL RECORD IN RCD
C
C INPUT
C TAPE - BUFFER IN UNIT
C BPR - BITS PER RECORD
C BPW - BITS PER WORD
C OUTPUT
C BUF(DIM BUF) - PHYSICAL RECORD
C RCD(DIM RCD) - LOGICAL RECORD
C JEOF - 0=FALSE 1=TRUE
C
C BUF(1) = GBYTE OFFSET
C BUF(2) = LOGICAL RECORD COUNT
C BUF(3) = PHYSICAL RECORD COUNT
C BUF(4) =
C BUF(5) = BLOCK LENGTH IN BITS
C BUF(6) =
C
IMPLICIT INTEGER(A-E,G-Z)
REAL UNIT
DIMENSION BUF(DIM BUF),RCD(DIM RCD)
C
IF(BUF(1)+BPR.LE.BUF(5))GOTO 200
C-----BUFFER IN
c
c read directly from tape, do not use buffer in
10 read(tape,201)(buf(i),i=7,1806)
201 format(1800a4)
c
c write the first part of the input record in hexidecimal
c just to check the bytes
c
c write(6,202)(buf(i),i=7,31)
c202 format(5z12)
c
jeof=0
100 BUF(1)=0
BUF(5)=57600
BUF(3)=BUF(3)+1
C
C-----GBYTE
200 CALL GxBYTES
+(BUF(6+BUF(1)/BPW+1) ,RCD ,MOD(BUF(1),BPW) ,BPW ,0 ,DIM RCD)
IF(RCD(1).EQ.0.AND.RCD(2).EQ.0)GOTO 10
BUF(1)=BUF(1)+BPR
BUF(2)=BUF(2)+1
RETURN
C
C-----ERROR
800 PRINT *,' SUBROUTINE RCDIN -- BUFFER IN ERROR, TAPE = ',TAPE
+,', BLOCK = ',BUF(3)+1
STOP
END
SUBROUTINE GBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
DIMENSION NPACK(ITER),ISAM(ITER)
C ++++++++++
C CALL GBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C starts unpacking bits at bit offset IBIT in array
C NPACK. It takes NBITS and stores them in the longword
C array starting at ISAM. Then NSKIP bits are skipped in
C NPACK and the next field of NBITS is unpacked into the
C next ISAM. This is done a total of ITER times.
C
C this routine extracts bits from vax words.
C it is similar to NCAR's GBYTE but it works with
C the natural underlying structure of the VAX.
C ----------
ISW = 1
GO TO 10
ENTRY SBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C ++++++++++
C CALL SBITS(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C This routine takes the first longword located at
C ISAM and stores it into the NBITS of NPACK starting at
C bit offset IBIT. Then NSKIP bits are skipped in
C NPACK and the process is repeated a total of ITER times.
C
C this routine extracts bits from vax words.
C it is similar to NCAR's SBYTE but it works with
C the natural underlying structure of the VAX.
C ----------
ISW = 2
GO TO 10
ENTRY GXBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C ++++++++++
C CALL GXBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C starts unpacking bits at bit offset IBIT in array
C NPACK. It takes NBITS and stores them in the longword
C array starting at ISAM. Then NSKIP bits are skipped in
C NPACK and the next field of NBITS is unpacked into the
C next ISAM. This is done a total of ITER times.
C
C This routine deals with bits and bytes in the order
C they are numbered on the Mesa (ie Bigendian).
C ----------
ISW = 3
GO TO 10
ENTRY SXBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C ++++++++++
C CALL SXBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C This routine takes the first longword located at
C ISAM and stores it into the NBITS of NPACK starting at
C bit offset IBIT. Then NSKIP bits are skipped in
C NPACK and the process is repeated a total of ITER times.
C
C
C This routine deals with bits and bytes in the order
C they are numbered on the Mesa (ie Bigendian).
C ----------
ISW = 4
GOTO 10
ENTRY GBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C THIS ROUTINE IS JUST A REPEATED CALL TO GBYTE
C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS
C AND THE LOOP COUNT IS ITER
ISW = 5
GOTO 10
ENTRY SBYTES(NPACK,ISAM,IBIT,NBITS,NSKIP,ITER)
C THIS ROUTINE IS JUST A REPEATED CALL TO SBYTE
C WHERE SUCCESSIVE CALLS SKIP NSKIP BITS
C AND THE LOOP COUNT IS ITER
ISW = 6
GOTO 10
10 IOFF = IBIT
IBASE = 1
DO 30 I = 1 , ITER
GO TO(11,12,13,14,15,16)ISW
11 CALL GBIT(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GO TO 20
12 CALL SBIT(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GO TO 20
13 CALL GXBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GO TO 20
14 CALL SXBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GO TO 20
15 CALL GBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GOTO 20
16 CALL SBYTE(NPACK(IBASE),ISAM(I),IOFF,NBITS)
GOTO 20
20 IOFF = IOFF + NBITS + NSKIP
IBASE = IBASE + IOFF/32
IOFF = MOD(IOFF,32)
30 CONTINUE
RETURN
END
SUBROUTINE GXBYTE(NPACK,ISAM,IBIT,NBITS)
C ++++++++++
C CALL GXBYTE(NPACK,ISAM,IBIT,NBITS)
C starts unpacking bits at bit offset IBIT in array
C NPACK. It takes NBITS and stores them in the longword
C array starting at ISAM.
C
C This routine deals with bits and bytes in the order
C they are numbered on the Mesa (ie Bigendian).
C ----------
C
C gbyte and sbyte are special routines to do the same
C things as their counterparts on the Mesa.
C They differ from the bits routines in that bits
C are counted from the top of the word rather than
C the bottom. This means that the bits they specify jump around
C when crossing byte boundaries. There is no assumption
C made about the wordsize of the machine they were written
C on. However the maximum number of bits extracted must be
C less than or equal to 32.
C
BYTE NPACK(8)
INTEGER T
EXTERNAL SS$_ABORT
IDBIT(I) = 7 - MOD(I,8)
ISW = 3
ISAM = 0
GO TO 10
ENTRY SXBYTE(NPACK,ISAM,IBIT,NBITS)
C ++++++++++
C CALL SXBYTE(NPACK,ISAM,IBIT,NBITS)
C This routine takes the first longword located at
C ISAM and stores it into the NBITS of NPACK starting at
C bit offset IBIT.
C
C
C This routine deals with bits and bytes in the order
C they are numbered on the Mesa (ie Bigendian).
C ----------
ISW = 4
10 IBASE = IBIT/8
C ibase points to the first byte involved
IOFF = IBIT - 8*IBASE
C ioff is the bit offset within first byte
M = (IOFF+NBITS-1)/8 + 1
C m is the number of bytes (including partials) involved
C IF(M.GT.5)THEN
IF(NBITS.GT.32)THEN
TYPE *,'ILLEGAL VALUE FOR NBITS IN S/GBYTE(S) CALL'
CALL SYS$EXIT(SS$_ABORT)
END IF
NN = 0
C nn is the number of bits transferred
DO 20 I = M , 1 , -1
C loop on bytes
IS = IDBIT(0)
C calc first bit within byte
IE = IDBIT(7)
C calc last bit within byte
IF(I.EQ.1)IS = IDBIT(IOFF)
C first bit varies for first byte
IF(I.EQ.M)IE = IDBIT(IOFF+NBITS-1)
C last bit varies for last byte
N = IS - IE + 1
C calc number of bits within byte to xfer
IF(ISW.EQ.4)GO TO 12
CALL GBIT(NPACK(IBASE+I),T,IE,N)
C extract bits from source
CALL SBIT(ISAM,T,NN,N)
C and load into destination
GO TO 15
12 CALL GBIT(ISAM,T,NN,N)
C extract bits from source
CALL SBIT(NPACK(IBASE+I),T,IE,N)
C and load into destination
15 NN = NN + N
C update bits xferred
20 CONTINUE
RETURN
END
SUBROUTINE GBYTE(NPACK,ISAM,IBIT,NBITS)
C
C gbyte and sbyte are special routines to do the same
C things as their counterparts on the Mesa.
C They differ from the bits routines in that bits
C are counted from the top of the word rather than
C the bottom. This means that the bits they specify jump around
C when crossing byte boundaries. There is no assumption
C made about the wordsize of the machine they were written
C on. However the maximum number of bits extracted must be
C less than or equal to 32.
C
BYTE NPACK(8)
INTEGER T
EXTERNAL SS$_ABORT
IDBIT(I) = 7 - MOD(I,8)
ISW = 3
ISAM = 0
GO TO 10
ENTRY SBYTE(NPACK,ISAM,IBIT,NBITS)
ISW = 4
10 IBASE = IBIT/8
C ibase points to the first byte involved
IOFF = IBIT - 8*IBASE
C ioff is the bit offset within first byte
M = (IOFF+NBITS-1)/8 + 1
C m is the number of bytes (including partials) involved
C IF(M.GT.5)THEN
IF(NBITS.GT.32)THEN
TYPE *,'ILLEGAL VALUE FOR NBITS IN S/GBYTE(S) CALL'
CALL SYS$EXIT(SS$_ABORT)
END IF
NN = 0
C nn is the number of bits transferred
DO 20 I = M , 1 , -1
C loop on bytes
IBB = IBASE + I - 1
IBC = IBB/4
IBD = 4*IBC+3-MOD(IBB,4) + 1
C calculate unshifted byte
IS = IDBIT(0)
C calc first bit within byte
IE = IDBIT(7)
C calc last bit within byte
IF(I.EQ.1)IS = IDBIT(IOFF)
C first bit varies for first byte
IF(I.EQ.M)IE = IDBIT(IOFF+NBITS-1)
C last bit varies for last byte
N = IS - IE + 1
C calc number of bits within byte to xfer
IF(ISW.EQ.4)GO TO 12
C CALL GBIT(NPACK(IBASE+I),T,IE,N)
CALL GBIT(NPACK(IBD),T,IE,N)
C extract bits from source
CALL SBIT(ISAM,T,NN,N)
C and load into destination
GO TO 15
12 CALL GBIT(ISAM,T,NN,N)
C extract bits from source
C CALL SBIT(NPACK(IBASE+I),T,IE,N)
CALL SBIT(NPACK(IBD),T,IE,N)
C and load into destination
15 NN = NN + N
C update bits xferred
20 CONTINUE
RETURN
END
.title sgbit
; ++++++++++
; CALL GBIT(NPACK,ISAM,IBIT,NBITS)
; unpacks the bit pattern located at a bit offset
; of IBIT in NPACK of length NBITS into ISAM.
;
; this routine extracts bits from vax words.
; it is similar to NCAR's GBYTE but it works with
; the natural underlying structure of the VAX.
; ----------
.PSECT MACRO_CODE PIC,USR,CON,REL,LCL,SHR,EXE,RD,NOWRT,NOVEC
.ENTRY GBIT,0
extzv @12(ap),@16(ap),@4(ap),@8(ap) ;isn't this neat ?
ret
;
;
; ++++++++++
; CALL SBIT(NPACK,ISAM,IBIT,NBITS)
; packs the value in ISAM into NPACK
; with NBITS offset by IBIT.
;
; this routine extracts bits from vax words.
; it is similar to NCAR's SBYTE but it works with
; the natural underlying structure of the VAX.
; ----------
.ENTRY SBIT,0
insv @8(ap),@12(ap),@16(ap),@4(ap) ;isn't this neat ?
ret
.end