PROGRAM qs2_sun C-----READ AND PRINT LMR6 C C AUTHOR: S.LUBKER, 93/10/15. 17:26:52. C -----------REVISION HISTORY---------------------------------------34567898 C LEVEL AUTHOR DATE DESCRIPTION C ===== ====== ========== ==================== C .01A. SJL 93/10/15. ORIGINAL VERSION. C ------------------------------------------------------------------34567898 IMPLICIT INTEGER(A-E,G-Z) C DATA UNIT/1/ DATA FMISS/-999./ C C-----BITS PER WORD PARAMETER(BPW=32) C PARAMETER(DIM BUF=(1006*64-1)/BPW+1) DIMENSION BUF(DIM BUF) DATA (BUF(I),I=1,6)/6*0/,DEOF/0/ C PARAMETER(BPR=452+(3+255)*4*15,DIM RPT=(BPR-1)/BPW+1) DIMENSION RPT(DIM RPT) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) COMMON /LMR6/FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER) COMMON /LMR6/OFFSET(NUMBER),FORMAT(NUMBER),RPTID,INDXCK C DIMENSION CODED(NUMBER),FTRUE(NUMBER) C DIMENSION AL(15),AD(255,15) DIMENSION QCFLG(14) DIMENSION TRFLG(23) DIMENSION SUP(255) DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51) C CHARACTER*8 YYMMDD,HHMMSS CHARACTER LEVEL*4,FILE*32 DATA LEVEL/'.01A'/ C CALL DATE(YYMMDD) CALL CLOCK(HHMMSS) file = '/huron/u2/tmp/worley/lmr' OPEN(UNIT,FILE=FILE) C C-----READ REPORT 100 CALL RPTIN(UNIT,BUF,RPT,NRPT,1,DIM RPT,EOF) IF(EOF.NE.0)GOTO 900 DEOF=0 IF(MOD(BUF(2)-1,56).EQ.0)THEN PRINT 1,LEVEL,YYMMDD,HHMMSS,FILE,(BUF(2)-1)/56+1 1 FORMAT('1QS2',A4,2A9,' < ',A,T132,I10) CALL PRNFLD(FIELD,FORMAT,NUMBER) ENDIF C C-----UNPACK REPORT AND CONVERT CODED TO TRUE VALUES CALL GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C-----PRINT REPORT CALL PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) C C-----UNPACK ATTACHMENTS C GOTO 700 IF(NRPT.NE.64/BPW*((GETATT(RPT,AL,AD)-1)/64+1))STOP 'NRPT' CALL GETQCF(AL,AD,QCFLG,QC) IF(QC.GE.0) +PRINT *,'QC ATT: "',(CHAR(QCFLG(I)),I=1,14),QC,'"' CALL GETTRF(AL,AD,TRFLG) IF(TRFLG(1).NE.0) +PRINT *,'TRIM ATT: "',TRFLG,'"' CALL GETSUP(AL,AD,SUP,SUPLEN) IF(SUPLEN.NE.0) +PRINT *,'SUP ATT: "',(CHAR(SUP(I)),I=1,SUPLEN),'"' CALL GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) IF(NERR.NE.0) +PRINT *,'ERR ATT:',(' ',FIELD(ERRNUM(J))(1:3) +,' = "',(CHAR(ERR(I,J)),I=1,ERRLEN(J)),'"',J=1,NERR) 700 CONTINUE C IF(BUF(2).EQ.10)STOP 'ETC' GOTO 100 C C-----END OF FILE 900 PRINT *,' REPORTS ',BUF(2),', EOF ',EOF DEOF=DEOF+1 IF(DEOF.LT.2)GOTO 100 END C-----------------------------------------------------------------------3456789 BLOCK DATA BDLMR6 IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*8 FIELD,FORMAT PARAMETER(NUMBER=73) COMMON /LMR6/FIELD(NUMBER),FTRUEL(NUMBER),FTRUEU(NUMBER) +,FUNITS(NUMBER),FBASE(NUMBER),BITS(NUMBER),OFFSET(NUMBER) +,FORMAT(NUMBER),RPTID,INDXCK C DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I= 1,10) 1/'B10 ', 1., 648., 1., 0., 10, 16,'(A4 ' 2,'YR ', 1770., 2024., 1., 1769., 8, 26,',A4 ' 3,'MO ', 1., 12., 1., 0., 4, 34,',A2 ' 4,'DY ', 1., 31., 1., 0., 5, 38,',A2 ' 5,'HR ', 0.00, 23.99, 0.01, -1.00, 12, 43,',A4 ' 6,'TI ', 0., 3., 1., -1., 4, 55,',A1 ' 7,'LON ', 0.00, 359.99, 0.01, -1.00, 16, 59,',A5 ' 8,'LAT ', -90.00, 90.00, 0.01,-9001.00, 15, 75,',A5 ' 9,'LI ', 0., 6., 1., -1., 4, 90,',A1 ' 1,'DCK ', 0., 999., 1., -1., 10, 94,',A3 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=11,20) 1/'SID ', 0., 80., 1., -1., 8, 104,',A2 ' 2,'PT ', 0., 15., 1., -1., 5, 112,',A2 ' 3,'QI ', 0., 2., 1., -1., 2, 117,',A1 ' 4,'DS ', 0., 13., 1., -1., 5, 119,',A2 ' 5,'DC ', 0., 2., 1., -1., 4, 124,',A2 ' 6,'TC ', 0., 1., 1., -1., 3, 128,',A1 ' 7,'PB ', 0., 2., 1., -1., 2, 131,',A1 ' 8,'DI ', 0., 6., 1., -1., 4, 133,',A1 ' 9,'D ', 1., 362., 1., 0., 9, 137,',A3 ' 2,'WI ', 0., 8., 1., -1., 4, 146,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=21,30) 1/'W ', 0.0, 102.2, 0.1, -1.0, 10, 150,',A4 ' 2,'VI ', 0., 2., 1., -1., 2, 160,',A1 ' 3,'VV ', 90., 99., 1., 89., 4, 162,',A2 ' 4,'WW ', 0., 99., 1., -1., 7, 166,',A2 ' 5,'W1 ', 0., 9., 1., -1., 4, 173,',A1 ' 6,'W2 ', 0., 9., 1., -1., 4, 177,',A1 ' 7,'SLP ', 870.0, 1074.6, 0.1, 8699.0, 11, 181,',A5 ' 8,'T1 ', 0., 9., 1., -1., 4, 192,',A1 ' 9,'AT ', -99.9, 99.9, 0.1, -1000.0, 11, 196,',A4 ' 3,'WBT ', -99.9, 99.9, 0.1, -1000.0, 11, 207,',A4 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=31,40) 1/'DPT ', -99.9, 99.9, 0.1, -1000.0, 11, 218,',A4 ' 2,'SST ', -99.9, 99.9, 0.1, -1000.0, 11, 229,',A4 ' 3,'SI ', 0., 12., 1., -1., 4, 240,',A2 ' 4,'N ', 0., 9., 1., -1., 4, 244,',A1 ' 5,'NH ', 0., 9., 1., -1., 4, 248,',A1 ' 6,'CL ', 0., 10., 1., -1., 4, 252,',A2 ' 7,'HI ', 0., 1., 1., -1., 2, 256,',A1 ' 8,'H ', 0., 10., 1., -1., 4, 258,',A2 ' 9,'CM ', 0., 10., 1., -1., 4, 262,',A2 ' 4,'CH ', 0., 10., 1., -1., 4, 266,',A2 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=41,50) 1/'WD ', 0., 38., 1., -1., 6, 270,',A2 ' 2,'WP ', 0., 30., 1., -1., 5, 276,',A2 ' 3,'WH ', 0., 49.5, 0.5, -1., 7, 281,',A2 ' 4,'SD ', 0., 38., 1., -1., 6, 288,',A2 ' 5,'SP ', 0., 30., 1., -1., 5, 294,',A2 ' 6,'SH ', 0., 49.5, 0.5, -1., 7, 299,',A2 ' 7,'C1 ', 0., 40., 1., -1., 7, 306,',A2 ' 8,'C2 ', 0., 40., 1., -1., 7, 313,',A2 ' 9,'SC ', 0., 9., 1., -1., 4, 320,',A1 ' 5,'SS ', 0., 9., 1., -1., 4, 324,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=51,60) 1/'A ', 0., 8., 1., -1., 4, 328,',A1 ' 2,'PPP ', 0.0, 51.0, 0.1, -1.0, 9, 332,',A3 ' 3,'IS ', 1., 5., 1., 0., 3, 341,',A1 ' 4,'ES ', 0., 99., 1., -1., 7, 344,',A2 ' 5,'RS ', 0., 4., 1., -1., 3, 351,',A1 ' 6,'II ', 0., 10., 1., -1., 4, 354,',A2 ' 7,'ID1 ', 33., 95., 1., 32., 6, 358,', A1' 8,'ID2 ', 33., 95., 1., 32., 6, 364,', A1' 9,'ID3 ', 33., 95., 1., 32., 6, 370,', A1' 6,'ID4 ', 33., 95., 1., 32., 6, 376,', A1'/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=61,70) 1/'ID5 ', 33., 95., 1., 32., 6, 382,', A1' 2,'ID6 ', 33., 95., 1., 32., 6, 388,', A1' 3,'ID7 ', 33., 95., 1., 32., 6, 394,', A1' 4,'ID8 ', 33., 95., 1., 32., 6, 400,', A1' 5,'OS ', 0., 6., 1., -1., 4, 406,',A1 ' 6,'OP ', 0., 9., 1., -1., 4, 410,',A1 ' 7,'T2 ', 0., 6., 1., -1., 3, 414,',A1 ' 8,'IX ', 1., 6., 1., 0., 4, 417,',A1 ' 9,'WX ', 1., 1., 1., 0., 1, 421,',A1 ' 7,'SX ', 1., 1., 1., 0., 1, 422,',A1 '/ DATA (FIELD(I),FTRUEL(I),FTRUEU(I),FUNITS(I),FBASE(I) +,BITS(I),OFFSET(I),FORMAT(I),I=71,73) 1/'IRD ', 1., 255., 1., 0., 8, 423,',A3 ' 2,'A6 ', 0., 1., 1., -1., 2, 431,',A1 ' 3,'CK ', 0., 30., 1., 0., 5, 443,',A2)'/ C DATA INDXCK/NUMBER/,RPTID/6/ END C-----------------------------------------------------------------------3456789 FUNCTION GETATT(RPT,AL,AD) C UNPACK ATTACHMENTS RETURNING LENGTH OF RPT IN BITS C IMPLICIT INTEGER(A-E,G-Z) DIMENSION RPT(*) DIMENSION AL(15),AD(255,15) GETATT=452 CALL GBYTE(RPT,AC,452-4,4) DO 190 I=1,15 AL(I)=0 IF(AC.EQ.0)GOTO 190 CALL GBYTE(RPT,AID,GETATT+8,4) IF(AID.NE.I)GOTO 190 CALL GBYTE(RPT,AL(AID),GETATT,8) CALL GBYTES(RPT,AD(1,AID),GETATT+12,4,0,AL(AID)) GETATT=GETATT+12+4*AL(AID) AC=AC-1 190 CONTINUE END C-----------------------------------------------------------------------3456789 SUBROUTINE GETERR(AL,AD,ERRNUM,ERRLEN,ERR,NERR) C GET ERROR ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION ERRNUM(51),ERRLEN(51),ERR(15,51) C J=0 NERR=0 100 J=J+1 IF(J.GT.AL(5))RETURN NERR=NERR+1 ERRNUM(NERR)=AD(J,5)*16+AD(J+1,5) ERRLEN(NERR)=AD(J+2,5) J=J+2 DO 190 I=1,ERRLEN(NERR) ERR(I,NERR)=AD(J+1,5)*16+AD(J+2,5) J=J+2 190 CONTINUE GOTO 100 END C-----------------------------------------------------------------------3456789 SUBROUTINE GETQCF(AL,AD,QCFLG,QC) C GET QUALITY CONTROL ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION QCFLG(14) DIMENSION ICHAR(11) DATA ICHAR/32,82,65,66,74,75,76,77,78,81,83/ C IF(AL(1).EQ.16)THEN DO 190 I=1,14 QCFLG(I)=ICHAR(AD(I,1)+1) 190 CONTINUE QC=AD(15,1)*16+AD(16,1)-1 ELSE QC=-999 ENDIF END C-----------------------------------------------------------------------3456789 SUBROUTINE GETRPT(RPT,CODED,FTRUE,FMISS +,FUNITS,FBASE,BITS,OFFSET,NUMBER,RPTID,INDXCK) C UNPACK REPORT AND CONVERT CODED TO TRUE VALUES C IMPLICIT INTEGER(A-E,G-Z) C CHARACTER*(*) RPT DIMENSION CODED(*),FTRUE(*),FUNITS(*),FBASE(*),BITS(*),OFFSET(*) C IF(MOD(ICHAR(RPT(2:2)),16).NE.RPTID)STOP 'RPTID' C CODED(INDXCK)=0 DO 190 I=1,NUMBER IF(I.EQ.INDXCK)GOTO 190 CALL GBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) IF(CODED(I).EQ.0)THEN FTRUE(I)=FMISS ELSE FTRUE(I)=(CODED(I)+FBASE(I))*FUNITS(I) CODED(INDXCK)=CODED(INDXCK)+CODED(I) ENDIF 190 CONTINUE I=INDXCK FTRUE(I)=MOD(CODED(I),2**BITS(I)-1) CALL GBYTE(RPT,CODED(I),OFFSET(I),BITS(I)) IF(FTRUE(I).NE.CODED(I))STOP 'CHECKSUM' END C-----------------------------------------------------------------------3456789 SUBROUTINE GETTRF(AL,AD,TRFLG) C GET TRIMMING ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION TRFLG(23) C IF(AL(2).EQ.16)THEN C TRFLG( 1)= AD( 1,2)*16*16*4 C + +AD( 2,2)*16*4 C + +AD( 3,2)*4 C + +AD( 4,2)/4 TRFLG( 1)=((AD( 1,2)*16+AD( 2,2))*16+AD( 3,2))*4+AD( 4,2)/4 TRFLG( 2)=MOD(AD( 4,2) ,4) TRFLG( 3)= AD( 5,2) TRFLG( 4)= AD( 6,2) TRFLG( 5)= AD( 7,2) TRFLG( 6)= AD( 8,2) TRFLG( 7)= AD( 9,2) TRFLG( 8)= AD(10,2) TRFLG( 9)= AD(11,2)/4 TRFLG(10)=MOD(AD(11,2) ,4) TRFLG(11)= AD(12,2)/4 TRFLG(12)=MOD(AD(12,2) ,4) TRFLG(13)= AD(13,2)/4 TRFLG(14)=MOD(AD(13,2) ,4) TRFLG(15)= AD(14,2)/4 TRFLG(16)=MOD(AD(14,2) ,4) TRFLG(17)= AD(15,2)/4 TRFLG(18)=MOD(AD(15,2)/2 ,2) TRFLG(19)=MOD(AD(15,2) ,2) TRFLG(20)= AD(16,2)/2/2/2 TRFLG(21)=MOD(AD(16,2)/2/2 ,2) TRFLG(22)=MOD(AD(16,2)/2 ,2) TRFLG(23)=MOD(AD(16,2) ,2) ELSE DO 190 I=1,23 TRFLG(I)=0 190 CONTINUE ENDIF END C-----------------------------------------------------------------------3456789 SUBROUTINE GETSUP(AL,AD,SUP,SUPLEN) C GET SUPPLEMENTAL ATTACHMENT C IMPLICIT INTEGER(A-E,G-Z) DIMENSION AL(15),AD(255,15) DIMENSION SUP(255) DIMENSION SHIP(256) DATA SHIP +/48,49,50,51,52,53,54,55,56,57,32,181*15 +,123,65,66,67,68,69,70,71,72,73,38,43,4*15 +,125,74,75,76,77,78,79,80,81,82,45,6*15 +,47,83,84,85,86,87,88,89,90,42,21*15/ C I=0 SUPLEN=0 100 I=I+1 IF(I.GT.AL(4))RETURN SUPLEN=SUPLEN+1 C GOTO(9,9,9,9,9,9,9,9,9,9,9,11,14,14,14,15)AD(I,4)+1 C 9 SUP(SUPLEN)=SHIP(AD(I,4)+1) GOTO 100 C 11 DO 190 M=1,3+AD(I+1,4) SUP(SUPLEN)=SHIP(10+1) SUPLEN=SUPLEN+1 190 CONTINUE I=I+1 SUPLEN=SUPLEN-1 GOTO 100 C 14 SUP(SUPLEN)=SHIP(AD(I,4)*16+AD(I+1,4)+1) I=I+1 GOTO 100 C 15 SUP(SUPLEN)=AD(I+1,4)*16+AD(I+2,4) I=I+2 GOTO 100 END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNFLD(FIELD,FORMAT,NUMBER) IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FIELD,FORMAT DIMENSION FIELD(*),FORMAT(*) CHARACTER FLD*1 FLD(I,J)=FIELD(I)(J:J) WRITE(*,FORMAT)((FLD(I,MOD(J+INDEX(FIELD(I)(1:3)//' ',' ')-1,3)+1) +,I=1,NUMBER),J=0,2) WRITE(*,FORMAT)('-',I=1,NUMBER) END C-----------------------------------------------------------------------3456789 SUBROUTINE PRNRPT(FTRUE,FMISS,FUNITS,FORMAT,NUMBER) IMPLICIT INTEGER(A-E,G-Z) CHARACTER*8 FORMAT DIMENSION FTRUE(*),FUNITS(*),FORMAT(*) COMMON /ATT/AL(15),AD(255,15) +,SUP(255),SUPLEN,ERRNUM(51),ERRLEN(51),ERR(15,51),NERR CHARACTER*8 ATRUE(104) C DO 190 I=1,NUMBER IF(FTRUE(I).EQ.FMISS)THEN ATRUE(I)=' ' ELSE IF(FORMAT(I)(2:2).EQ.' ')THEN ATRUE(I)(1:1)=CHAR(NINT(FTRUE(I))) ELSE WRITE(ATRUE(I),'(I'//FORMAT(I)(3:3)//')') + NINT(FTRUE(I)/FUNITS(I)) ENDIF 190 CONTINUE C WRITE(*,FORMAT)(ATRUE(I),I=1,NUMBER) END c Thu Jun 24 10:36:29 MDT 1993 c-----------------------------------------------------------------------3456789 subroutine rptin(kunit,kbuf,kloc,kwds,jj,klmax,jeof) c read rptin format files on a 32-bit word machine dimension kbuf(2,1006),kloc(klmax) c if(kbuf(1,1)+1.ge.kbuf(1,3))then if(kbuf(1,1).eq.0)kbuf(1,4)=-kunit kbuf(1,1)=1 kbuf(1,3)=length(kbuf(1,4),kbuf(1,7),kbuf(2,3)) jeof=kbuf(2,3) if(jeof.ne.0)return kbuf(1,2)=kbuf(1,2)+1 if(kbuf(1,3).ne.kbuf(2,7))stop 'rptin: word count' kbuf(2,2)=kbuf(2,2)+kbuf(1,3) endif c kwds=0 call gbyte(kbuf(1,6+kbuf(1,1)+1),m,0,12) do 190 j=1,m kbuf(1,1)=kbuf(1,1)+1 if(kwds+2.gt.klmax)stop 'rptin: klmax too small' kloc(kwds+1)=kbuf(1,6+kbuf(1,1)) kloc(kwds+2)=kbuf(2,6+kbuf(1,1)) kwds=kwds+2 190 continue kbuf(2,1)=kbuf(2,1)+1 end c-----------------------------------------------------------------------3456789 function length(iun,ibuf,ieof) c read Cray COS blocked files on a 32-bit word machine c and return length in Cray words dimension iun(6),ibuf(2,1000) c iun(1) = Fortran unit= (initialize to -unit) c iun(2) = Fortran rec= c iun(3) = pointer to Cray 64-bit word dimension iblk(2,512) logical named character name*512 c if(iun(1).lt.0)then iun(1)=-iun(1) iun(2)=1 iun(3)=1 inquire(unit=iun(1),named=named,name=name) if(named)then close(iun(1)) open(iun(1),form='unformatted',access='direct',recl=2*512*4 + ,file=name) else open(iun(1),form='unformatted',access='direct',recl=2*512*4) endif endif c length=0 read(iun(1),rec=iun(2))iblk 100 call gbyte(iblk(2,iun(3)),ifwi,23,9) do 190 j=1,ifwi length=length+1 iun(3)=iun(3)+1 ibuf(1,length)=iblk(1,iun(3)) ibuf(2,length)=iblk(2,iun(3)) 190 continue iun(3)=iun(3)+1 if(iun(3).gt.512)then iun(2)=iun(2)+1 iun(3)=1 read(iun(1),rec=iun(2))iblk endif call gbyte(iblk(1,iun(3)),im,0,4) if(im.eq.0)then call gbyte(iblk(1,iun(3)),ibn,31,24) if(mod(iun(2)-1,16777216).ne.ibn)stop 'length: block number' goto 100 else if(im.eq.8)then ieof=0 else if(im.eq.14)then ieof=1 else if(im.eq.15)then iun(3)=512 ieof=1 else stop 'length: type of control word' endif end c-----------------------------------------------------------------------3456789 subroutine date(yymmdd) character*8 yymmdd integer iarray(3) call idate(iarray) write(yymmdd,110)iarray(3)-1900,iarray(2),iarray(1) 110 format(2(i2.2,'/'),i2.2) end c-----------------------------------------------------------------------3456789 subroutine clock(hhmmss) character*8 hhmmss integer iarray(3) call itime(iarray) write(hhmmss,110)iarray(1),iarray(2),iarray(3) 110 format(2(i2.2,':'),i2.2) end SUBROUTINE GBYTE (IN,IOUT,ISKIP,NBYTE) CALL GBYTES (IN,IOUT,ISKIP,NBYTE,0,1) RETURN END SUBROUTINE SBYTE (IOUT,IN,ISKIP,NBYTE) CALL SBYTES (IOUT,IN,ISKIP,NBYTE,0,1) RETURN END SUBROUTINE GBYTES (IN,IOUT,ISKIP,NBYTE,NSKIP,N) C Get bytes - unpack bits: Extract arbitrary size values from a C packed bit string, right justifying each value in the unpacked C array. DIMENSION IN(*), IOUT(*) C IN = packed array input C IO = unpacked array output C ISKIP = initial number of bits to skip C NBYTE = number of bits to take C NSKIP = additional number of bits to skip on each iteration C N = number of iterations C************************************** MACHINE SPECIFIC CHANGES START HERE C Machine dependent information required: C LMWD = Number of bits in a word on this machine C MASKS = Set of word masks where the first element has only the C right most bit set to 1, the second has the two, ... C LEFTSH = Shift left bits in word M to the by N bits C RGHTSH = Shift right C OR = Logical OR (add) on this machine. C AND = Logical AND (multiply) on this machine C This is for Sun UNIX Fortran, DEC Alpha, and RS6000 PARAMETER (LMWD=32) DIMENSION MASKS(LMWD) SAVE MASKS DATA MASKS /'1'X,'3'X,'7'X,'F'X, '1F'X,'3F'X,'7F'X,'FF'X, +'1FF'X,'3FF'X,'7FF'X,'FFF'X, '1FFF'X,'3FFF'X,'7FFF'X,'FFFF'X, +'1FFFF'X, '3FFFF'X, '7FFFF'X, 'FFFFF'X, +'1FFFFF'X, '3FFFFF'X, '7FFFFF'X, 'FFFFFF'X, +'1FFFFFF'X, '3FFFFFF'X, '7FFFFFF'X, 'FFFFFFF'X, +'1FFFFFFF'X, '3FFFFFFF'X, '7FFFFFFF'X, 'FFFFFFFF'X/ C +'1FFFFFFFF'X, '3FFFFFFFF'X, '7FFFFFFFF'X, 'FFFFFFFFF'X, C +'1FFFFFFFFF'X, '3FFFFFFFFF'X, '7FFFFFFFFF'X, 'FFFFFFFFFF'X, C +'1FFFFFFFFFF'X, '3FFFFFFFFFF'X, '7FFFFFFFFFF'X, 'FFFFFFFFFFF'X, C +'1FFFFFFFFFFF'X,'3FFFFFFFFFFF'X,'7FFFFFFFFFFF'X,'FFFFFFFFFFFF'X, C +'1FFFFFFFFFFFF'X, '3FFFFFFFFFFFF'X, '7FFFFFFFFFFFF'X, C + 'FFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFF'X, '3FFFFFFFFFFFFF'X, '7FFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFFF'X, '3FFFFFFFFFFFFFF'X, '7FFFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFFF'X, C +'1FFFFFFFFFFFFFFF'X,'3FFFFFFFFFFFFFFF'X,'7FFFFFFFFFFFFFFF'X, C 'FFFFFFFFFFFFFFFF'X/ C IBM PC using Microsoft Fortran uses different syntax: C DATA MASKS/16#1,16#3,16#7,16#F,16#1F,16#3F,16#7F,16#FF, C + 16#1FF,16#3FF,16#7FF,16#FFF,16#1FFF,16#3FFF,16#7FFF,16#FFFF, C + 16#1FFFF,16#3FFFF,16#7FFFF,16#FFFFF,16#1FFFFF,16#3FFFFF, C + 16#7FFFFF,16#FFFFFF,16#1FFFFFF,16#3FFFFFF,16#7FFFFFF,16#FFFFFFF, C + 16#1FFFFFFF,16#3FFFFFFF,16#7FFFFFFF,16#FFFFFFFF/ INTEGER RGHTSH, OR, AND LEFTSH(M,N) = ISHFT(M,N) RGHTSH(M,N) = ISHFT(M,-N) C OR(M,N) = M.OR.N C AND(M,N) = M.AND.N C************************************** MACHINE SPECIFIC CHANGES END HERE C History: written by Robert C. Gammill, jul 1972. C NBYTE must be less than or equal to LMWD ICON = LMWD-NBYTE IF (ICON.LT.0) RETURN MASK = MASKS (NBYTE) C INDEX = number of words into IN before the next "byte" appears C II = number of bits the "byte" is from the left side of the word C ISTEP = number of bits from the start of one "byte" to the next C IWORDS = number of words to skip from one "byte" to the next C IBITS = number of bits to skip after skipping IWORDS C MOVER = number of bits to the right, a byte must be moved to be C right adjusted INDEX = ISKIP/LMWD II = MOD (ISKIP,LMWD) ISTEP = NBYTE+NSKIP IWORDS= ISTEP/LMWD IBITS = MOD (ISTEP,LMWD) DO 6 I=1,N MOVER = ICON-II IF (MOVER) 2,3,4 C The "byte" is split across a word break. 2 MOVEL = -MOVER MOVER = LMWD-MOVEL NP1 = LEFTSH (IN(INDEX+1),MOVEL) NP2 = RGHTSH (IN(INDEX+2),MOVER) IOUT(I) = AND (OR (NP1,NP2) , MASK) GO TO 5 C The "byte" is already right adjusted. 3 IOUT(I) = AND (IN (INDEX+1) , MASK) GO TO 5 C Right adjust the "byte". 4 IOUT(I) = AND (RGHTSH (IN (INDEX+1),MOVER) , MASK) 5 II = II+IBITS INDEX = INDEX+IWORDS IF (II .LT. LMWD) GO TO 6 II = II-LMWD INDEX = INDEX+1 6 CONTINUE RETURN END SUBROUTINE SBYTES (IOUT,IN,ISKIP,NBYTE,NSKIP,N) C Store bytes - pack bits: Put arbitrary size values into a C packed bit string, taking the low order bits from each value C in the unpacked array. DIMENSION IN(*), IOUT(*) C IOUT = packed array output C IN = unpacked array input C ISKIP = initial number of bits to skip C NBYTE = number of bits to pack C NSKIP = additional number of bits to skip on each iteration C N = number of iterations C************************************** MACHINE SPECIFIC CHANGES START HERE C Machine dependent information required: C LMWD = Number of bits in a word on this machine C MASKS = Set of word masks where the first element has only the C right most bit set to 1, the second has the two, ... C LEFTSH = Shift left bits in word M to the by N bits C RGHTSH = Shift right C OR = Logical OR (add) on this machine C AND = Logical AND (multiply) on this machine C NOT = Logical NOT (negation) on this machine C This is for Sun UNIX Fortran PARAMETER (LMWD=32) DIMENSION MASKS(LMWD) SAVE MASKS DATA MASKS /'1'X,'3'X,'7'X,'F'X, '1F'X,'3F'X,'7F'X,'FF'X, +'1FF'X,'3FF'X,'7FF'X,'FFF'X, '1FFF'X,'3FFF'X,'7FFF'X,'FFFF'X, +'1FFFF'X, '3FFFF'X, '7FFFF'X, 'FFFFF'X, +'1FFFFF'X, '3FFFFF'X, '7FFFFF'X, 'FFFFFF'X, +'1FFFFFF'X, '3FFFFFF'X, '7FFFFFF'X, 'FFFFFFF'X, +'1FFFFFFF'X, '3FFFFFFF'X, '7FFFFFFF'X, 'FFFFFFFF'X/ INTEGER RGHTSH, OR, AND LEFTSH(M,N) = ISHFT(M,N) RGHTSH(M,N) = ISHFT(M,-N) C OR(M,N) = M.OR.N C AND(M,N) = M.AND.N C NOT(M) = .NOT.M C*********************************************************************** C NBYTE must be less than or equal to LMWD ICON = LMWD-NBYTE IF (ICON .LT. 0) RETURN MASK = MASKS(NBYTE) C INDEX = number of words into IOUT the next "byte" is to be stored C II = number of bits in from the left side of the word to store it C ISTEP = number of bits from the start of one "byte" to the next C IWORDS = number of words to skip from one "byte" to the next C IBITS = number of bits to skip after skipping IWORDS C MOVER = number of bits to the right, a byte must be moved to be C right adjusted INDEX = ISKIP/LMWD II = MOD(ISKIP,LMWD) ISTEP = NBYTE+NSKIP IWORDS = ISTEP/LMWD IBITS = MOD(ISTEP,LMWD) DO 6 I=1,N J = AND (MASK,IN(I)) MOVEL = ICON-II IF (MOVEL) 2,3,4 C The "byte" is to be split across a word break 2 MSK = MASKS (NBYTE+MOVEL) IOUT(INDEX+1) = OR (AND(NOT(MSK),IOUT(INDEX+1)),RGHTSH(J,-MOVEL)) ITEMP = AND (MASKS(LMWD+MOVEL),IOUT(INDEX+2)) IOUT(INDEX+2) = OR(ITEMP,LEFTSH(J,LMWD+MOVEL)) GO TO 5 C The "byte" is to be stored right-adjusted 3 IOUT(INDEX+1) = OR ( AND (NOT(MASK),IOUT(INDEX+1)) , J) GO TO 5 C The "byte" is to be stored in middle of word, so shift left. 4 MSK = LEFTSH(MASK,MOVEL) IOUT(INDEX+1) = OR(AND(NOT(MSK),IOUT(INDEX+1)),LEFTSH(J,MOVEL)) 5 II = II+IBITS INDEX = INDEX+IWORDS IF (II .LT. LMWD) GO TO 6 II = II-LMWD INDEX = INDEX+1 6 CONTINUE RETURN END