w3fi62.f

Go to the documentation of this file.

C> @file
C> @brief Build 80-char on295 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> 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
C> for ASCII character set computers
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
C> WMO header + body of message in bytes
C> (not including queue descriptor)
C> @param[out] LOC Location to receive queue descriptor
C> @param[out] IERR Error return
C>
C> @note If total size is entered (kary(7)) then kary(5) and
C> kary(6) will be calculated.
C> If kary(5) and kary(6) are provided then kary(7) will
C> be ignored.
C>
C> @note Equivalence array loc to integer array so it starts on
C> a word boundary for sbyte subroutine.
C>
C> Error returns:
C> - IERR = 1 Total byte count and/or 80 byte increment
C> count is missing. One or the other is
C> required to complete the queue descriptor.
C> - IERR = 2 Total size too small
C>
C> @author Bill Cavanaugh @date 1991-06-21
      SUBROUTINE w3fi62 (LOC,TTAAII,KARY,IERR)
C
      INTEGER       IHOLD(2)
      INTEGER       KARY(7),II,IERR
C
      LOGICAL       IBM370
C
      CHARACTER*6   TTAAII,AHOLD
      CHARACTER*80  LOC
      CHARACTER*1   BLANK
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                  DAY OF MONTH AND UTC(Z) HRS
C                                   DAY
C
C     NOTE: W3AI15 WILL MAKE ASCII OR EBCDIC CHARACTERS
C           DEPENDING ON WHAT TYPE OF COMPUTER IT IS ON
C
      CALL w3ai15 (kary(1),ii,1,lw,'-')
      CALL sbyte (loc,ii,inofst,16)
      inofst    = inofst + 16
C                                   HOURS
      CALL w3ai15 (kary(2),ii,1,lw,'-')
      CALL sbyte (loc,ii,inofst,16)
C
C     IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
C
      IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
      inofst    = inofst + 16
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