program rsunqq22
c
c
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=3000,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)
      character flnm*64
      EQUIVALENCE (FTRUE(7),FTRUE2)
C
      DATA LEVEL/4H.01A/,BUF/DIM BUF*0/
C
c     open data file - direct access mode     
c       -- each direct access record is equivalent to MSTG blocksize

      write(*,*)'Enter File Name for Read '
      read(*,'(a)')flnm
      open(unit=tape,file=flnm,form='unformatted',
     *     access='direct',recl=7200)
c
      write(*,1)flnm
1     format('1  * beginning output  from  'a)
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
      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 - 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) - 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
 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
c
c      checksum verification
c
       IF(MOD(CK,2**BITS(INDEXCK)-1).EQ.UN(INDEXCK))RETURN
C
C-----ERROR
       PRINT *,' SUBROUTINE GETRPT  --  CHECKSUM ERROR, TAPE = ',TAPE
     +,', REPORT = ',BUF(2)
       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)
      DIMENSION BUF(DIM BUF),RCD(DIM RCD)
      data irdata/1/
C
      IF(BUF(1)+BPR.LE.BUF(5))GOTO 200
C-----BUFFER IN
c
c     read from UNIX data file 

10    read(tape,rec=irdata)(buf(i),i=7,1806)
      call swap4(buf(7),buf(7),7200)
      irdata=irdata + 1
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 GBYTES
     +(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 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 THIS PROGRAM WRITTEN BY.....                                                  
C             DR. ROBERT C. GAMMILL, CONSULTANT                                 
C             NATIONAL CENTER FOR ATMOSPHERIC RESEARCH                          
C             MAY 1972                                                          
C THIS IS THE FORTRAN VERSION OF GBYTES.                                        
      COMMON/MACHIN/NBITSW,NBITSC,MASK0,MASKS(32)                               
      DIMENSION IN(1),IOUT(1)                                                   
C  THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE             
C  DEPENDENT INFORMATION                                                        
C***********************************************************************        
C THIS SPECIFICATION IS FOR IBM PC USING MICROSOFT FORTRAN
      INTEGER RGHTSH,OR,AND                                                     
      LEFTSH(M,N)=ISHFT(M,N)                                                      
      RGHTSH(M,N)=ISHFT(M,-N)                                                      
      OR(M,N)=IOR(M,N)                                                            
      AND(M,N)=IAND(M,N)
      DATA NBITSW/32/
      DATA MASK0/16#0/
      DATA MASKS/16#1,16#3,16#7,16#F,16#1F,16#3F,16#7F,16#FF,
     2 16#1FF,16#3FF,16#7FF,16#FFF,16#1FFF,16#3FFF,16#7FFF,16#FFFF,
     3 16#1FFFF,16#3FFFF,16#7FFFF,16#FFFFF,16#1FFFFF,16#3FFFFF,
     4 16#7FFFFF,16#FFFFFF,16#1FFFFFF,16#3FFFFFF,16#7FFFFFF,16#FFFFFFF,
     5 16#1FFFFFFF,16#3FFFFFFF,16#7FFFFFFF,16#FFFFFFFF/
C***********************************************************************        
C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW                                    
      ICON=NBITSW-NBYTE                                                         
      IF(ICON.LT.0) RETURN                                                      
      MASK=MASKS(NBYTE)                                                         
C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IN' THE NEXT BYTE APPEARS.         
      INDEX=ISKIP/NBITSW                                                        
C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD.            
      II=MOD(ISKIP,NBITSW)                                                      
C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT.         
      ISTEP=NBYTE+NSKIP                                                         
C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT.                
      IWORDS=ISTEP/NBITSW                                                       
C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS.                      
      IBITS=MOD(ISTEP,NBITSW)                                                   
      DO 6 I=1,N                                                                
C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER            
C    TO BE RIGHT ADJUSTED.                                                      
      MOVER=ICON-II                                                             
      IF(MOVER) 2,3,4                                                           
C                                                                               
C THE BYTE IS SPLIT ACROSS A WORD BREAK.                                        
    2 MOVEL=-MOVER                                                              
      MOVER=NBITSW-MOVEL
C EXPAND STATEMENT SINCE MSFORTRAN SEEMS TO FAIL OTHERWISE
      NP1=LEFTSH(IN(INDEX+1),MOVEL)
      NP2=RGHTSH(IN(INDEX+2),MOVER)
C      NP3=OR(LEFTSH(IN(INDEX+1),MOVEL),RGHTSH(IN(INDEX+2),MOVER))
      IOUT(I)=AND(OR(NP1,NP2),MASK)
C      IOUT(I)=AND(OR(LEFTSH(IN(INDEX+1),MOVEL),RGHTSH(IN(INDEX+2),MOVER)        
C     1 ),MASK)                                                                  
      GO TO 5                                                                   
C                                                                               
C THE BYTE IS ALREADY RIGHT ADJUSTED.                                           
    3 IOUT(I)=AND(IN(INDEX+1),MASK)                                             
      GO TO 5                                                                   
C                                                                               
C RIGHT ADJUST THE BYTE.                                                        
    4 IOUT(I)=AND(RGHTSH(IN(INDEX+1),MOVER),MASK)                               
C                                                                               
C INCREMENT II AND INDEX.                                                       
    5 II=II+IBITS                                                               
      INDEX=INDEX+IWORDS                                                        
      IF(II.LT.NBITSW) GO TO 6                                                  
      II=II-NBITSW                                                              
      INDEX=INDEX+1                                                             
    6 CONTINUE                                                                  
      RETURN                                                                    
      END                                                                       
      SUBROUTINE SBYTES(IOUT,IN,ISKIP,NBYTE,NSKIP,N)                            
C THIS PROGRAM WRITTEN BY.....                                                  
C             DR. ROBERT C. GAMMILL, CONSULTANT                                 
C             NATIONAL CENTER FOR ATMOSPHERIC RESEARCH                          
C             JULY 1972                                                         
C THIS IS THE FORTRAN VERSIONS OF SBYTES.                                       
      COMMON/MACHIN/NBITSW,NBITSC,MASK0,MASKS(32)                               
      DIMENSION IN(1),IOUT(1)                                                   
C                                                                               
C  THE STATEMENTS BETWEEN ASTERISK LINES GIVE ALL NECESSARY MACHINE             
C  DEPENDENT INFORMATION                                                        
C***********************************************************************        
C THIS SPECIFICATION IS SUITABLE FOR CDC 6000 SERIES COMPUTERS.                 
      INTEGER RGHTSH,OR,AND                                                     
      OR(M,N)=IOR(M,N)                                                            
      AND(M,N)=IAND(M,N)                                                         
C                            
      LEFTSH(M,N)=ISHFT(M,N)                                                      
      RGHTSH(M,N)=ISHFT(M,-N)                                                      
C***********************************************************************        
C                                                                               
C NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW                                    
      ICON=NBITSW-NBYTE                                                         
      IF(ICON.LT.0) RETURN                                                      
      MASK=MASKS(NBYTE)                                                         
C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED.           
      INDEX=ISKIP/NBITSW                                                        
C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT.         
      II=MOD(ISKIP,NBITSW)                                                      
C ISTEP IS THE DISTANCE IN BITS FROM ONE BYTE POSITION TO THE NEXT.             
      ISTEP=NBYTE+NSKIP                                                         
C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT.                
      IWORDS=ISTEP/NBITSW                                                       
C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS.                      
      IBITS=MOD(ISTEP,NBITSW)                                                   
      DO 6 I=1,N                                                                
      J=AND(MASK,IN(I))                                                         
      MOVEL=ICON-II                                                             
      IF(MOVEL) 2,3,4                                                           
C                                                                               
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(NBITSW+MOVEL),IOUT(INDEX+2))                              
      IOUT(INDEX+2)=OR(ITEMP,LEFTSH(J,NBITSW+MOVEL))                            
      GO TO 5                                                                   
C                                                                               
C BYTE IS TO BE STORED RIGHT-ADJUSTED.                                          
3     IOUT(INDEX+1)=OR(AND(NOT(MASK),IOUT(INDEX+1)),J)                          
      GO TO 5                                                                   
C                                                                               
C BYTE IS TO BE STORED IN MIDDLE OF WORD.  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.NBITSW) GO TO 6                                                  
      II=II-NBITSW                                                              
      INDEX=INDEX+1                                                             
6     CONTINUE                                                                  
      RETURN                                                                    
      END                                                                       
      SUBROUTINE SWAP4(IN,IO,NN)
      LOGICAL*1 IN(1),IO(1),IH
      DO 10 I=1,NN,4
      IH=IN(I)
      IO(I)=IN(I+3)
      IO(I+3)=IH
      IH=IN(I+1)
      IO(I+1)=IN(I+2)
      IO(I+2)=IH
  10  CONTINUE
      RETURN
      END