w3fi92.f

Go to the documentation of this file.

C> @file
C> @brief Build 80-char on 295 grib queue descriptor.
C> @author Bill Cavanaugh @date 1991-06-21
 
C> Build 80 character queue descriptor using information
C> supplied by user, placing the completed queue descriptor in the
C> location specified by the user. (based on office note 295).
C>
C> @note This is a modified version of w3fi62() which adds the 'KWBX'
C> parameter. This value will now be added to bytes 35-38 for all grib
C> products. Queue desciptors for non-grib products will continue to be
C> generated by w3fi62().
C>
C> Program history log:
C> - Bill Cavanaugh 1991-06-21
C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
C> exceed 20000 bytes
C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII
C> character set computers
C> - J. Smith 1995-10-16 Modified version of w3fi62() to add 'KWBX' to bytes
C> 35-38 of queue descriptor.
C> - Ralph Jones 1996-01-29 Preset ierr to zero.
C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
C>
C> @param[in] TTAAII First 6 characters of wmo header
C> @param[inout] KARY Integer array containing user information
C> - 1 = Day of month
C> - 2 = Hour of day
C> - 3 = Hour * 100 + minute
C> - 4 = Catalog number
C> - 5 = Number of 80 byte increments
C> - 6 = Number of bytes in last increment
C> - 7 = Total size of message WMO header + body of message in bytes (not
C> including queue descriptor)
C> @param[in] KWBX 4 characters, representing the fcst model that the bulletin
C> was derived from.
C> @param[out] LOC Location to receive queue descriptor.
C> @param[out] IERR Error return.
C>
C>
C> @note If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated.
C> If kary(5) and kary(6) are provided then kary(7) will be ignored.
C>
C> @note Equivalence array loc to integer array so it starts on a word
C> boundary for sbyte subroutine.
C>
C> Error returns:
C> - IERR = 1 Total byte count and/or 80 byte increment count is missing. One
C> or the other is required to complete the queue descriptor.
C> - IERR = 2 Total size too small
C>
C> @author Bill Cavanaugh @date 1991-06-21
      SUBROUTINE w3fi92 (LOC,TTAAII,KARY,KWBX,IERR)
C
      INTEGER       IHOLD(2)
      INTEGER       KARY(7),IERR
C
      LOGICAL       IBM370
C
      CHARACTER*6   TTAAII,AHOLD
      CHARACTER*80  LOC
      CHARACTER*1   BLANK
      CHARACTER*4   KWBX
C
      equivalence(ahold,ihold)
C
      SAVE
C
C     BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
C     COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
C     BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
C     ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
C     SETS TO FIND IBM370 TYPE COMPUTER.
C
      DATA  blank /' '/
C  ----------------------------------------------------------------
C
C     TEST FOR CRAY 64 BIT COMPUTER, LW = 8
C
      CALL w3fi01(lw)
C
C     TEST FOR EBCDIC CHARACTER SET
C
      ibm370 = .false.
      IF (mova2i(blank).EQ.64) THEN
        ibm370 = .true.
      END IF
C
      inofst    = 0
C BYTES 1-16                   'QUEUE DESCRIPTOR'
      CALL sbyte  (loc,-656095772,inofst,32)
      inofst    = inofst + 32
      CALL sbyte  (loc,-985611067,inofst,32)
      inofst    = inofst + 32
      CALL sbyte  (loc,-490481207,inofst,32)
      inofst    = inofst + 32
      CALL sbyte  (loc,-672934183,inofst,32)
      inofst    = inofst + 32
C BYTES 17-20                  INTEGER ZEROES
      CALL sbyte (loc,0,inofst,32)
      inofst    = inofst + 32
C                              IF TOTAL COUNT IS INCLUDED
C                              THEN WILL DETERMINE THE NUMBER OF
C                              80 BYTE INCREMENTS AND WILL DETERMINE
C                              THE NUMBER OF BYTES IN THE LAST INCREMENT
      ierr = 0
      IF (kary(7).NE.0) THEN
          IF (kary(7).LT.35) THEN
C             PRINT *,'LESS THAN MINIMUM SIZE'
              ierr   = 2
              RETURN
          END IF
          kary(5)    = kary(7) / 80
          kary(6)    = mod(kary(7),80)
          IF (kary(6).EQ.0) THEN
              kary(6)    = 80
          ELSE
              kary(5)    = kary(5) + 1
          END IF
      ELSE
          IF (kary(5).LT.1) THEN
              ierr     = 1
              RETURN
          END IF
      END IF
C BYTE  21-22                  NR OF 80 BYTE INCREMENTS
      CALL sbyte (loc,kary(5),inofst,16)
      inofst    = inofst + 16
C BYTE  23                     NR OF BYTES IN LAST INCREMENT
      CALL sbyte (loc,kary(6),inofst,8)
      inofst    = inofst + 8
C BYTES 24-28                  INTEGER ZEROES
      CALL sbyte (loc,0,inofst,32)
      inofst    = inofst + 32
      CALL sbyte (loc,0,inofst,8)
      inofst    = inofst + 8
C BYTES 29-34                  6 CHAR BULLETIN NAME TTAAII
      loc(29:34) = ttaaii(1:6)
C
C     IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
C
      IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
C
      inofst    = inofst + 48
C BYTES 35-38                  KWBX
C
      loc(35:38) = kwbx(1:4)
C
C     IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
C
      IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
      inofst    = inofst + 32
C BYTES 39-40                  HR/MIN TIME OF BULLETIN CREATION
C                                    TWO BYTES AS 4 BIT BCD
      ka        = kary(3) / 1000
      kb        = mod(kary(3),1000) / 100
      kc        = mod(kary(3),100) / 10
      kd        = mod(kary(3),10)
      CALL sbyte (loc,ka,inofst,4)
      inofst    = inofst + 4
      CALL sbyte (loc,kb,inofst,4)
      inofst    = inofst + 4
      CALL sbyte (loc,kc,inofst,4)
      inofst    = inofst + 4
      CALL sbyte (loc,kd,inofst,4)
      inofst    = inofst + 4
C BYTES 41-45                  CATALOG NUMBER ELSE (SET TO 55555)
      IF (kary(4).GE.1.AND.kary(4).LE.99999) THEN
          CALL w3ai15 (kary(4),ihold,1,8,'-')
          IF (lw.EQ.4) THEN
            CALL sbyte (loc,ihold(1),inofst,8)
            inofst    = inofst + 8
            CALL sbyte (loc,ihold(2),inofst,32)
            inofst    = inofst + 32
C
C         ON CRAY 64 BIT COMPUTER
C
          ELSE
            CALL sbyte (loc,ihold,inofst,40)
            inofst    = inofst + 40
          END IF
C
C   IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
C
          IF (.NOT.ibm370) CALL w3ai39(loc(41:41),5)
      ELSE
          CALL sbyte (loc,-168430091,inofst,32)
          inofst    = inofst + 32
          CALL sbyte (loc,245,inofst,8)
          inofst    = inofst + 8
      END IF
C BYTES 46-80                  INTEGER ZEROES
      DO 4676 i = 1, 8
          CALL sbyte (loc,0,inofst,32)
          inofst    = inofst + 32
 4676 CONTINUE
          CALL sbyte (loc,0,inofst,24)
      RETURN
      END