SUBROUTINE W3FP13 (GRIB, PDS, ID8, IERR ) C$$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3FP13 CONVERT GRIB PDS EDITION 1 TO O.N. 84 ID C PRGMMR: MCCLEES ORG: NMC421 DATE:91-10-07 C C ABSTRACT: CONVERTS GRIB VERSION 1 FORMATTED PRODUCT DEFINITION C SECTION TO AN OFFICE NOTE 84 ID LABEL. FORMATS ALL THAT IS APPLI- C CABLE IN THE FIRST 8 WORDS OF O.N. 84. (CAUTION ****SEE REMARKS) C C PROGRAM HISTORY LOG: C 91-10-07 ORIGINAL AUTHOR MCCLEES, A. J. C 92-01-06 R.E.JONES CONVERT TO SiliconGraphics 3.3 FORTRAN 77 C 93-03-29 R.E.JONES ADD SAVE STATEMENT C 94-04-17 R.E.JONES COMPLETE REWRITE TO USE SBYTE, MAKE CODE C PORTABLE, UPGRADE TO ON388, MAR 24,1994 C 94-05-05 R.E.JONES CORRECTION IN TWO TABLES C 96-08-02 R.E.JONES ERROR USING T MARKER C 96-09-03 R.E.JONES ADD MERCATOR GRIDS 8 AND 53 TO TABLES C 99-02-15 B. FACEY REPLACE W3FS04 WITH W3MOVDAT. C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I C C USAGE: CALL W3FP13 (GRIB, PDS, ID8, IERR ) C INPUT ARGUMENT LIST: C GRIB - GRIB SECTION 0 READ AS CHARACTER*8 C PDS - GRIB PDS SECTION 1 READ AS CHARACTER*1 PDS(*) C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C ID8 - 12 INTEGER*4 FORMATTED O.N. 84 ID. C 6 INTEGER 64 BIT WORDS ON CRAY C IERR 0 - COMPLETED SATISFACTORILY C 1 - GRIB BLOCK 0 NOT CORRECT C 2 - LENGTH OF PDS NOT CORRECT C 3 - COULD NOT MATCH TYPE INDICATOR C 4 - GRID TYPE NOT IN TABLES C 5 - COULD NOT MATCH TYPE LEVEL C 6 - COULD NOT INTERPRET ORIGINATOR OF CODE C SUBPROGRAMS CALLED: C SPECIAL: INDEX, MOVA2I, CHAR, IOR, IAND, ISHFT C C LIBRARY: C W3LIB: W3MOVDAT, W3FI69, W3FI01 C C REMARKS: SOME OF THE ID'S WILL NOT BE EXACT TO THE O.N. 84 C FOR LOCATING FIELD ON THE DATASET. THESE DIFFERENCES C ARE MAINLY DUE TO TRUNCATION ERRORS WITH LAYERS. C FOR EXAMPLE: .18019 SIG .47191 SIG R H FOR 36.O HRS C WILL CONVERT TO: .18000 SIG .47000 SIG R H FOR 36.0 HRS C !!!!!!!THE ABOVE ID'S NOW FORCED TO BE EXACT!!!!!!!!! C IF J THE WORD COUNT IS GREATER THEN 32743, J IS STORED C IN THE 12TH ID WORD. BITS 16-31 OF THE 8TH ID WORD ARE C SET TO ZERO. C C ATTRIBUTES: C LANGUAGE: FORTRAN 90 C$$$ C INTEGER HH (255) INTEGER HH1 (127) INTEGER HH2 (128) INTEGER LL (255) INTEGER LL1 (127) INTEGER LL2 (128) INTEGER ICXG2 (9) INTEGER ICXGB2 (9) INTEGER ICXG1 (7) INTEGER ICXGB1 (7) C INTEGER C1 INTEGER C2 INTEGER E1 INTEGER E2 INTEGER FTU INTEGER F1 INTEGER F2 INTEGER ID (25) INTEGER ID8 (12) INTEGER IDATE INTEGER JDATE INTEGER IGEN ( 4) INTEGER NGRD (34) INTEGER NPTS (34) INTEGER P1 INTEGER P2 INTEGER S1 C INTEGER S2 INTEGER T INTEGER TR C CHARACTER * 8 GRIB CHARACTER * 8 IGRIB REAL RINC(5) INTEGER NDATE(8), MDATE(8) CHARACTER * 1 IWORK ( 8) CHARACTER * 1 JWORK ( 8) CHARACTER * 1 PDS ( *) C SAVE C EQUIVALENCE (HH(1),HH1(1)) EQUIVALENCE (HH(128),HH2(1)) EQUIVALENCE (LL(1),LL1(1)) EQUIVALENCE (LL(128),LL2(1)) EQUIVALENCE (IDATE,IWORK(1)) EQUIVALENCE (JDATE,JWORK(1)) C DATA HH1 / 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, & 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, & 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, & 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, & 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, & 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, & 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, & 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, & 91, 92, 93, 94, 95, 96, 97, 98, 99, 100, & 101, 102, 103, 104, 105, 106, 107, 108, 109, 110, & 111, 112, 113, 114, 115, 116, 117, 118, 119, 120, & 121, 122, 123, 124, 125, 126, 127/ DATA HH2 / 128, 129, 130, & 131, 132, 133, 134, 135, 136, 137, 138, 139, 140, & 141, 142, 143, 144, 145, 146, 147, 148, 149, 150, & 151, 152, 153, 154, 155, 156, 157, 158, 159, 160, & 161, 162, 163, 164, 165, 166, 167, 168, 169, 170, & 171, 172, 173, 174, 175, 176, 177, 178, 179, 180, & 181, 182, 183, 184, 185, 186, 187, 188, 189, 190, & 191, 192, 193, 194, 195, 196, 197, 198, 199, 200, & 201, 202, 203, 204, 205, 206, 207, 208, 209, 210, & 211, 212, 213, 214, 215, 216, 217, 218, 219, 220, & 221, 222, 223, 224, 225, 226, 227, 228, 229, 230, & 231, 232, 233, 234, 235, 236, 237, 238, 239, 240, & 241, 242, 243, 244, 245, 246, 247, 248, 249, 250, & 251, 252, 253, 254, 255/ C DATA IGEN / 7, 58, 66, 98/ C C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB LAYER. C ICXG2 1.0000, .98230, .96470, C .85000, .84368, .47191, C .18017, .81573, .25011 C ################# C DATA ICXG2 /Z'00002710', Z'00017FB6', Z'000178D6', A Z'00014C08', Z'00014990', Z'0000B857', A Z'00004663', Z'00013EA5', Z'000061B3'/ C C ########### NUMBERS CALCULATED BY GRIB LAYER. C ICXGB2 1.00000, .98000, .96000, C .85000, .84000, .47000, C .18000, .82000, .25000 C ################# C DATA ICXGB2/Z'00002710', Z'00017ED0', Z'00017700', A Z'00014C00', Z'00014820', Z'0000B798', A Z'00004650', Z'00014050', Z'000061A8'/ C C ########### NUMBERS FORCED AFTER CONVERTING FROM GRIB SINGLE. C ICXG1 .98230, .89671, .78483 C .94316, .84367, .999.00, .25011 C ################# C DATA ICXG1 /Z'00017FB6', Z'00015E47', Z'00013293', A Z'0001706C', Z'0001498F', Z'0000863C', Z'000061B3'/ C C ########### NUMBERS CALCULATED BY GRIB LAYER. C ICXGB1 .98230, .89670, .78480 C .94320, .84370, 998.00, .25000 C ################# C DATA ICXGB1/Z'00017FB6', Z'00015E46', Z'00013290', A Z'00017070', Z'00014992', Z'000185D8', Z'000061A8'/ C DATA LL1 / 8, 8, 9, 255, 255, 255, 1, 6, 255, 255, & 16, 24, 19, 23, 20, 21, 17, 18, 255, 180, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 55, 50, 48, 49, 80, 81, 71, 255, 40, 42, & 72, 74, 73, 255, 255, 255, 255, 255, 304, 305, & 95, 88, 101, 89, 104, 255, 117, 255, 97, 98, & 90, 105, 94, 255, 255, 93, 188, 255, 255, 255, & 255, 211, 255, 255, 255, 255, 255, 255, 255, 384, & 161, 255, 255, 169, 22, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 400, & 389, 385, 388, 391, 386, 390, 402, 401, 404, 403, & 204, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 195, 194, 255, 255, 255, 255, 255/ DATA LL2 / 255, 255, 255, & 112, 116, 114, 255, 103, 52, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 119, 157, 158, 159, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 176, 177, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 392, 255, 255, 192, 190, 255, 199, 216, 189, 255, & 193, 191, 210, 107, 255, 198, 255, 255, 255, 255, & 255, 1, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 255, 255, 255, 255, 255, 255, 255, 255, 255, & 255, 160, 255, 255, 255/ C DATA NPTS / 1679, 259920, 3021, 2385, 5104, 4225, & 4225, 5365, 5365, 8326, 8326, & 5967, 6177, 6177, 12321, 12321, 12321, & 32400, 32400, 5022, 12902, 25803, & 24162, 48232, 18048, 6889, 10283, & 3640, 16170, 6889, 19305, 11040, & 72960, 6693/ C DATA NGRD / 1, 4, 5, 6, 8, 27, & 28, 29, 30, 33, 34, & 53, 55, 56, 75, 76, 77, & 85, 86, 87, 90, 91, & 92, 93, 98, 100, 101, & 103, 104, 105, 106, 107, & 126, 214/ C C DATA MSK1 /Z0000FFFF/, C & MSK2 /Z00000080/, C & MSK3 /Z00000000/, C & MSK4 /Z00000200/ C CHANGE HEX TO DECIMAL TO MAKE SUBROUTINE MORE PORTABLE C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - DATA MSK1 /65535/, & MSK2 /128/, & MSK3 /0/, & MSK4 /512/ C C MAKE SECTION 0, PUT 'GRIB' IN ASCII C IGRIB(1:1) = CHAR(71) IGRIB(2:2) = CHAR(82) IGRIB(3:3) = CHAR(73) IGRIB(4:4) = CHAR(66) IGRIB(5:5) = CHAR(0) IGRIB(6:6) = CHAR(0) IGRIB(7:7) = CHAR(0) IGRIB(8:8) = CHAR(1) C C CONVERT PDS INTO 25 INTEGER NUMBERS C CALL W3FI69(PDS,ID) C C ID(1) = NUMBER OF BYTES IN PDS C ID(2) = PARAMETER TABLE VERSION NUMBER C ID(3) = IDENTIFICATION OF ORIGINATING CENTER C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) C ID(5) = GRID IDENTIFICATION C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED C ID(8) = INDICATOR OF PARAMETER AND UNITS C ID(9) = INDICATOR OF TYPE OF LEVEL OR LAYER C ID(10) = LEVEL 1 C ID(11) = LEVEL 2 C ID(12) = YEAR OF CENTURY C ID(13) = MONTH OF YEAR C ID(14) = DAY OF MONTH C ID(15) = HOUR OF DAY C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) C ID(17) = FCST TIME UNIT C ID(18) = P1 PERIOD OF TIME C ID(19) = P2 PERIOD OF TIME C ID(20) = TIME RANGE INDICATOR C ID(21) = NUMBER INCLUDED IN AVERAGE C ID(22) = NUMBER MISSING FROM AVERAGES OR ACCUMULATIONS C ID(23) = CENTURY C ID(24) = IDENTIFICATION OF SUB-CENTER (TABLE 0 - PART 2) C ID(25) = SCALING POWER OF 10 C C THE 1ST 8 32 BIT WORDS WITH THE OFFICE NOTE 84 ID'S ARE C IN 27 PARTS, SBYTE IS USED WITH BIT COUNTS TO MAKE THIS C DATA. THIS MAKE IT WORD SIZE INDEPENDENT, AND MAKES THIS C SUBROUTINE PORTABLE. TABLE WITH STARTING BITS IS NEXT. C THE STARTING BIT AND NO. OF BITS IS USED AS THE 3RD AND C 4TH PARAMETER FOR SBYTE. READ GBYTES DOCUMENT FROM NCAR C FOR INFORMATION ABOUT SBYTE. SEE PAGE 38, FIGURE 1, IN C OFFICE NOTE 84. C C NO. NAME STARTING BIT NO. OF BITS C ----------------------------------------- C 1 Q 0 12 C 2 S1 12 12 C 3 F1 24 8 C 4 T 32 4 C 5 C1 36 20 C 6 E1 56 8 C 7 M 64 4 C 8 X 68 8 C 9 S2 76 12 C 10 F2 88 8 C 11 N 96 4 C 12 C2 100 20 C 13 E2 120 8 C 14 CD 128 8 C 15 CM 136 8 C 16 KS 144 8 C 17 K 152 8 C 18 GES 160 4 C 19 164 12 C 20 NW 176 16 C 21 YY 192 8 C 22 MM 200 8 C 23 DD 208 8 C 24 II 216 8 C 25 R 224 8 C 26 G 232 8 C 27 J 240 16 C OR 27 J 352 32 J > 32743 C---------------------------------------------- C C$ 1.0 INITIALIZATION - NO. OF ENTRIES IN INDCATOR PARM. C$ - NO. OF ENTRIES IN TYPE LEVEL C$ - NO. OF ENTRIES IN CNTR PROD. DTA. C$ - INITIAL ZEROS IN O.N. 84 LABEL C IQ = 255 IC = 4 IN = 34 C C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) C CALL W3FI01(LW) IF (LW.EQ.4) THEN NWORDS = 12 ELSE NWORDS = 6 END IF C C ZERO OUTPUT ARRAY C DO N = 1,NWORDS ID8(N) = 0 END DO C C --------------------------------------------------------------------- C$ 2.0 VERIFY GRIB IN SECTION 0 C IF (.NOT. GRIB(1:4) .EQ. IGRIB(1:4)) THEN IERR = 1 RETURN END IF C C 2.1 VERIFY THE NO. OF OCTETS IN THE PDS C IF (ID(1).NE.28) THEN IERR = 2 PRINT *,'IERR = ',IERR,',LENGTH OF PDS = ',ID(1) RETURN END IF C C$ 3.0 GENERATING MODEL, TYPE GRID, AND NO. OF GRID PTS. C C IF CENTER NOT U.S., STORE CENTER IN G MARKER C IF CENTER U.S. STORE MODEL NO. IN G MARKER C IF (ID(3) .NE. 7) THEN CALL SBYTE(ID8,ID(3),232,8) ELSE CALL SBYTE(ID8,ID(4),232,8) END IF C DO KK = 1,IN IF (ID(5) .EQ. NGRD(KK)) THEN IGRDPT = NPTS(KK) IF (ID(5) .EQ. 6) ID(5) = 26 CALL SBYTE(ID8,ID(5),152,8) IF (IGRDPT.LE.32743) THEN CALL SBYTE(ID8,IGRDPT,240,16) ELSE CALL SBYTE(ID8,IGRDPT,352,32) END IF GO TO 350 END IF END DO IERR = 4 PRINT *,'IERR = ',IERR,',GRID TYPE = ',ID(5) RETURN C 350 CONTINUE C C COMPUTE R MARKER FROM MODEL NUMBERS FOR U.S. CENTER C C (ERL) run IF (ID(3).EQ.7) THEN IF (ID(4).EQ.19.OR.ID(4).EQ.53.OR.ID(4).EQ.83.OR. & ID(4).EQ.84.OR.ID(4).EQ.85) THEN CALL SBYTE(ID8,0,224,8) C (NMC) run ELSE IF (ID(4).EQ.25) THEN CALL SBYTE(ID8,1,224,8) C (RGL) run ELSE IF (ID(4).EQ.39.OR.ID(4).EQ.64) THEN CALL SBYTE(ID8,2,224,8) C (AVN) run ELSE IF (ID(4).EQ.10.OR.ID(4).EQ.42.OR. & ID(4).EQ.68.OR.ID(4).EQ.73.OR. & ID(4).EQ.74.OR.ID(4).EQ.75.OR. & ID(4).EQ.77.OR.ID(4).EQ.81.OR. & ID(4).EQ.88) THEN CALL SBYTE(ID8,3,224,8) C (MRF) run ELSE IF (ID(4).EQ.69.OR.ID(4).EQ.76.OR. & ID(4).EQ.78.OR.ID(4).EQ.79.OR. & ID(4).EQ.80.oR.ID(4).EQ.87) THEN CALL SBYTE(ID8,4,224,8) C (FNL) run ELSE IF (ID(4).EQ.43.OR.ID(4).EQ.44.OR. & ID(4).EQ.82) THEN CALL SBYTE(ID8,5,224,8) C (HCN) run ELSE IF ( ID(4).EQ.70) THEN CALL SBYTE(ID8,6,224,8) C (RUC) run ELSE IF ( ID(4).EQ.86) THEN CALL SBYTE(ID8,7,224,8) C Not applicable, set to 255 ELSE CALL SBYTE(ID8,255,224,8) END IF END IF C C$ 4.0 FORM TYPE DATA PARAMETER C DO II = 1,IQ III = II IF (ID(8) .EQ. HH(II)) THEN IF (LL(II).NE.255) GO TO 410 PRINT *,'PDS PARAMETER HAS NO OFFICE NOTE 84 Q TYPE' PRINT *,'PDS BYTE 9 PARAMETER = ',ID(8) IERR = 3 RETURN END IF END DO IERR = 3 PRINT *,'PDS BYTE 9, PARAMETER = ',ID(8) RETURN C 410 CONTINUE C C Q DATA TYPE, BITS 1-12 C CALL SBYTE(ID8,LL(III),0,12) C C TEST FOR 32 OR 64 BIT COMPUTER (CRAY) C IF (LW.EQ.4) THEN IF (ID(8) .EQ. 211) ID8(5) = IOR (ID8(5),MSK4) IF (ID(8) .EQ. 210) ID8(5) = IOR (ID8(5),MSK4) ELSE IF (ID(8) .EQ. 211) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) IF (ID(8) .EQ. 210) ID8(3) = IOR (ID8(3),ISHFT(MSK4,32)) END IF C C$ 5.0 FORM TYPE LEVEL C IF (ID(9) .EQ. 100) THEN M = 0 S1 = 8 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) LEVEL = ID(11) IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) C ELSE IF (ID(9) .EQ. 103) THEN M = 0 S1 = 1 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) LEVEL = ID(11) IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) C ELSE IF (ID(9) .EQ. 105) THEN M = 0 S1 = 6 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) LEVEL = ID(11) IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) C ELSE IF (ID(9) .EQ. 111) THEN M = 0 S1 = 7 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) LEVEL = ID(11) IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) C XXXXXXX SCALE FROM CENTIMETERS TO METERS. XXXXXXXXXX E1 = IOR(E1,MSK2) E1 = E1 + 2 IF (C1 .EQ. 0) THEN E1 = 0 END IF CALL SBYTE(ID8,E1,56,8) C ELSE IF (ID(9) .EQ. 107) THEN M = 0 S1 = 148 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) LEVEL = ID(11) IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 ELSE E1 = 0 END IF C1 = LEVEL * 10 ** E1 DO ISI = 1,7 IF (C1 .EQ. ICXGB1(ISI)) THEN C1 = ICXG1(ISI) END IF END DO CALL SBYTE(ID8,C1,36,20) C***********SCALING OF .0001 TAKEN INTO ACCOUNT E1 = E1 + 4 E1 = IOR(E1,MSK2) IF (C1 .EQ. 0) THEN E1 = 0 END IF CALL SBYTE(ID8,E1,56,8) C ELSE IF (ID(9) .EQ. 4) THEN M = 0 S1 = 16 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) C LEVEL = ID(11) C******* CONSTANT VALUE OF 273.16 WILL HAVE TO BE INSERTED C LEVEL = IAND (IPDS(3),MSK1) C IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN C E1 = 4 C ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN C E1 = 3 C ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN C E1 = 2 C ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN C E1 = 1 C END IF E1 = 2 C1 = (273.16 * 10 ** E1) + .5 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) C*************SPECIAL CASES ********************* ELSE IF (ID(9) .EQ. 102) THEN M = 0 S1 = 128 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,0,64,32) C ELSE IF (ID(9) .EQ. 1) THEN M = 0 S1 = 129 C***** S1 = 133 ALSO POSSIBILITY CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,0,64,32) C ELSE IF (ID(9) .EQ. 7) THEN M = 0 S1 = 130 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,0,64,32) C ELSE IF (ID(9) .EQ. 6) THEN M = 0 S1 = 131 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,0,64,32) C ELSE IF (ID(9) .EQ. 101) THEN M = 2 S1 = 8 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) CALL SBYTE(ID8,S1,76,12) LEVEL = ID(10) LEVEL = (LEVEL * .1) * 10 ** 2 IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) LEVEL2 = ID(11) LEVEL2 = (LEVEL2 * .1) * 10 ** 2 IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN E2 = 4 ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN E2 = 3 ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN E2 = 2 ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN E2 = 1 END IF C2 = LEVEL2 * 10 ** E2 CALL SBYTE(ID8,C2,100,20) IF (C2 .EQ. 0) E2 = 0 E2 = IOR(E2,MSK2) CALL SBYTE(ID8,E2,120,8) C ELSE IF (ID(9) .EQ. 104) THEN M = 2 S1 = 1 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) CALL SBYTE(ID8,S1,76,12) LEVEL = ID(10) LEVEL = (LEVEL * .1) * 10 ** 2 IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) LEVEL2 = ID(11) LEVEL2 = (LEVEL2 * .1) * 10 ** 2 IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN E2 = 4 ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN E2 = 3 ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN E2 = 2 ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN E2 = 1 END IF C2 = LEVEL2 * 10 ** E2 CALL SBYTE(ID8,C2,100,20) E2 = IOR(E2,MSK2) CALL SBYTE(ID8,E2,120,8) C ELSE IF (ID(9) .EQ. 106) THEN M = 2 S1 = 6 CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) CALL SBYTE(ID8,S1,76,12) LEVEL = ID(10) LEVEL = (LEVEL * .1) * 10**2 IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * 10 ** E1 CALL SBYTE(ID8,C1,36,20) E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) LEVEL2 = ID(10) LEVEL2 = (LEVEL2 * .1) * 10 ** 2 IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN E2 = 4 ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN E2 = 3 ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN E2 = 2 ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN E2 = 1 END IF C2 = LEVEL2 * 10 ** E2 CALL SBYTE(ID8,C2,100,20) E2 = IOR(E2,MSK2) CALL SBYTE(ID8,E2,120,8) C ELSE IF (ID(9) .EQ. 108) THEN M = 2 S1 = 148 C**** S1 = 144 ALSO POSSIBILITY C**** S1 = 145 ALSO POSSIBILITY CALL SBYTE(ID8,S1,12,12) CALL SBYTE(ID8,M,64,4) CALL SBYTE(ID8,S1,76,12) LEVEL = ID(10) LEVEL = LEVEL IF (LEVEL .GE. 1 .AND. LEVEL .LE. 9) THEN E1 = 4 ELSE IF (LEVEL .GE. 10 .AND. LEVEL .LE. 99) THEN E1 = 3 ELSE IF (LEVEL .GE. 100 .AND. LEVEL .LE. 999) THEN E1 = 2 ELSE IF (LEVEL .GE. 1000 .AND. LEVEL .LE. 9999) THEN E1 = 1 END IF C1 = LEVEL * (10 ** E1) DO ISI = 1,9 IF (C1 .EQ. ICXGB2(ISI)) THEN C1 = ICXG2(ISI) END IF END DO CALL SBYTE(ID8,C1,36,20) IF (C1 .EQ. 0) THEN E1 = 0 CALL SBYTE(ID8,E1,56,8) GO TO 700 END IF C*****TAKE SCALING INTO ACCOUNT .01 E1 = E1 + 2 E1 = IOR(E1,MSK2) CALL SBYTE(ID8,E1,56,8) C 700 CONTINUE LEVEL2 = ID(11) LEVEL2 = LEVEL2 IF (LEVEL2 .GE. 1 .AND. LEVEL2 .LE. 9) THEN E2 = 4 ELSE IF (LEVEL2 .GE. 10 .AND. LEVEL2 .LE. 99) THEN E2 = 3 ELSE IF (LEVEL2 .GE. 100 .AND. LEVEL2 .LE. 999) THEN E2 = 2 ELSE IF (LEVEL2 .GE. 1000 .AND. LEVEL2 .LE. 9999) THEN E2 = 1 END IF C2 = LEVEL2 * 10 ** E2 DO ISI = 1,9 IF (C2 .EQ. ICXGB2(ISI)) THEN C2 = ICXG2(ISI) END IF END DO CALL SBYTE(ID8,C2,100,20) E2 = IOR(E2,MSK2) CALL SBYTE(ID8,E2,120,8) C*******TAKE SCALING INTO ACCOUNT .01 E2 = E2 + 2 E2 = IOR(E2,MSK2) CALL SBYTE(ID8,E2,120,8) C END IF C 5.1 FORCAST TIMES ,PLUS THE T MARKER AND CM FIELD C TR = ID(20) IF (TR .EQ. 0) THEN P1 = ID(18) CALL SBYTE(ID8,ID(18),24,8) ELSE IF (TR .EQ. 4) THEN P2 = ID(19) CALL SBYTE(ID8,P2,24,8) P1 = ID(18) CALL SBYTE(ID8,(P2 - P1),88,8) T = 3 CALL SBYTE(ID8,T,32,4) ELSE IF (TR .EQ. 5) THEN P2 = ID(19) CALL SBYTE(ID8,P2,24,8) P1 = ID(18) CALL SBYTE(ID8,(P2 - P1),88,8) T = 3 CALL SBYTE(ID8,T,32,4) C ELSE IF (TR .EQ. 124) THEN FTU = ID(17) IF (FTU .EQ. 2) THEN F1 = ID(21) CALL SBYTE(ID8,F1,24,8) T = 4 CALL SBYTE(ID8,T,32,4) ELSE IF (FTU .EQ. 4) THEN F2 = ID(21) CALL SBYTE(ID8,F2,88,8) T = 4 CALL SBYTE(ID8,T,32,4) END IF C ELSE IF (TR .EQ.123) THEN F1 = 3 F1 = IOR(F1,MSK2) CALL SBYTE(ID8,F1,24,8) F2 = 5 * 2 CALL SBYTE(ID8,F2,88,8) T = 6 CALL SBYTE(ID8,T,32,4) RINC = 0.0 RINC(2) = 36.0 IYR=MOVA2I(PDS(13)) PRINT *, 'IYR = ', IYR IF(IYR.LT.20)THEN MDATE(1)=2000+IYR ELSE MDATE(1)=1900+IYR ENDIF MDATE(2) = MOVA2I(PDS(14)) MDATE(3) = MOVA2I(PDS(15)) MDATE(5) = MOVA2I(PDS(16)) C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) C PRINT *, 'CHANGE DATE BY - ', RINC(2) CALL W3MOVDAT(RINC,MDATE,NDATE) C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) C CALL W3FS04 (IDATE,JDATE,3,IERR) IYEAR = MOD(NDATE(1),100) JWORK(1) = CHAR(IYEAR) JWORK(2) = CHAR(NDATE(2)) JWORK(3) = CHAR(NDATE(3)) JWORK(4) = CHAR(NDATE(5)) IDATE = JDATE GO TO 710 C ELSE IF (TR .EQ.3) THEN P1 = ID(18) P2 = ID(19) F1 = P1 / 12 CALL SBYTE(ID8,F1,24,8) C C ***** NAVG IS IN BITES 22 23 ***** C USING BITE 23 ONLY ******* C FIX LATER ****************************************** C C NAVG = MOVA2I(PDS(23)) F2 = (P2 - P1) / 12 CALL SBYTE(ID8,F2,88,8) T = 6 CALL SBYTE(ID8,T,32,4) RINC = 0.0 RINC(2) = -36.0 IYR=MOVA2I(PDS(13)) PRINT *, 'IYR = ', IYR IF(IYR.LT.20)THEN MDATE(1)=2000+IYR ELSE MDATE(1)=1900+IYR ENDIF MDATE(2) = MOVA2I(PDS(14)) MDATE(3) = MOVA2I(PDS(15)) MDATE(5) = MOVA2I(PDS(16)) C PRINT *, 'OLD DATE = ', MDATE(1), MDATE(2), MDATE(3), MDATE(5) C PRINT *, 'CHANGE DATE BY - ', RINC(2) CALL W3MOVDAT(RINC,MDATE,NDATE) C PRINT *, 'NEW DATE = ', NDATE(1), NDATE(2), NDATE(3), NDATE(5) C CALL W3FS04 (IDATE,JDATE,-3,IERR) IYEAR = MOD(NDATE(1),100) JWORK(1) = CHAR(IYEAR) JWORK(2) = CHAR(NDATE(2)) JWORK(3) = CHAR(NDATE(3)) JWORK(4) = CHAR(NDATE(5)) IDATE = JDATE GO TO 710 END IF C C$ 7.0 TRANSFER THE DATE C IWORK(1) = PDS(13) IWORK(2) = PDS(14) IWORK(3) = PDS(15) IWORK(4) = PDS(16) C 710 CONTINUE C C TEST FOR 64 BIT COMPUTER (CRAY) C IF (LW.EQ.8) IDATE = ISHFT(IDATE,-32) CALL SBYTE(ID8,IDATE,192,32) C IERR = 0 RETURN END