w3fi32.f

Go to the documentation of this file.

C> @file
C> @brief Pack id's into office note 84 format.
C> @author Alan Nierow @date 1986-02-07
 
C> Converts an array of the 27 data field identifiers into
C> an array of the first 8 identification words of the format de-
C> scribed in NMC office note 84 (89-06-15, page-35). On a cray
C> they will fit into four 64 bit integer words.
C>
C> Program history log:
C> - Alan Nierow 1986-02-07
C> - Ralph Jones 1989-10-24 Convert to cray cft77 fortran.
C> - Ralph Jones 1991-03-19 Changes for big records.
C> - Boi Vuong 1998-03-10 Remove the cdir$ integer=64 directive.
C> - Stephen Gilbert 1999-03-15 Specified 8-byte integer array explicitly.
C>
C> @param[in] LARRAY Integer array containing 27 data field
C> identifiers (see o.n. 84)
C> @param[out] KIDNT Integer array of 6 words, 12 office note 84 32 bit
C> words, first 4 words are made by w3fi32(), if you are
C> using packer w3ai00(), it will compute word 5 and 6.
C> (office note 84 words 9,10, 11 and 12). If J the
C> word count in word 27 of LARRAY is greater than
C> 32743 then bits 15-0 of the 4th ID word are set to
C> zero, J is stored in bits 31-0 of the 6th ID word.
C> ID word 5 is set zero, bit 63-32 of the 6th ID
C> word are set zero.
C> @note bis are number left to right on the cray as 63-0.
C>
C> @note Exit states printed messages:
C> If any number n in (LARRAY(i),i=1,27) is erroneously large:
C> 'value in LARRAY(i)=n is too large to pack'
C> if any number n in (LARRAY(i),i=1,27) is erroneously negative:
C> 'value in LARRAY(i)=n should not be negative'
C> in either of the above situations, that portion of the packed
C> word corresponding to LARRAY(i) will be set to binary ones.
C>
C> @author Alan Nierow @date 1986-02-07
      SUBROUTINE w3fi32(LARRAY,KIDNT)
C
       INTEGER(8)        LARRAY(27)
       INTEGER(8)        ITABLE(27)
       INTEGER(8)        KIDNT(*)
       INTEGER(8)        KX,MASK,MASK16,ISC,ITEMP8
C
       SAVE
C
       DATA  itable/z'0000000000340C01',z'0000000000280C01',
     &              z'0000000000200801',z'00000000001C0401',
     &              z'0000000001081401',z'0000000001000801',
     &              z'00000000003C0402',z'0000000000340802',
     &              z'0000000000280C02',z'0000000000200802',
     &              z'00000000001C0402',z'0000000001081402',
     &              z'0000000001000802',z'0000000000380803',
     &              z'0000000000300803',z'0000000000280803',
     &              z'0000000000200803',z'00000000001C0403',
     &              z'0000000000100C03',z'0000000000001003',
     &              z'0000000000380804',z'0000000000300804',
     &              z'0000000000280804',z'0000000000200804',
     &              z'0000000000180804',z'0000000000100804',
     &              z'0000000000001004'/
       DATA  kx    /z'00000000FFFFFFFF'/
       DATA  mask  /z'00000000000000FF'/
       DATA  mask16/z'FFFFFFFFFFFF0000'/
C
C     MAKE KIDNT = 0
C
      DO 10 i = 1,4
        kidnt(i) = 0
 10   CONTINUE
C
      isign = 0
C
      DO 90 i = 1,27
        isc = itable(i)
        i1  = iand(isc,mask)
        i2  = iand(ishft(isc,-8_8), mask)
        i3  = iand(ishft(isc,-16_8),mask)
        i4  = iand(ishft(isc,-24_8),mask)
C
C     SIGN TEST
C
       iv = larray(i)
       IF (iv.GE.0) GO TO 50
       IF (i4.NE.0) GO TO 30
       WRITE (6,20) i, iv
 20    FORMAT(/,1x,' W3FI32 - VALUE IN LARRAY(',i2,') =',i11,
     & ' SHOULD NOT BE NEGATIVE',/)
       GO TO 70
C
 30   CONTINUE
        iv    = iabs(iv)
        msign = 1
        isign = msign
        k     = i2 / 4
C
      DO 40 m = 1,k
        isign = ishft(isign,4)
 40   CONTINUE
C
        isign = ishft(isign,-1)
        iv    = ior(iv,isign)
C
 50   CONTINUE
C
C     MAG TEST
C
        IF (ishft(iv,-i2).EQ.0) GO TO 80
        IF (larray(27).GT.32743) GO TO 70
        print 60, i , iv
 60     FORMAT(/,1x,' W3FI32 - VALUE IN LARRAY(',i2,') =',i11,
     &  ' IS TOO LARGE TO PACK',/)
C
 70   CONTINUE
        iv = kx
        ia = 32 - i2
        iv = ishft(iv,-ia)
C
C     SHIFT
C
 80   CONTINUE
        itemp=ishft(iv,i3)
        itemp8=itemp
        kidnt(i1) = ior(kidnt(i1),itemp8)
C
 90   CONTINUE
C
C     TEST FOR BIG RECORDS, STORE J THE WORD COUNT IN THE 6TH
C     ID WORD IF GREATER THAN 32743.
C
      IF (larray(27).EQ.0) THEN
        print *,' W3FI32 - ERROR, WORD COUNT J = 0'
      ELSE IF (larray(27).GT.32743) THEN
        kidnt(4) = iand(kidnt(4),mask16)
        kidnt(5) = 0
        kidnt(6) = larray(27)
      END IF
C
      RETURN
      END