NCEPLIBS-w3emc  2.11.0
w3fi92.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Build 80-char on 295 grib queue descriptor.
3 C> @author Bill Cavanaugh @date 1991-06-21
4 
5 C> Build 80 character queue descriptor using information
6 C> supplied by user, placing the completed queue descriptor in the
7 C> location specified by the user. (based on office note 295).
8 C>
9 C> @note This is a modified version of w3fi62() which adds the 'KWBX'
10 C> parameter. This value will now be added to bytes 35-38 for all grib
11 C> products. Queue desciptors for non-grib products will continue to be
12 C> generated by w3fi62().
13 C>
14 C> Program history log:
15 C> - Bill Cavanaugh 1991-06-21
16 C> - Bill Cavanaugh 1994-03-08 Modified to allow for bulletin sizes that
17 C> exceed 20000 bytes
18 C> - Ralph Jones 1994-04-28 Change for cray 64 bit word size and for ASCII
19 C> character set computers
20 C> - J. Smith 1995-10-16 Modified version of w3fi62() to add 'KWBX' to bytes
21 C> 35-38 of queue descriptor.
22 C> - Ralph Jones 1996-01-29 Preset ierr to zero.
23 C> - Boi Vuong 2002-10-15 Replaced function ichar with mova2i.
24 C>
25 C> @param[in] TTAAII First 6 characters of wmo header
26 C> @param[inout] KARY Integer array containing user information
27 C> - 1 = Day of month
28 C> - 2 = Hour of day
29 C> - 3 = Hour * 100 + minute
30 C> - 4 = Catalog number
31 C> - 5 = Number of 80 byte increments
32 C> - 6 = Number of bytes in last increment
33 C> - 7 = Total size of message WMO header + body of message in bytes (not
34 C> including queue descriptor)
35 C> @param[in] KWBX 4 characters, representing the fcst model that the bulletin
36 C> was derived from.
37 C> @param[out] LOC Location to receive queue descriptor.
38 C> @param[out] IERR Error return.
39 C>
40 C>
41 C> @note If total size is entered (kary(7)) then kary(5) and kary(6) will be calculated.
42 C> If kary(5) and kary(6) are provided then kary(7) will be ignored.
43 C>
44 C> @note Equivalence array loc to integer array so it starts on a word
45 C> boundary for sbyte subroutine.
46 C>
47 C> Error returns:
48 C> - IERR = 1 Total byte count and/or 80 byte increment count is missing. One
49 C> or the other is required to complete the queue descriptor.
50 C> - IERR = 2 Total size too small
51 C>
52 C> @author Bill Cavanaugh @date 1991-06-21
53  SUBROUTINE w3fi92 (LOC,TTAAII,KARY,KWBX,IERR)
54 C
55  INTEGER IHOLD(2)
56  INTEGER KARY(7),IERR
57 C
58  LOGICAL IBM370
59 C
60  CHARACTER*6 TTAAII,AHOLD
61  CHARACTER*80 LOC
62  CHARACTER*1 BLANK
63  CHARACTER*4 KWBX
64 C
65  equivalence(ahold,ihold)
66 C
67  SAVE
68 C
69 C BLANK WILL BE 40 HEX OR DECIMAL 64 ON AN IBM370 TYPE
70 C COMPUTER, THIS IS THE EBCDIC CHARACTER SET.
71 C BLANK WILL BE 20 HEX OR DECIMAL 32 ON A COMPUTER WITH THE
72 C ASCII CHARACTER SET. THIS WILL BE USED TO TEST FOR CHARACTER
73 C SETS TO FIND IBM370 TYPE COMPUTER.
74 C
75  DATA blank /' '/
76 C ----------------------------------------------------------------
77 C
78 C TEST FOR CRAY 64 BIT COMPUTER, LW = 8
79 C
80  CALL w3fi01(lw)
81 C
82 C TEST FOR EBCDIC CHARACTER SET
83 C
84  ibm370 = .false.
85  IF (mova2i(blank).EQ.64) THEN
86  ibm370 = .true.
87  END IF
88 C
89  inofst = 0
90 C BYTES 1-16 'QUEUE DESCRIPTOR'
91  CALL sbyte (loc,-656095772,inofst,32)
92  inofst = inofst + 32
93  CALL sbyte (loc,-985611067,inofst,32)
94  inofst = inofst + 32
95  CALL sbyte (loc,-490481207,inofst,32)
96  inofst = inofst + 32
97  CALL sbyte (loc,-672934183,inofst,32)
98  inofst = inofst + 32
99 C BYTES 17-20 INTEGER ZEROES
100  CALL sbyte (loc,0,inofst,32)
101  inofst = inofst + 32
102 C IF TOTAL COUNT IS INCLUDED
103 C THEN WILL DETERMINE THE NUMBER OF
104 C 80 BYTE INCREMENTS AND WILL DETERMINE
105 C THE NUMBER OF BYTES IN THE LAST INCREMENT
106  ierr = 0
107  IF (kary(7).NE.0) THEN
108  IF (kary(7).LT.35) THEN
109 C PRINT *,'LESS THAN MINIMUM SIZE'
110  ierr = 2
111  RETURN
112  END IF
113  kary(5) = kary(7) / 80
114  kary(6) = mod(kary(7),80)
115  IF (kary(6).EQ.0) THEN
116  kary(6) = 80
117  ELSE
118  kary(5) = kary(5) + 1
119  END IF
120  ELSE
121  IF (kary(5).LT.1) THEN
122  ierr = 1
123  RETURN
124  END IF
125  END IF
126 C BYTE 21-22 NR OF 80 BYTE INCREMENTS
127  CALL sbyte (loc,kary(5),inofst,16)
128  inofst = inofst + 16
129 C BYTE 23 NR OF BYTES IN LAST INCREMENT
130  CALL sbyte (loc,kary(6),inofst,8)
131  inofst = inofst + 8
132 C BYTES 24-28 INTEGER ZEROES
133  CALL sbyte (loc,0,inofst,32)
134  inofst = inofst + 32
135  CALL sbyte (loc,0,inofst,8)
136  inofst = inofst + 8
137 C BYTES 29-34 6 CHAR BULLETIN NAME TTAAII
138  loc(29:34) = ttaaii(1:6)
139 C
140 C IF ON ASCII COMPUTER, CONVERT LAST 6 CHARACTERS TO EBCDIC
141 C
142  IF (.NOT.ibm370) CALL w3ai39(loc(29:29),6)
143 C
144  inofst = inofst + 48
145 C BYTES 35-38 KWBX
146 C
147  loc(35:38) = kwbx(1:4)
148 C
149 C IF ON ASCII COMPUTER, CONVERT LAST 4 CHARACTERS TO EBCDIC
150 C
151  IF (.NOT.ibm370) CALL w3ai39(loc(35:35),4)
152  inofst = inofst + 32
153 C BYTES 39-40 HR/MIN TIME OF BULLETIN CREATION
154 C TWO BYTES AS 4 BIT BCD
155  ka = kary(3) / 1000
156  kb = mod(kary(3),1000) / 100
157  kc = mod(kary(3),100) / 10
158  kd = mod(kary(3),10)
159  CALL sbyte (loc,ka,inofst,4)
160  inofst = inofst + 4
161  CALL sbyte (loc,kb,inofst,4)
162  inofst = inofst + 4
163  CALL sbyte (loc,kc,inofst,4)
164  inofst = inofst + 4
165  CALL sbyte (loc,kd,inofst,4)
166  inofst = inofst + 4
167 C BYTES 41-45 CATALOG NUMBER ELSE (SET TO 55555)
168  IF (kary(4).GE.1.AND.kary(4).LE.99999) THEN
169  CALL w3ai15 (kary(4),ihold,1,8,'-')
170  IF (lw.EQ.4) THEN
171  CALL sbyte (loc,ihold(1),inofst,8)
172  inofst = inofst + 8
173  CALL sbyte (loc,ihold(2),inofst,32)
174  inofst = inofst + 32
175 C
176 C ON CRAY 64 BIT COMPUTER
177 C
178  ELSE
179  CALL sbyte (loc,ihold,inofst,40)
180  inofst = inofst + 40
181  END IF
182 C
183 C IF ON ASCII COMPUTER, CONVERT LAST 5 CHARACTERS TO EBCDIC
184 C
185  IF (.NOT.ibm370) CALL w3ai39(loc(41:41),5)
186  ELSE
187  CALL sbyte (loc,-168430091,inofst,32)
188  inofst = inofst + 32
189  CALL sbyte (loc,245,inofst,8)
190  inofst = inofst + 8
191  END IF
192 C BYTES 46-80 INTEGER ZEROES
193  DO 4676 i = 1, 8
194  CALL sbyte (loc,0,inofst,32)
195  inofst = inofst + 32
196  4676 CONTINUE
197  CALL sbyte (loc,0,inofst,24)
198  RETURN
199  END
mova2i
integer function mova2i(a)
This Function copies a bit string from a Character*1 variable to an integer variable.
Definition: mova2i.f:25
sbyte
subroutine sbyte(IOUT, IN, ISKIP, NBYTE)
Definition: sbyte.f:12
w3ai15
subroutine w3ai15(NBUFA, NBUFB, N1, N2, MINUS)
Converts a set of binary numbers to an equivalent set of ascii number fields in core.
Definition: w3ai15.f:48
w3ai39
subroutine w3ai39(NFLD, N)
translate an 'ASCII' field to 'EBCDIC', all alphanumerics, special charcaters, fill scatter,...
Definition: w3ai39.f:26
w3fi01
subroutine w3fi01(LW)
Determines the number of bytes in a full word for the particular machine (IBM or cray).
Definition: w3fi01.f:19
w3fi92
subroutine w3fi92(LOC, TTAAII, KARY, KWBX, IERR)
Build 80 character queue descriptor using information supplied by user, placing the completed queue d...
Definition: w3fi92.f:54