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 file 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 c Note: this program reads and prints some data for the first 5 c records (see MAX=5 in the parameter statement). This is a c starting point example - you must modify the program to meet your c needs. Also this is set up to read MSTG group 3 - see the c parameter statement. 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