!
!##################################################################
!##################################################################
!###### ######
!###### NMCDECODE ######
!###### ######
!##################################################################
!##################################################################
!
!
!-----------------------------------------------------------------------
!
! PURPOSE:
!
! Decode the NMC GRIB files.
!
!-----------------------------------------------------------------------
!
! AUTHOR: NWS/NMC
!
! MODIFICATION HISTORY:
! 01/16/1996 (Yuhe Liu)
! Changed subroutine name of SBYTE(S) and GBYTE(S) to GRBSBYTE(S)
! and GRBGBYTE(S) to avoid the conflict with the subroutines of
! same names in NCAR graphics package.
!
!-----------------------------------------------------------------------
!
! Original comments:
!
! FILE UPDATED ON 11-22-94 BY M. FARLEY.
! CONTAINS SUBROUTINES NEEDED TO DECODE GRIB MESSAGES:
! W3FI63 AND W3FI83.
!
SUBROUTINE w3fi63(msga,kpds,kgds,kbms,DATA,kptr,kret) 1,24
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: W3FI63 UNPK GRIB FIELD TO GRIB GRID
! PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22
!
! ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID
! SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE
! THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE
! GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS.
!
! WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN
! RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
! 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5-8
! 91-12-22 CAVANAUGH CORRECTED PROCESSING OF MERCATOR PROJECTIONS
! IN GRID DEFINITION SECTION (GDS) IN
! ROUTINE FI633
! 92-08-05 CAVANAUGH CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR
! ONE DEGREE BY ONE DEGREE GLOBAL GRIDS
! 92-08-27 CAVANAUGH CORRECTED TYPO ERROR, ADDED CODE TO COMPARE
! TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF
! SECTION SIZES.
! 92-10-21 CAVANAUGH CORRECTIONS WERE MADE (IN FI634) TO REDUCE
! PROCESSING TIME FOR INTERNATIONAL GRIDS.
! REMOVED A TYPOGRAPHICAL ERROR IN FI635.
! 93-01-07 CAVANAUGH CORRECTIONS WERE MADE (IN FI635) TO
! FACILITATE USE OF THESE ROUTINES ON A PC.
! A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED
! 93-01-13 CAVANAUGH CORRECTIONS WERE MADE (IN FI632) TO
! PROPERLY HANDLE CONDITION WHEN
! TIME RANGE INDICATOR = 10.
! ADDED U.S.GRID 87.
! 93-02-04 CAVANAUGH ADDED U.S.GRIDS 85 AND 86
! 93-02-26 CAVANAUGH ADDED GRIDS 2, 3, 37 THRU 44,AND
! GRIDS 55, 56, 90, 91, 92, AND 93 TO
! LIST OF U.S. GRIDS.
! 93-04-07 CAVANAUGH ADDED GRIDS 67 THRU 77 TO
! LIST OF U.S. GRIDS.
! 93-04-20 CAVANAUGH INCREASED MAX SIZE TO ACCOMODATE
! GAUSSIAN GRIDS.
! 93-05-26 CAVANAUGH CORRECTED GRID RANGE SELECTION IN FI634
! FOR RANGES 67-71 & 75-77
! 93-06-08 CAVANAUGH CORRECTED FI635 TO ACCEPT GRIB MESSAGES
! WITH SECOND ORDER PACKING. ADDED ROUTINE FI636
! TO PROCESS MESSAGES WITH SECOND ORDER PACKING.
! 93-09-22 CAVANAUGH MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM
! PDS BYTE 26
! 93-10-13 CAVANAUGH MODIFIED FI634 TO CORRECT GRID SIZES FOR
! GRIDS 204 AND 208
! 93-10-14 CAVANAUGH INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR
! NUMBER OF POINTS IN GRID AND NUMBER OF WORDS
! IN EACH ROW
! 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD
! OF VERSION NUMBER
! 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER
! VALUES AND SECOND ORDER VALUES CORRECTLY
! IN ROUTINE FI636
! 94-03-02 CAVANAUGH ADDED CALL TO W3FI83 WITHIN DECODER. USER
! NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE
! 94-04-22 CAVANAUGH MODIFIED FI635, FI636 TO PROCESS ROW BY ROW
! SECOND ORDER PACKING, ADDED SCALING CORRECTION
! TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS
! IN COMMENT FIELDS IN FI634
! 94-05-17 CAVANAUGH CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION
! FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING
! INFORMATION TO DOCBLOCK ENTRIES
! 94-05-25 CAVANAUGH ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL
! AS ROW BY ROW ORDERING OF SECOND ORDER DATA
! 94-06-27 CAVANAUGH ADDED PROCESSING FOR GRIDS 45, 94 AND 95.
! INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS
! FOR THINNED GRIDS IN FI636.
! 94-07-08 CAVANAUGH COMMENTED OUT PRINT OUTS USED FOR DEBUGGING
! 94-09-08 CAVANAUGH ADDED GRIDS 220, 221, 223 FOR FNOC
! 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000
! FOR .5 DEGREE SST ANALYSIS FIELDS
!
!
! USAGE: CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
! INPUT ARGUMENT LIST:
! MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1
! (MESSAGE CAN BE PRECEDED BY JUNK CHARS)
!
! OUTPUT ARGUMENT LIST:
! DATA - ARRAY CONTAINING DATA ELEMENTS
! KPDS - ARRAY CONTAINING PDS ELEMENTS. (EDITION 1)
! (1) - ID OF CENTER
! (2) - GENERATING PROCESS ID NUMBER
! (3) - GRID DEFINITION
! (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8)
! (5) - INDICATOR OF PARAMETER
! (6) - TYPE OF LEVEL
! (7) - HEIGHT/PRESSURE , ETC OF LEVEL
! (8) - YEAR INCLUDING (CENTURY-1)
! (9) - MONTH OF YEAR
! (10) - DAY OF MONTH
! (11) - HOUR OF DAY
! (12) - MINUTE OF HOUR
! (13) - INDICATOR OF FORECAST TIME UNIT
! (14) - TIME RANGE 1
! (15) - TIME RANGE 2
! (16) - TIME RANGE FLAG
! (17) - NUMBER INCLUDED IN AVERAGE
! (18) - VERSION NR OF GRIB SPECIFICATION
! (19) - VERSION NR OF PARAMETER TABLE
! (20) - NR MISSING FROM AVERAGE/ACCUMULATION
! (21) - CENTURY OF REFERENCE TIME OF DATA
! (22) - UNITS DECIMAL SCALE FACTOR
! (23) - SUBCENTER NUMBER
! (26-35) - RESERVED
! (24-25) - RESERVED FOR FUTURE USE
! (36-N) - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM
! DEFINITION SECTION (PDS) OF GRIB MESSAGE
! KGDS - ARRAY CONTAINING GDS ELEMENTS.
! (1) - DATA REPRESENTATION TYPE
! (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS
! (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
! PARAMETERS
! OR
! OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
! IN EACH ROW
! OR
! 255 IF NEITHER ARE PRESENT
! (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
! (22) - NUMBER OF WORDS IN EACH ROW
! LATITUDE/LONGITUDE GRIDS
! (2) - N(I) NR POINTS ON LATITUDE CIRCLE
! (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
! (7) - LA(2) LATITUDE OF EXTREME POINT
! (8) - LO(2) LONGITUDE OF EXTREME POINT
! (9) - DI LATITUDINAL DIRECTION OF INCREMENT
! (10) - DJ LONGITUDINAL DIRECTION INCREMENT
! (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
! GAUSSIAN GRIDS
! (2) - N(I) NR POINTS ON LATITUDE CIRCLE
! (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
! (7) - LA(2) LATITUDE OF EXTREME POINT
! (8) - LO(2) LONGITUDE OF EXTREME POINT
! (9) - DI LATITUDINAL DIRECTION OF INCREMENT
! (10) - N - NR OF CIRCLES POLE TO EQUATOR
! (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
! (12) - NV - NR OF VERT COORD PARAMETERS
! (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS
! OR
! PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN
! EACH ROW (IF NO VERT COORD PARAMETERS
! ARE PRESENT
! OR
! 255 IF NEITHER ARE PRESENT
! POLAR STEREOGRAPHIC GRIDS
! (2) - N(I) NR POINTS ALONG LAT CIRCLE
! (3) - N(J) NR POINTS ALONG LON CIRCLE
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
! (7) - LOV GRID ORIENTATION
! (8) - DX - X DIRECTION INCREMENT
! (9) - DY - Y DIRECTION INCREMENT
! (10) - PROJECTION CENTER FLAG
! (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28)
! SPHERICAL HARMONIC COEFFICIENTS
! (2) - J PENTAGONAL RESOLUTION PARAMETER
! (3) - K " " "
! (4) - M " " "
! (5) - REPRESENTATION TYPE
! (6) - COEFFICIENT STORAGE MODE
! MERCATOR GRIDS
! (2) - N(I) NR POINTS ON LATITUDE CIRCLE
! (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17)
! (7) - LA(2) LATITUDE OF LAST GRID POINT
! (8) - LO(2) LONGITUDE OF LAST GRID POINT
! (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION
! (10) - RESERVED
! (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
! (12) - LONGITUDINAL DIR GRID LENGTH
! (13) - LATITUDINAL DIR GRID LENGTH
! LAMBERT CONFORMAL GRIDS
! (2) - NX NR POINTS ALONG X-AXIS
! (3) - NY NR POINTS ALONG Y-AXIS
! (4) - LA1 LAT OF ORIGIN (LOWER LEFT)
! (5) - LO1 LON OF ORIGIN (LOWER LEFT)
! (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
! (7) - LOV - ORIENTATION OF GRID
! (8) - DX - X-DIR INCREMENT
! (9) - DY - Y-DIR INCREMENT
! (10) - PROJECTION CENTER FLAG
! (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28)
! (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
! (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
! KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
! (ALWAYS CONSTRUCTED)
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG (COPY OF BMS OCTETS 5,6)
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4)
! (15) - NR UNUSED BITS AT END OF SECTION 4
! KRET - FLAG INDICATING QUALITY OF COMPLETION
!
! REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN
! RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL.
!
! VALUES FOR RETURN FLAG (KRET)
! KRET = 0 - NORMAL RETURN, NO ERRORS
! = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS
! = 2 - '7777' NOT IN CORRECT LOCATION
! = 3 - UNPACKED FIELD IS LARGER THAN 65160
! = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES
! = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED
! = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF
! = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
! =10 - INCORRECT CENTER INDICATOR
! =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED.
! PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS
! SHOWN IN OCTETS 4 AND 14.
! =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED.
! PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
! 4 AUG 1988
! W3FI63
!
!
! GRIB UNPACKING ROUTINE
!
!
! THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
! TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
! VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
! DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
! SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
! INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
! GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
! DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
!
! THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
!
! CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
!
! INPUT:
!
! MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
! "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
!
! OUTPUT:
!
! KPDS(100) INTEGER*4
! ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
! DEFINITION SEC .
! (VERSION 1)
! KPDS(1) - ID OF CENTER
! KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
! KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
! KPDS(4) - GDS/BMS FLAG
! BIT DEFINITION
! 25 0 - GDS OMITTED
! 1 - GDS INCLUDED
! 26 0 - BMS OMITTED
! 1 - BMS INCLUDED
! NOTE:- LEFTMOST BIT = 1,
! RIGHTMOST BIT = 32
! KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
! KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
! KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
! KPDS(8) - YEAR INCLUDING CENTURY
! KPDS(9) - MONTH OF YEAR
! KPDS(10) - DAY OF MONTH
! KPDS(11) - HOUR OF DAY
! KPDS(12) - MINUTE OF HOUR
! KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
! TABLE 8)
! KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
! KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
! KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
! KPDS(17) - NUMBER INCLUDED IN AVERAGE
! KPDS(18) - EDITION NR OF GRIB SPECIFICATION
! KPDS(19) - VERSION NR OF PARAMETER TABLE
!
! KGDS(13) INTEGER*4
! ARRAY CONTAINING GDS ELEMENTS.
!
! KGDS(1) - DATA REPRESENTATION TYPE
!
! LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
! KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
! CIRCLE
! KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
! CIRCLE
! KGDS(4) - LA(1) LATITUDE OF ORIGIN
! KGDS(5) - LO(1) LONGITUDE OF ORIGIN
! KGDS(6) - RESOLUTION FLAG
! BIT MEANING
! 25 0 - DIRECTION INCREMENTS NOT
! GIVEN
! 1 - DIRECTION INCREMENTS GIVEN
! KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
! KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
! KGDS(9) - DI LATITUDINAL DIRECTION INCREMENT
! KGDS(10) - REGULAR LAT/LON GRID
! DJ - LONGITUDINAL DIRECTION
! INCREMENT
! GAUSSIAN GRID
! N - NUMBER OF LATITUDE CIRCLES
! BETWEEN A POLE AND THE EQUATOR
! KGDS(11) - SCANNING MODE FLAG
! BIT MEANING
! 25 0 - POINTS ALONG A LATITUDE
! SCAN FROM WEST TO EAST
! 1 - POINTS ALONG A LATITUDE
! SCAN FROM EAST TO WEST
! 26 0 - POINTS ALONG A MERIDIAN
! SCAN FROM NORTH TO SOUTH
! 1 - POINTS ALONG A MERIDIAN
! SCAN FROM SOUTH TO NORTH
! 27 0 - POINTS SCAN FIRST ALONG
! CIRCLES OF LATITUDE, THEN
! ALONG MERIDIANS
! (FORTRAN: (I,J))
! 1 - POINTS SCAN FIRST ALONG
! MERIDIANS THEN ALONG
! CIRCLES OF LATITUDE
! (FORTRAN: (J,I))
!
! POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
! KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
! KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
! KGDS(4) - LA(1) LATITUDE OF ORIGIN
! KGDS(5) - LO(1) LONGITUDE OF ORIGIN
! KGDS(6) - RESERVED
! KGDS(7) - LOV GRID ORIENTATION
! KGDS(8) - DX - X DIRECTION INCREMENT
! KGDS(9) - DY - Y DIRECTION INCREMENT
! KGDS(10) - PROJECTION CENTER FLAG
! KGDS(11) - SCANNING MODE
!
! SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
! KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
! KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
! KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
! KGDS(5) - REPRESENTATION TYPE
! KGDS(6) - COEFFICIENT STORAGE MODE
!
! MERCATOR GRIDS
! KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
! KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! KGDS(4) - LA(1) LATITUDE OF ORIGIN
! KGDS(5) - LO(1) LONGITUDE OF ORIGIN
! KGDS(6) - RESOLUTION FLAG
! KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
! KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
! KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION
! KGDS(10) - RESERVED
! KGDS(11) - SCANNING MODE FLAG
! KGDS(12) - LONGITUDINAL DIR GRID LENGTH
! KGDS(13) - LATITUDINAL DIR GRID LENGTH
! LAMBERT CONFORMAL GRIDS
! KGDS(2) - NX NR POINTS ALONG X-AXIS
! KGDS(3) - NY NR POINTS ALONG Y-AXIS
! KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
! KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
! KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
! KGDS(7) - LOV - ORIENTATION OF GRID
! KGDS(8) - DX - X-DIR INCREMENT
! KGDS(9) - DY - Y-DIR INCREMENT
! KGDS(10) - PROJECTION CENTER FLAG
! KGDS(11) - SCANNING MODE FLAG
! KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
! SECANT CONE INTERSECTION
! KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
! SECANT CONE INTERSECTION
!
! LBMS(65160) LOGICAL
! ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
! PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
! BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
! ONE WILL BE GENERATED AUTOMATICALLY BY THE
! UNPACKING ROUTINE.
!
!
! DATA(65160) REAL*4
! THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
!
! NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE
!
! KPTR(10) INTEGER*4
! ARRAY CONTAINING STORAGE FOR THE FOLLOWING
! PARAMETERS.
!
! (1) - UNUSED
! (2) - UNUSED
! (3) - LENGTH OF PDS (IN BYTES)
! (4) - LENGTH OF GDS (IN BYTES)
! (5) - LENGTH OF BMS (IN BYTES)
! (6) - LENGTH OF BDS (IN BYTES)
! (7) - USED BY UNPACKING ROUTINE
! (8) - NUMBER OF DATA POINTS FOR GRID
! (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
! (10) - USED BY UNPACKING ROUTINE
!
!
! KRET INTEGER*4
! THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
!
! 0 - NO ERRORS DETECTED.
!
! 1 - 'GRIB' NOT FOUND IN FIRST 100
! CHARACTERS.
!
! 2 - '7777' NOT FOUND, EITHER MISSING OR
! TOTAL OF SEC COUNTS OF INDIVIDUAL
! SECTIONS IS INCORRECT.
!
! 3 - UNPACKED FIELD IS LARGER THAN 65160.
!
! 4 - IN GDS, DATA REPRESENTATION TYPE
! NOT ONE OF THE CURRENTLY ACCEPTABLE
! VALUES. SEE "GRIB" TABLE 9. VALUE
! OF INCORRECT TYPE RETURNED IN KGDS(1).
!
! 5 - GRID INDICATED IN KPDS(3) IS NOT
! AVAILABLE FOR THE CENTER INDICATED IN
! KPDS(1) AND NO GDS SENT.
!
! 7 - EDITION INDICATED IN KPDS(18) HAS NOT
! YET BEEN INCLUDED IN THE DECODER.
!
! 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
! GRID) BUT FLAG INDICATING PRESENCE OF
! GDS IS TURNED OFF. NO METHOD OF
! GENERATING PROPER GRID.
!
! 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
! MATCH STANDARD NUMBER OF POINTS FOR THIS
! GRID (FOR OTHER THAN SPECTRALS). THIS
! WILL OCCUR ONLY IF THE GRID.
! IDENTIFICATION, KPDS(3), AND A
! TRANSMITTED GDS ARE INCONSISTENT.
!
! 10 - CENTER INDICATOR WAS NOT ONE INDICATED
! IN "GRIB" TABLE 1. PLEASE CONTACT AD
! PRODUCTION MANAGEMENT BRANCH (W/NMC42)
! IF THIS ERROR IS ENCOUNTERED.
!
! 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY
! PROCESSED. PROGRAM IS NOT SET TO PROCESS
! FLAG COMBINATIONS AS SHOWN IN
! OCTETS 4 AND 14.
!
!
! LIST OF TEXT MESSAGES FROM CODE
!
!
! W3FI63/FI632
!
! 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
! AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
! (W/NMC42)'
!
! 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
! AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
! (W/NMC42)'
!
! 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
! OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
! PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
!
! 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
! AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
! (W/NMC42)'
!
!
! W3FI63/FI633
!
! 'POLAR STEREO PROCESSING NOT AVAILABLE' *
!
! W3FI63/FI634
!
! 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
! COEFFICIENTS'
!
!
! W3FI63/FI637
!
! 'NO CURRENT LISTING OF FNOC GRIDS' *
!
!
! * WILL BE AVAILABLE IN NEXT UPDATE
! ***************************************************************
!
! INCOMING MESSAGE HOLDER
CHARACTER :: msga(*)
! BIT MAP
LOGICAL*1 :: kbms(*)
!
! ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
INTEGER :: kpds(*)
! ELEMENTS OF GRID DESCRIPTION SEC (PDS)
INTEGER :: kgds(*)
!
! CONTAINER FOR GRIB GRID
REAL :: DATA(*)
!
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kptr(*)
!
! *****************************************************************
INTEGER :: kkk,jsgn,jexp,ifr,npts
CHARACTER (LEN=1) :: kk(8)
REAL :: realkk,fval1,fdiff1
EQUIVALENCE (kk(1),kkk)
! *****************************************************************
! 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
! FIND 'GRIB' CHARACTERS
! 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
! IF '7777' IS IN PROPER PLACE.
! 3.0 PARSE PRODUCT DEFINITION SECTION.
! 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
! 5.0 PARSE BIT MAP SEC (IF INCLUDED)
! 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
! DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
! DATA AND PLACE INTO PROPER ARRAY.
! *******************************************************************
!
! MAIN DRIVER
!
! *******************************************************************
SAVE
kptr(10) = 0
! SEE IF PROPER 'GRIB' KEY EXISTS, THEN
! USING SEC COUNTS, DETERMINE IF '7777'
! IS IN THE PROPER LOCATION
!
CALL fi631
(msga,kptr,kpds,kret)
IF(kret /= 0) THEN
GO TO 900
END IF
! PRINT *,'FI631 KPTR',(KPTR(I),I=1,16)
!
! PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
!
CALL fi632(msga,kptr,kpds,kret)
IF(kret /= 0) THEN
GO TO 900
END IF
! PRINT *,'FI632 KPTR',(KPTR(I),I=1,16)
!
! IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION
!
IF (IAND(kpds(4),128) /= 0) THEN
CALL fi633(msga,kptr,kgds,kret)
IF(kret /= 0) THEN
GO TO 900
END IF
! PRINT *,'FI633 KPTR',(KPTR(I),I=1,16)
END IF
!
! EXTRACT OR GENERATE BIT MAP
!
CALL fi634(msga,kptr,kpds,kgds,kbms,kret)
IF(kret /= 0) THEN
GO TO 900
END IF
! PRINT *,'FI634 KPTR',(KPTR(I),I=1,16)
!
! USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
! EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
!
IF (kpds(18) == 1) THEN
CALL fi635(msga,kptr,kpds,kgds,kbms,DATA,kret)
IF (kptr(3) >= 50) THEN
!
! PDS GREATER THAN 28 BYTES
! THEREFORE SOMETHING SPECIAL IS GOING ON
!
! IN THIS CASE 2ND DIFFERENCE PACKING
! NEEDS TO BE UNDONE.
!
! EXTRACT FIRST VALUE FROM BYTE 41-44 PDS
! KPTR(9) CONTAINS OFFSET TO START OF
! GRIB MESSAGE.
! EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS
!
! AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E
! THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING
! AND PLACED IN PDS BYTES 49-51
! FACTOR IS A SIGNED TWO BYTE INTEGER
!
! ALSO NEED THE DECIMAL SCALING FROM PDS(27-28)
! (AVAILABLE IN KPDS(22) FROM UNPACKER)
! TO UNDO THE DECIMAL SCALING APPLIED TO THE
! SECOND DIFFERENCES DURING UNPACKING.
! SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE
! BUT UNPACKER DOESNT KNOW THAT.
!
! CALL GRBGBYTE (MSGA,FVAL1,KPTR(9)+384,32)
!
! NOTE INTEGERS, CHARACTERS AND EQUIVALENCES
! DEFINED ABOVE TO MAKE THIS KKK EXTRACTION
! WORK AND LINE UP ON WORD BOUNDARIES
!
CALL grbgbyte (msga,kkk,kptr(9)+384,32)
!
! THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
! TO THE FLOATING POINT USED ON YOUR MACHINE.
!
! 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE
! LW = 4 OR 8; IF 8 MAY BE A CRAY
!
CALL w3fi01(lw)
IF (lw == 4) THEN
CALL grbgbyte (kk,jsgn,0,1)
CALL grbgbyte (kk,jexp,1,7)
CALL grbgbyte (kk,ifr,8,24)
ELSE
CALL grbgbyte (kk,jsgn,32,1)
CALL grbgbyte (kk,jexp,33,7)
CALL grbgbyte (kk,ifr,40,24)
END IF
!
IF (ifr == 0) THEN
realkk = 0.0
ELSE IF (jexp == 0.AND.ifr == 0) THEN
realkk = 0.0
ELSE
realkk = FLOAT(ifr) * 16.0 ** (jexp - 64 - 6)
IF (jsgn /= 0) realkk = -realkk
END IF
fval1 = realkk
!
! CALL GRBGBYTE (MSGA,FDIFF1,KPTR(9)+416,32)
! (REPLACED BY FOLLOWING EXTRACTION)
!
CALL grbgbyte (msga,kkk,kptr(9)+416,32)
!
! THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
! TO THE FLOATING POINT USED ON YOUR MACHINE.
!
! 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE
! LW = 4 OR 8; IF 8 MAY BE A CRAY
!
CALL w3fi01(lw)
IF (lw == 4) THEN
CALL grbgbyte (kk,jsgn,0,1)
CALL grbgbyte (kk,jexp,1,7)
CALL grbgbyte (kk,ifr,8,24)
ELSE
CALL grbgbyte (kk,jsgn,32,1)
CALL grbgbyte (kk,jexp,33,7)
CALL grbgbyte (kk,ifr,40,24)
END IF
!
IF (ifr == 0) THEN
realkk = 0.0
ELSE IF (jexp == 0.AND.ifr == 0) THEN
realkk = 0.0
ELSE
realkk = FLOAT(ifr) * 16.0 ** (jexp - 64 - 6)
IF (jsgn /= 0) realkk = -realkk
END IF
fdiff1 = realkk
!
CALL grbgbyte (msga,ISIGN,kptr(9)+448,1)
CALL grbgbyte (msga,iscal2,kptr(9)+449,15)
IF(ISIGN > 0) THEN
iscal2 = - iscal2
END IF
! PRINT *,'DELTA POINT 1-',FVAL1
! PRINT *,'DELTA POINT 2-',FDIFF1
! PRINT *,'DELTA POINT 3-',ISCAL2
npts = kptr(10)
! WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/,
! & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
! PRINT *,'DELTA POINT 4-',KPDS(22)
CALL w3fi83 (DATA,npts,fval1,fdiff1, &
iscal2,kpds(22),kpds,kgds)
! WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '',
! & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS)
! WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/,
! & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS)
END IF
ELSE
PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',kpds(18)
kret = 7
END IF
!
900 RETURN
END SUBROUTINE w3fi63
SUBROUTINE fi631(msga,kptr,kpds,kret) 1,10
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI631 FIND 'GRIB' CHARS & RESET POINTERS
! PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT
! BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND
! BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY
! PLACES TERMINATOR '7777' AT THE CORRECT LOCATION.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
!
! USAGE: CALL FI631(MSGA,KPTR,KPDS,KRET)
! INPUT ARGUMENT LIST:
! MSGA - GRIB FIELD - "GRIB" THRU "7777"
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS
! (15) - NR UNUSED BITS AT END OF SECTION 4
!
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! KPDS - ARRAY CONTAINING PDS ELEMENTS.
! (1) - ID OF CENTER
! (2) - MODEL IDENTIFICATION
! (3) - GRID IDENTIFICATION
! (4) - GDS/BMS FLAG
! (5) - INDICATOR OF PARAMETER
! (6) - TYPE OF LEVEL
! (7) - HEIGHT/PRESSURE , ETC OF LEVEL
! (8) - YEAR OF CENTURY
! (9) - MONTH OF YEAR
! (10) - DAY OF MONTH
! (11) - HOUR OF DAY
! (12) - MINUTE OF HOUR
! (13) - INDICATOR OF FORECAST TIME UNIT
! (14) - TIME RANGE 1
! (15) - TIME RANGE 2
! (16) - TIME RANGE FLAG
! (17) - NUMBER INCLUDED IN AVERAGE
! KPTR - SEE INPUT LIST
! KRET - ERROR RETURN
!
! REMARKS:
! ERROR RETURNS
! KRET = 1 - NO 'GRIB'
! 2 - NO '7777' OR MISLOCATED (BY COUNTS)
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
!
! INCOMING MESSAGE HOLDER
CHARACTER :: msga(*)
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kptr(*)
! PRODUCT DESCRIPTION SECTION DATA.
INTEGER :: kpds(*)
!
INTEGER :: kret
!
! ******************************************************************
SAVE
kret = 0
! ------------------- FIND 'GRIB' KEY
DO i = 0, 839, 8
CALL grbgbyte (msga,mgrib,i,32)
IF (mgrib == 1196575042) THEN
kptr(9) = i
GO TO 60
END IF
END DO
kret = 1
RETURN
60 CONTINUE
! -------------FOUND 'GRIB'
! SKIP GRIB CHARACTERS
! PRINT *,'FI631 GRIB AT',I
kptr(8) = kptr(9) + 32
CALL grbgbyte (msga,itotal,kptr(8),24)
! HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT
ipoint = kptr(9) + itotal * 8 - 32
CALL grbgbyte (msga,i7777,ipoint,32)
IF (i7777 == 926365495) THEN
! HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION
! MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER
! PRINT *,'FI631 7777 AT',IPOINT
kptr(8) = kptr(8) + 24
kptr(1) = itotal
kptr(2) = 8
CALL grbgbyte (msga,kpds(18),kptr(8),8)
kptr(8) = kptr(8) + 8
ELSE
! CANNOT FIND END OF GRIB EDITION 1 MESSAGE
kret = 2
RETURN
END IF
! ------------------- PROCESS SECTION 1
! EXTRACT COUNT FROM PDS
! PRINT *,'START OF PDS',KPTR(8)
CALL grbgbyte (msga,kptr(3),kptr(8),24)
look = kptr(8) + 56
! EXTRACT GDS/BMS FLAG
CALL grbgbyte (msga,kpds(4),look,8)
kptr(8) = kptr(8) + kptr(3) * 8
! PRINT *,'START OF GDS',KPTR(8)
IF (IAND(kpds(4),128) /= 0) THEN
! EXTRACT COUNT FROM GDS
CALL grbgbyte (msga,kptr(4),kptr(8),24)
kptr(8) = kptr(8) + kptr(4) * 8
ELSE
kptr(4) = 0
END IF
! PRINT *,'START OF BMS',KPTR(8)
IF (IAND(kpds(4),64) /= 0) THEN
! EXTRACT COUNT FROM BMS
CALL grbgbyte (msga,kptr(5),kptr(8),24)
ELSE
kptr(5) = 0
END IF
kptr(8) = kptr(8) + kptr(5) * 8
! PRINT *,'START OF BDS',KPTR(8)
! EXTRACT COUNT FROM BDS
CALL grbgbyte (msga,kptr(6),kptr(8),24)
! --------------- TEST FOR '7777'
! PRINT *,(KPTR(KJ),KJ=1,10)
kptr(8) = kptr(8) + kptr(6) * 8
! EXTRACT FOUR BYTES FROM THIS LOCATION
! PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8)
CALL grbgbyte (msga,k7777,kptr(8),32)
match = kptr(2) + kptr(3) + kptr(4) + kptr(5) + kptr(6) + 4
IF (k7777 /= 926365495.OR.match /= kptr(1)) THEN
kret = 2
ELSE
! PRINT *,'FI631 7777 AT',KPTR(8)
IF (kpds(18) == 0) THEN
kptr(1) = kptr(2) + kptr(3) + kptr(4) + kptr(5) + &
kptr(6) + 4
END IF
END IF
! PRINT *,'KPTR',(KPTR(I),I=1,16)
RETURN
END SUBROUTINE fi631
SUBROUTINE fi632(msga,kptr,kpds,kret) 1,24
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI632 GATHER INFO FROM PRODUCT DEFINITION SEC
! PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION
! SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE
! IN OFFICE NOTE 84 FORMAT.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
! 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD
! OF VERSION NUMBER
!
! USAGE: CALL FI632(MSGA,KPTR,KPDS,KRET)
! INPUT ARGUMENT LIST:
! MSGA - ARRAY CONTAINING GRIB MESSAGE
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS
! (15) - NR UNUSED BITS AT END OF SECTION 4
!
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! KPDS - ARRAY CONTAINING PDS ELEMENTS.
! (1) - ID OF CENTER
! (2) - MODEL IDENTIFICATION
! (3) - GRID IDENTIFICATION
! (4) - GDS/BMS FLAG
! (5) - INDICATOR OF PARAMETER
! (6) - TYPE OF LEVEL
! (7) - HEIGHT/PRESSURE , ETC OF LEVEL
! (8) - YEAR OF CENTURY
! (9) - MONTH OF YEAR
! (10) - DAY OF MONTH
! (11) - HOUR OF DAY
! (12) - MINUTE OF HOUR
! (13) - INDICATOR OF FORECAST TIME UNIT
! (14) - TIME RANGE 1
! (15) - TIME RANGE 2
! (16) - TIME RANGE FLAG
! (17) - NUMBER INCLUDED IN AVERAGE
! (18) -
! (19) -
! (20) - NUMBER MISSING FROM AVGS/ACCUMULATIONS
! (21) - CENTURY
! (22) - UNITS DECIMAL SCALE FACTOR
! (23) - SUBCENTER
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! SEE INPUT LIST
! KRET - ERROR RETURN
!
! REMARKS:
! ERROR RETURN = 0 - NO ERRORS
! = 8 - TEMP GDS INDICATED, BUT NO GDS
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
!
! INCOMING MESSAGE HOLDER
CHARACTER :: msga(*)
!
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kptr(*)
! PRODUCT DESCRIPTION SECTION ENTRIES
INTEGER :: kpds(*)
!
INTEGER :: kret
! ------------------- PROCESS SECTION 1
SAVE
kptr(8) = kptr(9) + kptr(2) * 8 + 24
! BYTE 4
! PARAMETER TABLE VERSION NR
CALL grbgbyte (msga,kpds(19),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 5 IDENTIFICATION OF CENTER
CALL grbgbyte (msga,kpds(1),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 6
! GET GENERATING PROCESS ID NR
CALL grbgbyte (msga,kpds(2),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 7
! GRID DEFINITION
CALL grbgbyte (msga,kpds(3),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 8
! GDS/BMS FLAGS
! CALL GRBGBYTE (MSGA,KPDS(4),KPTR(8),8)
kptr(8) = kptr(8) + 8
! BYTE 9
! INDICATOR OF PARAMETER
CALL grbgbyte (msga,kpds(5),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 10
! TYPE OF LEVEL
CALL grbgbyte (msga,kpds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 11,12
! HEIGHT/PRESSURE
CALL grbgbyte (msga,kpds(7),kptr(8),16)
kptr(8) = kptr(8) + 16
! BYTE 13
! YEAR OF CENTURY
CALL grbgbyte (msga,kpds(8),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 14
! MONTH OF YEAR
CALL grbgbyte (msga,kpds(9),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 15
! DAY OF MONTH
CALL grbgbyte (msga,kpds(10),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 16
! HOUR OF DAY
CALL grbgbyte (msga,kpds(11),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 17
! MINUTE
CALL grbgbyte (msga,kpds(12),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 18
! INDICATOR TIME UNIT RANGE
CALL grbgbyte (msga,kpds(13),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 19
! P1 - PERIOD OF TIME
CALL grbgbyte (msga,kpds(14),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 20
! P2 - PERIOD OF TIME
CALL grbgbyte (msga,kpds(15),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 21
! TIME RANGE INDICATOR
CALL grbgbyte (msga,kpds(16),kptr(8),8)
kptr(8) = kptr(8) + 8
!
! IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN
! PDS BYTES 19-20
!
IF (kpds(16) == 10) THEN
kpds(14) = kpds(14) * 256 + kpds(15)
kpds(15) = 0
END IF
! BYTE 22,23
! NUMBER INCLUDED IN AVERAGE
CALL grbgbyte (msga,kpds(17),kptr(8),16)
kptr(8) = kptr(8) + 16
! BYTE 24
! NUMBER MISSING FROM AVERAGES/ACCUMULATIONS
CALL grbgbyte (msga,kpds(20),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 25
! IDENTIFICATION OF CENTURY
CALL grbgbyte (msga,kpds(21),kptr(8),8)
kptr(8) = kptr(8) + 8
IF (kptr(3) > 25) THEN
! BYTE 26 SUB CENTER NUMBER
CALL grbgbyte (msga,kpds(23),kptr(8),8)
kptr(8) = kptr(8) + 8
IF (kptr(3) >= 28) THEN
! BYTE 27-28
! UNITS DECIMAL SCALE FACTOR
CALL grbgbyte (msga,ISIGN,kptr(8),1)
kptr(8) = kptr(8) + 1
CALL grbgbyte (msga,idec,kptr(8),15)
kptr(8) = kptr(8) + 15
IF (ISIGN > 0) THEN
kpds(22) = - idec
ELSE
kpds(22) = idec
END IF
isiz = kptr(3) - 28
IF (isiz <= 12) THEN
! BYTES 29-40 CURRENTLY RESERVED FOR FUTURE USE
kptr(8) = kptr(8) + isiz * 8
ELSE
! BYTES 29-40 CURRENTLY RESERVED FOR FUTURE USE
kptr(8) = kptr(8) + 12 * 8
! BYTES 40 - N LOCAL USE DATA
CALL w3fi01(lw)
mwdbit = lw * 8
isiz = kptr(3) - 40
iter = isiz / lw
CALL grbgbytes (msga,kpds(36),kptr(8),mwdbit,0,iter)
kptr(8) = kptr(8) + isiz * 8
END IF
END IF
END IF
! ----------- TEST FOR NEW GRID
IF (IAND(kpds(4),128) /= 0) THEN
IF (IAND(kpds(4),64) /= 0) THEN
IF (kpds(3) /= 255) THEN
IF (kpds(3) >= 21.AND.kpds(3) <= 26)THEN
RETURN
ELSE IF (kpds(3) >= 37.AND.kpds(3) <= 44)THEN
RETURN
ELSE IF (kpds(3) >= 61.AND.kpds(3) <= 64) THEN
RETURN
END IF
IF (kpds(1) == 7) THEN
IF (kpds(3) >= 2.AND.kpds(3) <= 3)THEN
ELSE IF (kpds(3) >= 5.AND.kpds(3) <= 6)THEN
ELSE IF (kpds(3) >= 27.AND.kpds(3) <= 34)THEN
ELSE IF (kpds(3) == 50) THEN
ELSE IF (kpds(3) >= 70.AND.kpds(3) <= 77) THEN
ELSE IF (kpds(3) >= 100.AND.kpds(3) <= 105) THEN
ELSE IF (kpds(3) >= 201.AND.kpds(3) <= 214) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', &
' NMC WITHOUT A GRID DESCRIPTION SECTION'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (kpds(1) == 98) THEN
IF (kpds(3) >= 1.AND.kpds(3) <= 16) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', &
' ECMWF WITHOUT A GRID DESCRIPTION SECTION'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (kpds(1) == 74) THEN
IF (kpds(3) >= 1.AND.kpds(3) <= 12) THEN
ELSE IF (kpds(3) >= 21.AND.kpds(3) <= 26)THEN
ELSE IF (kpds(3) >= 61.AND.kpds(3) <= 64) THEN
ELSE IF (kpds(3) >= 70.AND.kpds(3) <= 77) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', &
' U.K. MET OFFICE, BRACKNELL', &
' WITHOUT A GRID DESCRIPTION SECTION'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (kpds(1) == 58) THEN
IF (kpds(3) >= 1.AND.kpds(3) <= 12) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', &
' FNOC WITHOUT A GRID DESCRIPTION SECTION'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
END IF
END IF
END IF
END IF
RETURN
END SUBROUTINE fi632
SUBROUTINE fi633(msga,kptr,kgds,kret) 1,58
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI633 EXTRACT INFO FROM GRIB-GDS
! PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW
! CONVERSION TO OFFICE NOTE 84 FORMAT.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
!
! USAGE: CALL FI633(MSGA,KPTR,KGDS,KRET)
! INPUT ARGUMENT LIST:
! MSGA - ARRAY CONTAINING GRIB MESSAGE
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS
! (15) - NR UNUSED BITS AT END OF SECTION 4
!
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! KGDS - ARRAY CONTAINING GDS ELEMENTS.
! (1) - DATA REPRESENTATION TYPE
! (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS
! (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE
! PARAMETERS
! OR
! OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS
! IN EACH ROW
! OR
! 255 IF NEITHER ARE PRESENT
! (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID
! (22) - NUMBER OF WORDS IN EACH ROW
! LATITUDE/LONGITUDE GRIDS
! (2) - N(I) NR POINTS ON LATITUDE CIRCLE
! (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG
! (7) - LA(2) LATITUDE OF EXTREME POINT
! (8) - LO(2) LONGITUDE OF EXTREME POINT
! (9) - DI LATITUDINAL DIRECTION OF INCREMENT
! (10) - DJ LONGITUDINAL DIRECTION INCREMENT
! (11) - SCANNING MODE FLAG
! POLAR STEREOGRAPHIC GRIDS
! (2) - N(I) NR POINTS ALONG LAT CIRCLE
! (3) - N(J) NR POINTS ALONG LON CIRCLE
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESERVED
! (7) - LOV GRID ORIENTATION
! (8) - DX - X DIRECTION INCREMENT
! (9) - DY - Y DIRECTION INCREMENT
! (10) - PROJECTION CENTER FLAG
! (11) - SCANNING MODE
! SPHERICAL HARMONIC COEFFICIENTS
! (2) - J PENTAGONAL RESOLUTION PARAMETER
! (3) - K " " "
! (4) - M " " "
! (5) - REPRESENTATION TYPE
! (6) - COEFFICIENT STORAGE MODE
! MERCATOR GRIDS
! (2) - N(I) NR POINTS ON LATITUDE CIRCLE
! (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
! (4) - LA(1) LATITUDE OF ORIGIN
! (5) - LO(1) LONGITUDE OF ORIGIN
! (6) - RESOLUTION FLAG
! (7) - LA(2) LATITUDE OF LAST GRID POINT
! (8) - LO(2) LONGITUDE OF LAST GRID POINT
! (9) - LATIN - LATITUDE OF PROJECTION INTERSECTION
! (10) - RESERVED
! (11) - SCANNING MODE FLAG
! (12) - LONGITUDINAL DIR GRID LENGTH
! (13) - LATITUDINAL DIR GRID LENGTH
! LAMBERT CONFORMAL GRIDS
! (2) - NX NR POINTS ALONG X-AXIS
! (3) - NY NR POINTS ALONG Y-AXIS
! (4) - LA1 LAT OF ORIGIN (LOWER LEFT)
! (5) - LO1 LON OF ORIGIN (LOWER LEFT)
! (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17)
! (7) - LOV - ORIENTATION OF GRID
! (8) - DX - X-DIR INCREMENT
! (9) - DY - Y-DIR INCREMENT
! (10) - PROJECTION CENTER FLAG
! (11) - SCANNING MODE FLAG
! (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
! (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! SEE INPUT LIST
! KRET - ERROR RETURN
!
! REMARKS:
! KRET = 0
! = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
! ************************************************************
! INCOMING MESSAGE HOLDER
CHARACTER :: msga(*)
!
! ARRAY GDS ELEMENTS
INTEGER :: kgds(*)
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kptr(*)
!
INTEGER :: kret
! ---------------------------------------------------------------
SAVE
kret = 0
! PROCESS GRID DEFINITION SECTION (IF PRESENT)
! MAKE SURE BIT POINTER IS PROPERLY SET
kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + 24
nsave = kptr(8) - 24
! BYTE 4
! NV - NR OF VERT COORD PARAMETERS
CALL grbgbyte (msga,kgds(19),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 5
! PV - LOCATION - SEE FM92 MANUAL
CALL grbgbyte (msga,kgds(20),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTE 6
! DATA REPRESENTATION TYPE
CALL grbgbyte (msga,kgds(1),kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTES 7-32 ARE GRID DEFINITION DEPENDING ON
! DATA REPRESENTATION TYPE
IF (kgds(1) == 0) THEN
GO TO 1000
ELSE IF (kgds(1) == 1) THEN
GO TO 4000
ELSE IF (kgds(1) == 2.OR.kgds(1) == 5) THEN
GO TO 2000
ELSE IF (kgds(1) == 3) THEN
GO TO 5000
ELSE IF (kgds(1) == 4) THEN
GO TO 1000
! ELSE IF (KGDS(1).EQ.10) THEN
! ELSE IF (KGDS(1).EQ.14) THEN
! ELSE IF (KGDS(1).EQ.20) THEN
! ELSE IF (KGDS(1).EQ.24) THEN
! ELSE IF (KGDS(1).EQ.30) THEN
! ELSE IF (KGDS(1).EQ.34) THEN
ELSE IF (kgds(1) == 50) THEN
GO TO 3000
! ELSE IF (KGDS(1).EQ.60) THEN
! ELSE IF (KGDS(1).EQ.70) THEN
! ELSE IF (KGDS(1).EQ.80) THEN
ELSE
! MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
kret = 4
RETURN
END IF
! BYTE 33-N VERTICAL COORDINATE PARAMETERS
! -----------
! BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION
! OR STRETCHING OF THE COORDINATE SYSTEM OR
! LAMBERT CONFORMAL PROJECTION.
! BYTE 43-N VERTICAL COORDINATE PARAMETERS
! -----------
! BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED
! AND ROTATED COORDINATE SYSTEM
! BYTE 53-N VERTICAL COORDINATE PARAMETERS
! -----------
! ************************************************************
! ------------------- LATITUDE/LONGITUDE GRIDS
!
! ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1000 CONTINUE
CALL grbgbyte (msga,kgds(2),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
CALL grbgbyte (msga,kgds(3),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 11-13 LATITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(4),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(4),8388608) /= 0) THEN
kgds(4) = IAND(kgds(4),8388607) * (-1)
END IF
! ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(5),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(5),8388608) /= 0) THEN
kgds(5) = - IAND(kgds(5),8388607)
END IF
! ------------------- BYTE 17 RESOLUTION FLAG
CALL grbgbyte (msga,kgds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
CALL grbgbyte (msga,kgds(7),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(7),8388608) /= 0) THEN
kgds(7) = - IAND(kgds(7),8388607)
END IF
! ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
CALL grbgbyte (msga,kgds(8),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(8),8388608) /= 0) THEN
kgds(8) = - IAND(kgds(8),8388607)
END IF
! ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
CALL grbgbyte (msga,kgds(9),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
! HAVE LONGIT DIR INCREMENT
! ELSE IF GAUSSIAN GRID
! HAVE NR OF LAT CIRCLES
! BETWEEN POLE AND EQUATOR
CALL grbgbyte (msga,kgds(10),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 28 SCANNING MODE FLAGS
CALL grbgbyte (msga,kgds(11),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 29-32 RESERVED
! SKIP TO START OF BYTE 33
CALL grbgbyte (msga,kgds(12),kptr(8),32)
kptr(8) = kptr(8) + 32
! -------------------
GO TO 900
! ******************************************************************
! ' POLAR STEREO PROCESSING '
!
! ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
2000 CONTINUE
CALL grbgbyte (msga,kgds(2),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
CALL grbgbyte (msga,kgds(3),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 11-13 LATITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(4),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(4),8388608) /= 0) THEN
kgds(4) = - IAND(kgds(4),8388607)
END IF
! ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(5),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(5),8388608) /= 0) THEN
kgds(5) = - IAND(kgds(5),8388607)
END IF
! ------------------- BYTE 17 RESERVED
CALL grbgbyte (msga,kgds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
CALL grbgbyte (msga,kgds(7),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(7),8388608) /= 0) THEN
kgds(7) = - IAND(kgds(7),8388607)
END IF
! ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
CALL grbgbyte (msga,kgds(8),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(8),8388608) /= 0) THEN
kgds(8) = - IAND(kgds(8),8388607)
END IF
! ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
CALL grbgbyte (msga,kgds(9),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(9),8388608) /= 0) THEN
kgds(9) = - IAND(kgds(9),8388607)
END IF
! ------------------- BYTE 27 PROJECTION CENTER FLAG
CALL grbgbyte (msga,kgds(10),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 28 SCANNING MODE
CALL grbgbyte (msga,kgds(11),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 29-32 RESERVED
! SKIP TO START OF BYTE 33
CALL grbgbyte (msga,kgds(12),kptr(8),32)
kptr(8) = kptr(8) + 32
!
! -------------------
GO TO 900
!
! ******************************************************************
! ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
!
! ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
3000 CONTINUE
CALL grbgbyte (msga,kgds(2),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
CALL grbgbyte (msga,kgds(3),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
CALL grbgbyte (msga,kgds(4),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 13 REPRESENTATION TYPE
CALL grbgbyte (msga,kgds(5),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 14 COEFFICIENT STORAGE MODE
CALL grbgbyte (msga,kgds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- EMPTY FIELDS - BYTES 15 - 32
! SET TO START OF BYTE 33
kptr(8) = kptr(8) + 18 * 8
GO TO 900
! ******************************************************************
! PROCESS MERCATOR GRIDS
!
! ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
4000 CONTINUE
CALL grbgbyte (msga,kgds(2),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
CALL grbgbyte (msga,kgds(3),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 11-13 LATITUE OF ORIGIN
CALL grbgbyte (msga,kgds(4),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(4),8388608) /= 0) THEN
kgds(4) = - IAND(kgds(4),8388607)
END IF
! ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(5),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(5),8388608) /= 0) THEN
kgds(5) = - IAND(kgds(5),8388607)
END IF
! ------------------- BYTE 17 RESOLUTION FLAG
CALL grbgbyte (msga,kgds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
CALL grbgbyte (msga,kgds(7),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(7),8388608) /= 0) THEN
kgds(7) = - IAND(kgds(7),8388607)
END IF
! ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
CALL grbgbyte (msga,kgds(8),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(8),8388608) /= 0) THEN
kgds(8) = - IAND(kgds(8),8388607)
END IF
! ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION
CALL grbgbyte (msga,kgds(9),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(9),8388608) /= 0) THEN
kgds(9) = - IAND(kgds(9),8388607)
END IF
! ------------------- BYTE 27 RESERVED
CALL grbgbyte (msga,kgds(10),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 28 SCANNING MODE
CALL grbgbyte (msga,kgds(11),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT
CALL grbgbyte (msga,kgds(12),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(12),8388608) /= 0) THEN
kgds(12) = - IAND(kgds(12),8388607)
END IF
! ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT
CALL grbgbyte (msga,kgds(13),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(13),8388608) /= 0) THEN
kgds(13) = - IAND(kgds(13),8388607)
END IF
! ------------------- BYTE 35-42 RESERVED
! SKIP TO START OF BYTE 43
kptr(8) = kptr(8) + 8 * 8
! -------------------
GO TO 900
! ******************************************************************
! PROCESS LAMBERT CONFORMAL
!
! ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
5000 CONTINUE
CALL grbgbyte (msga,kgds(2),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
CALL grbgbyte (msga,kgds(3),kptr(8),16)
kptr(8) = kptr(8) + 16
! ------------------- BYTE 11-13 LATITUDE OF ORIGIN
CALL grbgbyte (msga,kgds(4),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(4),8388608) /= 0) THEN
kgds(4) = - IAND(kgds(4),8388607)
END IF
! ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
CALL grbgbyte (msga,kgds(5),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(5),8388608) /= 0) THEN
kgds(5) = - IAND(kgds(5),8388607)
END IF
! ------------------- BYTE 17 RESOLUTION
CALL grbgbyte (msga,kgds(6),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
CALL grbgbyte (msga,kgds(7),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(7),8388608) /= 0) THEN
kgds(7) = - IAND(kgds(7),8388607)
END IF
! ------------------- BYTE 21-23 DX - X-DIR INCREMENT
CALL grbgbyte (msga,kgds(8),kptr(8),24)
kptr(8) = kptr(8) + 24
! ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
CALL grbgbyte (msga,kgds(9),kptr(8),24)
kptr(8) = kptr(8) + 24
! ------------------- BYTE 27 PROJECTION CENTER FLAG
CALL grbgbyte (msga,kgds(10),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 28 SCANNING MODE
CALL grbgbyte (msga,kgds(11),kptr(8),8)
kptr(8) = kptr(8) + 8
! ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
CALL grbgbyte (msga,kgds(12),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(12),8388608) /= 0) THEN
kgds(12) = - IAND(kgds(12),8388607)
END IF
! ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
CALL grbgbyte (msga,kgds(13),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(13),8388608) /= 0) THEN
kgds(13) = - IAND(kgds(13),8388607)
END IF
! ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE
CALL grbgbyte (msga,kgds(14),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(14),8388608) /= 0) THEN
kgds(14) = - IAND(kgds(14),8388607)
END IF
! ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE
CALL grbgbyte (msga,kgds(15),kptr(8),24)
kptr(8) = kptr(8) + 24
IF (IAND(kgds(15),8388608) /= 0) THEN
kgds(15) = - IAND(kgds(15),8388607)
END IF
! ------------------- BYTE 41-42 RESERVED
CALL grbgbyte (msga,kgds(16),kptr(8),16)
kptr(8) = kptr(8) + 16
! -------------------
900 CONTINUE
!
! MORE CODE FOR GRIDS WITH PL
!
IF (kgds(19) == 0.AND.kgds(20) /= 255) THEN
isum = 0
kptr(8) = nsave + (kgds(20) - 1) * 8
CALL grbgbytes (msga,kgds(22),kptr(8),16,0,kgds(3))
DO j = 1, kgds(3)
isum = isum + kgds(21+j)
END DO
kgds(21) = isum
END IF
RETURN
END SUBROUTINE fi633
SUBROUTINE fi634(msga,kptr,kpds,kgds,kbms,kret) 1,17
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI634 EXTRACT OR GENERATE BIT MAP FOR OUTPUT
! PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT
! FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
! 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5 - 8.
!
! USAGE: CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
! INPUT ARGUMENT LIST:
! MSGA - BUFR MESSAGE
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS
! (15) - NR UNUSED BITS AT END OF SECTION 4
! KPDS - ARRAY CONTAINING PDS ELEMENTS.
! (1) - ID OF CENTER
! (2) - MODEL IDENTIFICATION
! (3) - GRID IDENTIFICATION
! (4) - GDS/BMS FLAG
! (5) - INDICATOR OF PARAMETER
! (6) - TYPE OF LEVEL
! (7) - HEIGHT/PRESSURE , ETC OF LEVEL
! (8) - YEAR OF CENTURY
! (9) - MONTH OF YEAR
! (10) - DAY OF MONTH
! (11) - HOUR OF DAY
! (12) - MINUTE OF HOUR
! (13) - INDICATOR OF FORECAST TIME UNIT
! (14) - TIME RANGE 1
! (15) - TIME RANGE 2
! (16) - TIME RANGE FLAG
! (17) - NUMBER INCLUDED IN AVERAGE
!
! OUTPUT ARGUMENT LIST:
! KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! SEE INPUT LIST
! KRET - ERROR RETURN
!
! REMARKS:
! KRET = 0 - NO ERROR
! = 5 - GRID NOT AVAIL FOR CENTER INDICATED
! =10 - INCORRECT CENTER INDICATOR
! =12 - BYTES 5-6 ARE NOT ZERO IN BMS, PREDEFINED BIT MAP
! NOT PROVIDED BY THIS CENTER
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
!
! INCOMING MESSAGE HOLDER
CHARACTER :: msga(*)
!
! BIT MAP
LOGICAL*1 :: kbms(*)
!
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kptr(*)
! ARRAY OF POINTERS AND COUNTERS
INTEGER :: kpds(*)
INTEGER :: kgds(*)
!
INTEGER :: kret
INTEGER :: mask(8)
! ----------------------GRID 21 AND GRID 22 ARE THE SAME
LOGICAL*1 grd21( 1369)
! ----------------------GRID 23 AND GRID 24 ARE THE SAME
LOGICAL*1 grd23( 1369)
LOGICAL*1 grd25( 1368)
LOGICAL*1 grd26( 1368)
! ----------------------GRID 27 AND GRID 28 ARE THE SAME
! ----------------------GRID 29 AND GRID 30 ARE THE SAME
! ----------------------GRID 33 AND GRID 34 ARE THE SAME
LOGICAL*1 grd50( 1188)
! -----------------------GRID 61 AND GRID 62 ARE THE SAME
LOGICAL*1 grd61( 4186)
! -----------------------GRID 63 AND GRID 64 ARE THE SAME
LOGICAL*1 grd63( 4186)
! LOGICAL*1 GRD70(16380)/16380*.TRUE./
! -------------------------------------------------------------
SAVE
DATA grd21 /1333*.true.,36*.false./
DATA grd23 /.true.,36*.false.,1332*.true./
DATA grd25 /1297*.true.,71*.false./
DATA grd26 /.true.,71*.false.,1296*.true./
DATA grd50/ &
! LINE 1-4
7*.false.,22*.true.,14*.false.,22*.true., &
14*.false.,22*.true.,14*.false.,22*.true.,7*.false., &
! LINE 5-8
6*.false.,24*.true.,12*.false.,24*.true., &
12*.false.,24*.true.,12*.false.,24*.true.,6*.false., &
! LINE 9-12
5*.false.,26*.true.,10*.false.,26*.true., &
10*.false.,26*.true.,10*.false.,26*.true.,5*.false., &
! LINE 13-16
4*.false.,28*.true., 8*.false.,28*.true., &
8*.false.,28*.true., 8*.false.,28*.true.,4*.false., &
! LINE 17-20
3*.false.,30*.true., 6*.false.,30*.true., &
6*.false.,30*.true., 6*.false.,30*.true.,3*.false., &
! LINE 21-24
2*.false.,32*.true., 4*.false.,32*.true., &
4*.false.,32*.true., 4*.false.,32*.true.,2*.false., &
! LINE 25-28
.false.,34*.true., 2*.false.,34*.true., &
2*.false.,34*.true., 2*.false.,34*.true., .false., &
! LINE 29-33
180*.true./
DATA grd61 /4096*.true.,90*.false./
DATA grd63 /.true.,90*.false.,4095*.true./
DATA mask /128,64,32,16,8,4,2,1/
!
! PRINT *,'FI634'
IF (IAND(kpds(4),64) == 64) THEN
!
! SET UP BIT POINTER
! SECTION 0 SECTION 1 SECTION 2
kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) + 24
!
! BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3
!
CALL grbgbyte (msga,kptr(11),kptr(8),8)
kptr(8) = kptr(8) + 8
!
! BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS
!
CALL grbgbyte (msga,kptr(12),kptr(8),16)
kptr(8) = kptr(8) + 16
! IF TABLE REFERENCE = 0, EXTRACT BIT MAP
IF (kptr(12) == 0) THEN
! CALCULATE NR OF BITS IN BIT MAP
ibits = (kptr(5) - 6) * 8 - kptr(11)
kptr(10) = ibits
IF (kpds(3) == 21.OR.kpds(3) == 22.OR.kpds(3) == 25 &
.OR.kpds(3) == 61.OR.kpds(3) == 62) THEN
! NORTHERN HEMISPHERE 21, 22, 25, 61, 62
DO i = 1, ibits
CALL grbgbyte (msga,ichk,kptr(8),1)
kptr(8) = kptr(8) + 1
IF (ichk /= 0) THEN
kbms(i) = .true.
ELSE
kbms(i) = .false.
END IF
END DO
IF (kpds(3) == 25) THEN
kadd = 71
ELSE IF (kpds(3) == 61.OR.kpds(3) == 62) THEN
kadd = 90
ELSE
kadd = 36
END IF
DO i = 1, kadd
kbms(i+ibits) = .false.
END DO
kptr(10) = kptr(10) + kadd
RETURN
ELSE IF (kpds(3) == 23.OR.kpds(3) == 24.OR.kpds(3) == 26 &
.OR.kpds(3) == 63.OR.kpds(3) == 64) THEN
! SOUTHERN HEMISPHERE 23, 24, 26, 63, 64
IF (kpds(3) == 26) THEN
kadd = 72
ELSE IF (kpds(3) == 63.OR.kpds(3) == 64) THEN
kadd = 91
ELSE
kadd = 37
END IF
DO i = 1, kadd
kbms(i+ibits) = .false.
END DO
DO i = 1, ibits
CALL grbgbyte (msga,ichk,kptr(8),1)
kptr(8) = kptr(8) + 1
IF (ichk /= 0) THEN
kbms(i) = .true.
ELSE
kbms(i) = .false.
END IF
END DO
kptr(10) = kptr(10) + kadd - 1
RETURN
ELSE IF (kpds(3) == 50) THEN
kpad = 7
kin = 22
kbits = 0
DO i = 1, 7
DO j = 1, 4
DO k = 1, kpad
kbits = kbits + 1
kbms(kbits) = .false.
END DO
DO k = 1, kin
CALL grbgbyte (msga,ichk,kptr(8),1)
kptr(8) = kptr(8) + 1
kbits = kbits + 1
IF (ichk /= 0) THEN
kbms(kbits) = .true.
ELSE
kbms(kbits) = .false.
END IF
END DO
DO k = 1, kpad
kbits = kbits + 1
kbms(kbits) = .false.
END DO
END DO
kin = kin + 2
kpad = kpad - 1
END DO
DO ii = 1, 5
DO j = 1, kin
CALL grbgbyte (msga,ichk,kptr(8),1)
kptr(8) = kptr(8) + 1
kbits = kbits + 1
IF (ichk /= 0) THEN
kbms(kbits) = .true.
ELSE
kbms(kbits) = .false.
END IF
END DO
END DO
ELSE
! EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS
DO i = 1, ibits
CALL grbgbyte (msga,ichk,kptr(8),1)
kptr(8) = kptr(8) + 1
IF (ichk /= 0) THEN
kbms(i) = .true.
ELSE
kbms(i) = .false.
END IF
END DO
END IF
RETURN
ELSE
PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER'
kret = 12
RETURN
END IF
!
END IF
kret = 0
! -------------------------------------------------------
! PROCESS NON-STANDARD GRID
! -------------------------------------------------------
IF (kpds(3) == 255) THEN
PRINT *,'NON STANDARD GRID, CENTER = ',kpds(1)
j = kgds(2) * kgds(3)
kptr(10) = j
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
END IF
! -------------------------------------------------------
! CHECK INTERNATIONAL SET
! -------------------------------------------------------
IF (kpds(3) == 21.OR.kpds(3) == 22) THEN
! ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
j = 1369
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 1369
kbms(i) = grd21(i)
END DO
RETURN
ELSE IF (kpds(3) == 23.OR.kpds(3) == 24) THEN
! ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
j = 1369
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 1369
kbms(i) = grd23(i)
END DO
RETURN
ELSE IF (kpds(3) == 25) THEN
! ----- INT'L GRID 25 - MAP SIZE 1368
j = 1368
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 1368
kbms(i) = grd25(i)
END DO
RETURN
ELSE IF (kpds(3) == 26) THEN
! ----- INT'L GRID 26 - MAP SIZE 1368
j = 1368
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 1368
kbms(i) = grd26(i)
END DO
RETURN
ELSE IF (kpds(3) >= 37.AND.kpds(3) <= 44) THEN
! ----- INT'L GRID 37-44 - MAP SIZE 3447
j = 3447
GO TO 800
ELSE IF (kpds(1) == 7.AND.kpds(3) == 50) THEN
! ----- INT'L GRIDS 50 - MAP SIZE 964
j = 1188
kptr(10) = j
CALL fi637(*890,j,kpds,kgds,kret)
DO i = 1, j
kbms(i) = grd50(i)
END DO
RETURN
ELSE IF (kpds(3) == 61.OR.kpds(3) == 62) THEN
! ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
j = 4186
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 4186
kbms(i) = grd61(i)
END DO
RETURN
ELSE IF (kpds(3) == 63.OR.kpds(3) == 64) THEN
! ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
j = 4186
kptr(10) = j
CALL fi637(*820,j,kpds,kgds,kret)
DO i = 1, 4186
kbms(i) = grd63(i)
END DO
RETURN
END IF
! -------------------------------------------------------
! CHECK UNITED STATES SET
! -------------------------------------------------------
IF (kpds(1) == 7) THEN
IF (kpds(3) < 100) THEN
IF (kpds(3) == 1) THEN
! ----- U.S. GRID 1 - MAP SIZE 1679
j = 1679
GO TO 800
END IF
IF (kpds(3) == 2) THEN
! ----- U.S. GRID 2 - MAP SIZE 10512
j = 10512
GO TO 800
ELSE IF (kpds(3) == 3) THEN
! ----- U.S. GRID 3 - MAP SIZE 65160
j = 65160
GO TO 800
ELSE IF (kpds(3) == 5) THEN
! ----- U.S. GRID 5 - MAP SIZE 3021
j = 3021
GO TO 800
ELSE IF (kpds(3) == 6) THEN
! ----- U.S. GRID 6 - MAP SIZE 2385
j = 2385
GO TO 800
ELSE IF (kpds(3) == 27.OR.kpds(3) == 28) THEN
! ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
j = 4225
GO TO 800
ELSE IF (kpds(3) == 29.OR.kpds(3) == 30) THEN
! ----- U.S. GRIDS 29,30 - MAP SIZE 5365
j = 5365
GO TO 800
ELSE IF (kpds(3) == 33.OR.kpds(3) == 34) THEN
! ----- U.S GRID 33, 34 - MAP SIZE 8326
j = 8326
GO TO 800
ELSE IF (kpds(3) >= 37.AND.kpds(3) <= 44) THEN
! ----- U.S. GRID 37-44 - MAP SIZE 3447
j = 3447
GO TO 800
ELSE IF (kpds(3) == 45) THEN
! ----- U.S. GRID 45 - MAP SIZE 41760
j = 41760
GO TO 800
ELSE IF (kpds(3) == 55.OR.kpds(3) == 56) THEN
! ----- U.S GRID 55, 56 - MAP SIZE 6177
j = 6177
GO TO 800
ELSE IF (kpds(3) >= 67.AND.kpds(3) <= 71) THEN
! ----- U.S GRID 67-71 - MAP SIZE 13689
j = 13689
GO TO 800
ELSE IF (kpds(3) == 72) THEN
! ----- U.S GRID 72 - MAP SIZE 406
j = 406
GO TO 800
ELSE IF (kpds(3) == 73) THEN
! ----- U.S GRID 73 - MAP SIZE 13056
j = 13056
GO TO 800
ELSE IF (kpds(3) == 74) THEN
! ----- U.S GRID 74 - MAP SIZE 10800
j = 10800
GO TO 800
ELSE IF (kpds(3) >= 75.AND.kpds(3) <= 77) THEN
! ----- U.S GRID 75-77 - MAP SIZE 12321
j = 12321
GO TO 800
ELSE IF (kpds(3) == 85.OR.kpds(3) == 86) THEN
! ----- U.S GRID 85,86 - MAP SIZE 32400
j = 32400
GO TO 800
ELSE IF (kpds(3) == 87) THEN
! ----- U.S GRID 87 - MAP SIZE 5022
j = 5022
GO TO 800
ELSE IF (kpds(3) == 90) THEN
! ----- U.S GRID 90 - MAP SIZE 12902
j = 12902
GO TO 800
ELSE IF (kpds(3) == 91) THEN
! ----- U.S GRID 91 - MAP SIZE 25803
j = 25803
GO TO 800
ELSE IF (kpds(3) == 92) THEN
! ----- U.S GRID 92 - MAP SIZE 24162
j = 24162
GO TO 800
ELSE IF (kpds(3) == 93) THEN
! ----- U.S GRID 93 - MAP SIZE 48323
j = 48323
GO TO 800
ELSE IF (kpds(3) == 94) THEN
! ----- U.S GRID 94 - MAP SIZE XXXXX
j = 48916
GO TO 800
ELSE IF (kpds(3) == 95) THEN
! ----- U.S GRID 95 - MAP SIZE XXXXX
j = 97831
GO TO 800
END IF
ELSE IF (kpds(3) >= 100.AND.kpds(3) < 200) THEN
IF (kpds(3) == 100) THEN
! ----- U.S. GRID 100 - MAP SIZE 6889
j = 6889
GO TO 800
ELSE IF (kpds(3) == 101) THEN
! ----- U.S. GRID 101 - MAP SIZE 10283
j = 10283
GO TO 800
ELSE IF (kpds(3) == 103) THEN
! ----- U.S. GRID 103 - MAP SIZE 3640
j = 3640
GO TO 800
ELSE IF (kpds(3) == 104) THEN
! ----- U.S. GRID 104 - MAP SIZE 16170
j = 16170
GO TO 800
ELSE IF (kpds(3) == 105) THEN
! ----- U.S. GRID 105 - MAP SIZE 6889
j = 6889
GO TO 800
ELSE IF (kpds(3) == 106) THEN
! ----- U.S. GRID 106 - MAP SIZE 19305
j = 19305
GO TO 800
ELSE IF (kpds(3) == 107) THEN
! ----- U.S. GRID 107 - MAP SIZE 11040
j = 11040
GO TO 800
ELSE IF (IAND(kpds(4),128) == 128) THEN
! ----- U.S. NON-STANDARD GRID
GO TO 895
END IF
ELSE IF (kpds(3) >= 200) THEN
IF (kpds(3) == 201) THEN
j = 4225
GO TO 800
ELSE IF (kpds(3) == 202) THEN
j = 2795
GO TO 800
ELSE IF (kpds(3) == 203.OR.kpds(3) == 205) THEN
j = 1755
GO TO 800
ELSE IF (kpds(3) == 204) THEN
j = 6324
GO TO 800
ELSE IF (kpds(3) == 206) THEN
j = 2091
GO TO 800
ELSE IF (kpds(3) == 207) THEN
j = 1715
GO TO 800
ELSE IF (kpds(3) == 208) THEN
j = 783
GO TO 800
ELSE IF (kpds(3) == 209) THEN
j = 8181
GO TO 800
ELSE IF (kpds(3) == 210) THEN
j = 625
GO TO 800
ELSE IF (kpds(3) == 211) THEN
j = 6045
GO TO 800
ELSE IF (kpds(3) == 212) THEN
j = 23865
GO TO 800
ELSE IF (kpds(3) == 213) THEN
j = 10965
GO TO 800
ELSE IF (kpds(3) == 214) THEN
j = 6693
GO TO 800
ELSE IF (IAND(kpds(4),128) == 128) THEN
GO TO 895
END IF
kret = 5
RETURN
END IF
END IF
! -------------------------------------------------------
! CHECK JAPAN METEOROLOGICAL AGENCY SET
! -------------------------------------------------------
IF (kpds(1) == 34) THEN
IF (IAND(kpds(4),128) == 128) THEN
PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL'
PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',kpds(3)
GO TO 900
END IF
END IF
! -------------------------------------------------------
! CHECK CANADIAN SET
! -------------------------------------------------------
IF (kpds(1) == 54) THEN
IF (IAND(kpds(4),128) == 128) THEN
PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL'
PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',kpds(3)
GO TO 900
END IF
END IF
! -------------------------------------------------------
! CHECK FNOC SET
! -------------------------------------------------------
IF (kpds(1) == 58) THEN
IF (kpds(3) == 220.OR.kpds(3) == 221) THEN
! FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63)
j = 3969
kptr(10) = j
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
END IF
IF (kpds(3) == 223) THEN
! FNOC GRID 223 - MAPSIZE 10512 (73 * 144)
j = 10512
kptr(10) = j
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
END IF
IF (IAND(kpds(4),128) == 128) THEN
PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL'
PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',kpds(3)
GO TO 900
END IF
END IF
! -------------------------------------------------------
! CHECK UKMET SET
! -------------------------------------------------------
IF (kpds(1) == 74) THEN
IF (IAND(kpds(4),128) == 128) THEN
GO TO 820
END IF
END IF
! -------------------------------------------------------
! CHECK ECMWF SET
! -------------------------------------------------------
IF (kpds(1) == 98) THEN
IF (kpds(3) >= 1.AND.kpds(3) <= 12) THEN
IF (kpds(3) >= 5.AND.kpds(3) <= 8) THEN
j = 1073
ELSE
j = 1369
END IF
kptr(10) = j
CALL fi637(*810,j,kpds,kgds,kret)
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
ELSE IF (kpds(3) >= 13.AND.kpds(3) <= 16) THEN
j = 361
kptr(10) = j
CALL fi637(*810,j,kpds,kgds,kret)
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
ELSE IF (IAND(kpds(4),128) == 128) THEN
GO TO 810
ELSE
kret = 5
RETURN
END IF
ELSE
PRINT *,'CENTER',kpds(1),' IS NOT DEFINED'
IF (IAND(kpds(4),128) == 128) THEN
PRINT *,'GDS WILL BE USED TO UNPACK THE DATA', &
' MAP = ',kpds(3)
GO TO 900
ELSE
kret = 10
RETURN
END IF
END IF
! =======================================
!
800 CONTINUE
kptr(10) = j
CALL fi637 (*801,j,kpds,kgds,kret)
DO i = 1, j
kbms(i) = .true.
END DO
RETURN
801 CONTINUE
!
! ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION
! ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE
! ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE
! ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN
! ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE
! ----- A BIT MAP.
!
810 CONTINUE
PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
GO TO 895
!
820 CONTINUE
PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
GO TO 895
!
890 CONTINUE
PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE'
895 CONTINUE
PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',kpds(3)
!
900 CONTINUE
j = kgds(2) * kgds(3)
! AFOS AFOS AFOS SPECIAL CASE
! INVOLVES NEXT SINGLE STATEMENT ONLY
IF (kpds(3) == 211) kret = 0
kptr(10) = j
DO i = 1, j
kbms(i) = .true.
END DO
! PRINT *,'EXIT FI634'
RETURN
END SUBROUTINE fi634
SUBROUTINE fi635(msga,kptr,kpds,kgds,kbms,DATA,kret) 1,37
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI635 EXTRACT GRIB DATA ELEMENTS FROM BDS
! PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: EXTRACT GRIB DATA FROM BINARY DATA SECTION AND PLACE
! INTO OUTPUT ARRAY IN PROPER POSITION.
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
! 94-04-01 CAVANAUGH MODIFIED CODE TO INCLUDE DECIMAL SCALING WHEN
! CALCULATING THE VALUE OF DATA POINTS SPECIFIED
! AS BEING EQUAL TO THE REFERENCE VALUE
! 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000
! FOR .5 DEGREE SST ANALYSIS FIELDS
!
! USAGE: CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET)
! INPUT ARGUMENT LIST:
! MSGA - ARRAY CONTAINING GRIB MESSAGE
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! (1) - TOTAL LENGTH OF GRIB MESSAGE
! (2) - LENGTH OF INDICATOR (SECTION 0)
! (3) - LENGTH OF PDS (SECTION 1)
! (4) - LENGTH OF GDS (SECTION 2)
! (5) - LENGTH OF BMS (SECTION 3)
! (6) - LENGTH OF BDS (SECTION 4)
! (7) - VALUE OF CURRENT BYTE
! (8) - BIT POINTER
! (9) - GRIB START BIT NR
! (10) - GRIB/GRID ELEMENT COUNT
! (11) - NR UNUSED BITS AT END OF SECTION 3
! (12) - BIT MAP FLAG
! (13) - NR UNUSED BITS AT END OF SECTION 2
! (14) - BDS FLAGS
! (15) - NR UNUSED BITS AT END OF SECTION 4
! KPDS - ARRAY CONTAINING PDS ELEMENTS.
! SEE INITIAL ROUTINE
! KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
!
! OUTPUT ARGUMENT LIST:
! KBDS - INFORMATION EXTRACTED FROM BINARY DATA SECTION
! KBDS(1) - N1
! KBDS(2) - N2
! KBDS(3) - P1
! KBDS(4) - P2
! KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS
! KBDS(6) - " " " " " BIT MAPS
! KBDS(7) - " " " FIRST ORDER VALUES
! KBDS(8) - " " " SECOND ORDER VALUES
! KBDS(9) - " " START OF BDS
! KBDS(10) - " " MAIN BIT MAP
! KBDS(11) - BINARY SCALING
! KBDS(12) - DECIMAL SCALING
! KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES
! KBDS(14) - BIT MAP FLAG
! 0 = NO SECOND ORDER BIT MAP
! 1 = SECOND ORDER BIT MAP PRESENT
! KBDS(15) - SECOND ORDER BIT WIDTH
! KBDS(16) - CONSTANT / DIFFERENT WIDTHS
! 0 = CONSTANT WIDTHS
! 1 = DIFFERENT WIDTHS
! KBDS(17) - SINGLE DATUM / MATRIX
! 0 = SINGLE DATUM AT EACH GRID POINT
! 1 = MATRIX OF VALUES AT EACH GRID POINT
! (18-20)- UNUSED
!
! DATA - REAL*4 ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE.
! KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
! SEE INPUT LIST
! KRET - ERROR RETURN
!
! REMARKS:
! ERROR RETURN
! 3 = UNPACKED FIELD IS LARGER THAN 65160
! 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID
! 7 = NUMBER OF BITS IN FILL TOO LARGE
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS9000
!
!$$$
! *************************************************************
! ON A PC THIS CAN BE CHANGED TO A SMALLER SIZE TO BETTER FIT
! THE DOS MEMORY LIMIT OF 640K BYTES. YOU COULD DO THIS
! FOR MICROSOFT 5.0. A PC 32 BIT FORTRAN COMPILER
! WOULD NOT NEED THIS CHANGE. IF NONE OF YOUR GRIB RECORDS
! IS LARGER THAN 20000, SET MXSIZE TO 20000.
! *************************************************************
PARAMETER (mxsize=260000)
CHARACTER :: msga(*)
CHARACTER (LEN=1) :: kk(8)
CHARACTER (LEN=1) :: ckref(8)
!
LOGICAL*1 kbms(*)
!
INTEGER :: kpds(*)
INTEGER :: kgds(*)
INTEGER :: kbds(20)
INTEGER :: kptr(*)
INTEGER :: nrbits
INTEGER :: kref
INTEGER :: kkk
INTEGER :: ksave(mxsize)
INTEGER :: kscale
!
REAL :: DATA(*)
REAL :: refnce
REAL :: scale
REAL :: realkk
!
EQUIVALENCE (ckref(1),kref,refnce)
EQUIVALENCE (kk(1),kkk,realkk)
!
!
! CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE
!
! *************************************************************
SAVE
! PRINT *,'ENTER FI635'
! SET UP BIT POINTER
kptr(8) = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) &
+ (kptr(5)*8) + 24
! ------------- EXTRACT FLAGS
! BYTE 4
CALL grbgbyte(msga,kptr(14),kptr(8),4)
kptr(8) = kptr(8) + 4
! --------- NR OF UNUSED BITS IN SECTION 4
CALL grbgbyte(msga,kptr(15),kptr(8),4)
kptr(8) = kptr(8) + 4
kend = kptr(9) + (kptr(2)*8) + (kptr(3)*8) + (kptr(4)*8) &
+ (kptr(5)*8) + kptr(6) * 8 - kptr(15)
! ------------- GET SCALE FACTOR
! BYTES 5,6
! CHECK SIGN
CALL grbgbyte (msga,ksign,kptr(8),1)
kptr(8) = kptr(8) + 1
! GET ABSOLUTE SCALE VALUE
CALL grbgbyte (msga,kscale,kptr(8),15)
kptr(8) = kptr(8) + 15
IF (ksign > 0) THEN
kscale = - kscale
END IF
scale = 2.0**kscale
! ------------ GET REFERENCE VALUE
! BYTES 7,10
CALL grbgbyte (msga,kref,kptr(8),32)
kptr(8) = kptr(8) + 32
!
! THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT
! TO THE FLOATING POINT USED ON YOUR COMPUTER.
!
! 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE
! LW = 4 OR 8; IF 8 MAY BE A CRAY
!
CALL w3fi01(lw)
IF (lw == 4) THEN
CALL grbgbyte (ckref,jsgn,0,1)
CALL grbgbyte (ckref,jexp,1,7)
CALL grbgbyte (ckref,ifr,8,24)
ELSE
CALL grbgbyte (ckref,jsgn,32,1)
CALL grbgbyte (ckref,jexp,33,7)
CALL grbgbyte (ckref,ifr,40,24)
END IF
! PRINT *,109,JSGN,JEXP,IFR
! 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8))
IF (ifr == 0) THEN
refnce = 0.0
ELSE IF (jexp == 0.AND.ifr == 0) THEN
refnce = 0.0
ELSE
refnce = FLOAT(ifr) * 16.0 ** (jexp - 64 - 6)
IF (jsgn /= 0) refnce = - refnce
END IF
! PRINT *,'SCALE ',SCALE,' REF VAL ',KREF,REFNCE
! ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
! BYTE 11
CALL grbgbyte (msga,kbits,kptr(8),8)
kptr(8) = kptr(8) + 8
kbds(4) = kbits
! KBDS(13) = KBITS
ibyt12 = kptr(8)
! ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT
! THIS IS WHERE DATA BEGINS AND AND THE PROCESSING
! INCLUDED IN THE FOLLOWING IF...END IF
! WILL BE SKIPPED
! PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1)
IF (IAND(kptr(14),1) == 0) THEN
! PRINT *,'NO EXTENDED FLAGS'
ELSE
! BYTES 12,13
CALL grbgbyte (msga,koctet,kptr(8),16)
kptr(8) = kptr(8) + 16
! --------------------------- EXTENDED FLAGS
! BYTE 14
CALL grbgbyte (msga,kxflag,kptr(8),8)
! PRINT *,'HAVE EXTENDED FLAGS',KXFLAG
kptr(8) = kptr(8) + 8
IF (IAND(kxflag,16) == 0) THEN
! SECOND ORDER VALUES CONSTANT WIDTHS
kbds(16) = 0
ELSE
! SECOND ORDER VALUES DIFFERENT WIDTHS
kbds(16) = 1
END IF
IF (IAND (kxflag,32) == 0) THEN
! NO SECONDARY BIT MAP
kbds(14) = 0
ELSE
! HAVE SECONDARY BIT MAP
kbds(14) = 1
END IF
IF (IAND (kxflag,64) == 0) THEN
! SINGLE DATUM AT GRID POINT
kbds(17) = 0
ELSE
! MATRIX OF VALUES AT GRID POINT
kbds(17) = 1
END IF
! ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX
! BYTES 15,16
CALL grbgbyte (msga,nr,kptr(8),16)
kptr(8) = kptr(8) + 16
! ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX
! BYTES 17,18
CALL grbgbyte (msga,nc,kptr(8),16)
kptr(8) = kptr(8) + 16
! ---------------------- NRV - FIRST DIM COORD VALS
! BYTE 19
CALL grbgbyte (msga,nrv,kptr(8),8)
kptr(8) = kptr(8) + 8
! ---------------------- NC1 - NR COEFF'S OR VALUES
! BYTE 20
CALL grbgbyte (msga,nc1,kptr(8),8)
kptr(8) = kptr(8) + 8
! ---------------------- NCV - SECOND DIM COORD OR VALUE
! BYTE 21
CALL grbgbyte (msga,ncv,kptr(8),8)
kptr(8) = kptr(8) + 8
! ---------------------- NC2 - NR COEFF'S OR VALS
! BYTE 22
CALL grbgbyte (msga,nc2,kptr(8),8)
kptr(8) = kptr(8) + 8
! ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF
! BYTE 23
CALL grbgbyte (msga,kphys1,kptr(8),8)
kptr(8) = kptr(8) + 8
! ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF
! BYTE 24
CALL grbgbyte (msga,kphys2,kptr(8),8)
kptr(8) = kptr(8) + 8
! BYTES 25-N
END IF
IF (kbits == 0) THEN
! HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
scal10 = 10.0 ** kpds(22)
scal10 = 1.0 / scal10
refn10 = refnce * scal10
kentry = kptr(10)
DO i = 1, kentry
DATA(i) = 0.0
IF (kbms(i)) THEN
DATA(i) = refn10
END IF
END DO
GO TO 900
END IF
! PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS
knr = (kend - kptr(8)) / kbits
! PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR
! --------------------
! CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
! ENTRIES.
! ------------- UNUSED BITS IN DATA AREA
! NUMBER OF BYTES IN DATA AREA
nrbyte = kptr(6) - 11
! ------------- TOTAL NR OF USABLE BITS
nrbits = nrbyte * 8 - kptr(15)
! ------------- TOTAL NR OF ENTRIES
kentry = nrbits / kbits
! MAX SIZE CHECK
IF (kentry > mxsize) THEN
kret = 3
RETURN
END IF
!
! IF (IAND(KPTR(14),2).EQ.0) THEN
! PRINT *,'SOURCE VALUES IN FLOATING POINT'
! ELSE
! PRINT *,'SOURCE VALUES IN INTEGER'
! END IF
!
IF (IAND(kptr(14),8) == 0) THEN
! PRINT *,'PROCESSING GRID POINT DATA'
IF (IAND(kptr(14),4) == 0) THEN
! PRINT *,' WITH SIMPLE PACKING'
IF (IAND(kptr(14),1) == 0) THEN
! PRINT *,' WITH NO ADDITIONAL FLAGS'
GO TO 4000
ELSE IF (IAND(kptr(14),1) /= 0) THEN
PRINT *,' WITH ADDITIONAL FLAGS',kxflag
IF (kbds(17) == 0) THEN
PRINT *,' SINGLE DATUM EACH GRID PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
ELSE IF (kbds(17) /= 0) THEN
PRINT *,' MATRIX OF VALS EACH PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
END IF
END IF
ELSE IF (IAND(kptr(14),4) /= 0) THEN
PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
IF (IAND(kptr(14),1) == 0) THEN
PRINT *,' WITH NO ADDITIONAL FLAGS'
ELSE IF (IAND(kptr(14),1) /= 0) THEN
PRINT *,' WITH ADDITIONAL FLAGS'
IF (kbds(17) == 0) THEN
PRINT *,' SINGLE DATUM AT EACH PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
! ROW BY ROW - COL BY COL
CALL fi636 (DATA,msga,kbms, &
refnce,kptr,kpds,kgds)
GO TO 900
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
CALL fi636 (DATA,msga,kbms, &
refnce,kptr,kpds,kgds)
GO TO 900
END IF
ELSE IF (kbds(17) /= 0) THEN
PRINT *,' MATRIX OF VALS EACH PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
END IF
END IF
END IF
ELSE IF (IAND(kptr(14),8) /= 0) THEN
PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS'
IF (IAND(kptr(14),4) == 0) THEN
PRINT *,' WITH SIMPLE PACKING'
IF (IAND(kptr(14),1) == 0) THEN
PRINT *,' WITH NO ADDITIONAL FLAGS'
GO TO 5000
ELSE IF (IAND(kptr(14),1) /= 0) THEN
PRINT *,' WITH ADDITIONAL FLAGS'
IF (kbds(17) == 0) THEN
PRINT *,' SINGLE DATUM EACH GRID PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
ELSE IF (kbds(17) /= 0) THEN
PRINT *,' MATRIX OF VALS EACH PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
END IF
END IF
ELSE IF (IAND(kptr(14),4) /= 0) THEN
! COMPLEX/SECOND ORDER PACKING
PRINT *,' WITH COMPLEX/SECOND ORDER PACKING'
IF (IAND(kptr(14),1) == 0) THEN
PRINT *,' WITH NO ADDITIONAL FLAGS'
ELSE IF (IAND(kptr(14),1) /= 0) THEN
PRINT *,' WITH ADDITIONAL FLAGS'
IF (kbds(17) == 0) THEN
PRINT *,' SINGLE DATUM EACH GRID PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
ELSE IF (kbds(17) /= 0) THEN
PRINT *,' MATRIX OF VALS EACH PT'
IF (kbds(14) == 0) THEN
PRINT *,' NO SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
ELSE IF (kbds(14) /= 0) THEN
PRINT *,' SEC BIT MAP'
IF (kbds(16) == 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES CONSTANT WIDTH'
ELSE IF (kbds(16) /= 0) THEN
PRINT *,' SECOND ORDER', &
' VALUES DIFFERENT WIDTHS'
END IF
END IF
END IF
END IF
END IF
END IF
PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED'
kret = 11
RETURN
4000 CONTINUE
! ****************************************************************
!
! GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
!
scal10 = 10.0 ** kpds(22)
scal10 = 1.0 / scal10
IF (kpds(3) == 23.OR.kpds(3) == 24.OR.kpds(3) == 26 &
.OR.kpds(3) == 63.OR.kpds(3) == 64) THEN
IF (kpds(3) == 26) THEN
kadd = 72
ELSE IF (kpds(3) == 63.OR.kpds(3) == 64) THEN
kadd = 91
ELSE
kadd = 37
END IF
CALL grbgbytes (msga,ksave,kptr(8),kbits,0,knr)
kptr(8) = kptr(8) + kbits * knr
ii = 1
kentry = kptr(10)
DO i = 1, kentry
IF (kbms(i)) THEN
DATA(i) = (refnce+FLOAT(ksave(ii))*scale)*scal10
ii = ii + 1
ELSE
DATA(i) = 0.0
END IF
END DO
DO i = 2, kadd
DATA(i) = DATA(1)
END DO
ELSE IF (kpds(3) == 21.OR.kpds(3) == 22.OR.kpds(3) == 25 &
.OR.kpds(3) == 61.OR.kpds(3) == 62) THEN
CALL grbgbytes (msga,ksave,kptr(8),kbits,0,knr)
ii = 1
kentry = kptr(10)
DO i = 1, kentry
IF (kbms(i)) THEN
DATA(i) = (refnce + FLOAT(ksave(ii)) * scale) * scal10
ii = ii + 1
ELSE
DATA(i) = 0.0
END IF
END DO
IF (kpds(3) == 25) THEN
kadd = 71
ELSE IF (kpds(3) == 61.OR.kpds(3) == 62) THEN
kadd = 90
ELSE
kadd = 36
END IF
lastp = kentry - kadd
DO i = lastp+1, kentry
DATA(i) = DATA(lastp)
END DO
ELSE
CALL grbgbytes (msga,ksave,kptr(8),kbits,0,knr)
ii = 1
kentry = kptr(10)
DO i = 1, kentry
IF (kbms(i)) THEN
DATA(i) = (refnce + FLOAT(ksave(ii)) * scale) * scal10
ii = ii + 1
ELSE
DATA(i) = 0.0
END IF
END DO
END IF
GO TO 900
! ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS,
! SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS
5000 CONTINUE
! PRINT *,'CHECK POINT SPECTRAL COEFF'
kptr(8) = ibyt12
CALL grbgbyte (msga,kkk,kptr(8),32)
kptr(8) = kptr(8) + 32
!
! THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT
! TO THE FLOATING POINT USED ON YOUR MACHINE.
!
! 1ST TEST TO SEE IN ON 32 OR 64 BIT WORD MACHINE
! LW = 4 OR 8; IF 8 MAY BE A CRAY
!
CALL w3fi01(lw)
IF (lw == 4) THEN
CALL grbgbyte (kk,jsgn,0,1)
CALL grbgbyte (kk,jexp,1,7)
CALL grbgbyte (kk,ifr,8,24)
ELSE
CALL grbgbyte (kk,jsgn,32,1)
CALL grbgbyte (kk,jexp,33,7)
CALL grbgbyte (kk,ifr,40,24)
END IF
!
IF (ifr == 0) THEN
realkk = 0.0
ELSE IF (jexp == 0.AND.ifr == 0) THEN
realkk = 0.0
ELSE
realkk = FLOAT(ifr) * 16.0 ** (jexp - 64 - 6)
IF (jsgn /= 0) realkk = -realkk
END IF
DATA(1) = realkk
CALL grbgbytes (msga,ksave,kptr(8),kbits,0,knr)
! --------------
DO i = 1, kentry
DATA(i+1) = refnce + FLOAT(ksave(i)) * scale
END DO
900 CONTINUE
! PRINT *,'EXIT FI635'
RETURN
END SUBROUTINE fi635
SUBROUTINE fi636 (DATA,msga,kbms,refnce,kptr,kpds,kgds) 2,17
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI636 PROCESS SECOND ORDER PACKING
! PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 92-09-22
!
! ABSTRACT: PROCESS SECOND ORDER PACKING FROM THE BINARY DATA SECTION
! (BDS) FOR SINGLE DATA ITEMS GRID POINT DATA
!
! PROGRAM HISTORY LOG:
! 93-06-08 CAVANAUGH
! 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER
! VALUES AND SECOND ORDER VALUES CORRECTLY.
!
! USAGE: CALL FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS)
! INPUT ARGUMENT LIST:
!
! MSGA - ARRAY CONTAINING GRIB MESSAGE
! REFNCE - REFERENCE VALUE
! KPTR - WORK ARRAY
!
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! DATA - LOCATION OF OUTPUT ARRAY
! WORKING ARRAY
! KBDS(1) - N1
! KBDS(2) - N2
! KBDS(3) - P1
! KBDS(4) - P2
! KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS
! KBDS(6) - " " " " " BIT MAPS
! KBDS(7) - " " " FIRST ORDER VALUES
! KBDS(8) - " " " SECOND ORDER VALUES
! KBDS(9) - " " START OF BDS
! KBDS(10) - " " MAIN BIT MAP
! KBDS(11) - BINARY SCALING
! KBDS(12) - DECIMAL SCALING
! KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES
! KBDS(14) - BIT MAP FLAG
! 0 = NO SECOND ORDER BIT MAP
! 1 = SECOND ORDER BIT MAP PRESENT
! KBDS(15) - SECOND ORDER BIT WIDTH
! KBDS(16) - CONSTANT / DIFFERENT WIDTHS
! 0 = CONSTANT WIDTHS
! 1 = DIFFERENT WIDTHS
! KBDS(17) - SINGLE DATUM / MATRIX
! 0 = SINGLE DATUM AT EACH GRID POINT
! 1 = MATRIX OF VALUES AT EACH GRID POINT
! (18-20)- UNUSED
!
! REMARKS:
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS, CYBER
!
!$$$
REAL :: DATA(*)
REAL :: refn
REAL :: refnce
!
INTEGER :: kbds(20)
INTEGER :: kptr(*)
INTEGER :: jref,bmap2(12500)
INTEGER :: i,ibds
INTEGER :: kbit,ifoval,isoval
INTEGER :: kpds(*),kgds(*)
!
LOGICAL*1 kbms(*)
!
CHARACTER :: msga(*)
!
EQUIVALENCE (jref,refn)
! ******************* SETUP ******************************
SAVE
! PRINT *,'ENTER FI636'
ij = 0
! ========================================================
IF (kbds(14) == 0) THEN
! NO BIT MAP, MUST CONSTRUCT ONE
IF (kgds(2) == 65535) THEN
IF (kgds(20) == 255) THEN
PRINT *,'CANNOT BE USED HERE'
ELSE
! POINT TO PL
lp = kptr(9) + kptr(2)*8 + kptr(3)*8 + kgds(20)*8 - 8
jt = 0
DO jz = 1, kgds(3)
! GET NUMBER IN CURRENT ROW
CALL grbgbyte (msga,NUMBER,lp,16)
! INCREMENT TO NEXT ROW NUMBER
lp = lp + 16
! PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER
DO jq = 1, NUMBER
jt = jt + 1
IF (jq == 1) THEN
bmap2(jt) = 1
ELSE
bmap2(jt) = 0
END IF
END DO
END DO
END IF
ELSE
IF (IAND(kgds(11),32) == 0) THEN
! ROW BY ROW
! PRINT *,' ROW BY ROW'
kout = kgds(3)
kin = kgds(2)
ELSE
! COL BY COL
! PRINT *,' COL BY COL'
kin = kgds(3)
kout = kgds(2)
END IF
! PRINT *,'KIN=',KIN,' KOUT= ',KOUT
DO i = 1, kout
DO j = 1, kin
IF (j == 1) THEN
CALL grbsbyte (bmap2,1,ij,1)
ELSE
CALL grbsbyte (bmap2,0,ij,1)
END IF
ij = ij + 1
END DO
END DO
END IF
END IF
! ========================================================
! CALL BINARY (BMAP2,2)
! START OF BMS (BIT POINTER)
! KBDS(10) = 0
! BYTE START OF BDS
ibds = kptr(2) + kptr(3) + kptr(4) + kptr(5)
! PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5)
! BIT START OF BDS
jptr = ibds * 8
! PRINT *,'JPTR ',JPTR
kbds(9) = jptr
! PRINT *,'START OF BDS ',KBDS(9)
! BINARY SCALE VALUE BDS BYTES 5-6
CALL grbgbyte (msga,ISIGN,jptr+32,1)
CALL grbgbyte (msga,kbds(11),jptr+33,15)
IF (ISIGN > 0) THEN
kbds(11) = - kbds(11)
END IF
! PRINT *,'BINARY SCALE VALUE =',KBDS(11)
! EXTRACT REFERENCE VALUE
CALL grbgbyte(msga,jref,jptr+48,32)
! PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE
! F O BIT WIDTH
CALL grbgbyte(msga,kbds(13),jptr+80,8)
jptr = jptr + 88
! AT START OF BDS BYTE 12
! EXTRACT N1
CALL grbgbyte (msga,kbds(1),jptr,16)
! PRINT *,'N1 = ',KBDS(1)
jptr = jptr + 16
! EXTENDED FLAGS
CALL grbgbyte (msga,kflag,jptr,8)
! ISOLATE BIT MAP FLAG
kbds(14) = IAND(kflag,32)
jptr = jptr + 8
! EXTRACT N2
CALL grbgbyte (msga,kbds(2),jptr,16)
! PRINT *,'N2 = ',KBDS(2)
jptr = jptr + 16
! EXTRACT P1
CALL grbgbyte (msga,kbds(3),jptr,16)
! PRINT *,'P1 = ',KBDS(3)
jptr = jptr + 16
! EXTRACT P2
CALL grbgbyte (msga,kbds(4),jptr,16)
! PRINT *,'P2 = ',KBDS(4)
jptr = jptr + 16
! SKIP RESERVED BYTE
jptr = jptr + 8
! START OF SECOND ORDER BIT WIDTHS
kbds(5) = jptr
! COMPUTE START OF SECONDARY BIT MAP
IF (kbds(14) /= 0) THEN
! FOR INCLUDED SECONDARY BIT MAP
jptr = jptr + (kbds(3) * 8)
kbds(6) = jptr
ELSE
! FOR CONSTRUCTED SECONDARY BIT MAP
kbds(6) = 0
END IF
! CREATE POINTER TO START OF FIRST ORDER VALUES
kbds(7) = kbds(9) + kbds(1) * 8 - 8
PRINT *,'BIT POINTER TO START OF FOVALS',kbds(7)
! CREATE POINTER TO START OF SECOND ORDER VALUES
! KBDS(8) = KBDS(9) + KBDS(2) * 8 - 8
! PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8)
! PRINT *,'KBDS( 1) - N1 ',KBDS( 1)
! PRINT *,'KBDS( 2) - N2 ',KBDS( 2)
! PRINT *,'KBDS( 3) - P1 ',KBDS( 3)
! PRINT *,'KBDS( 4) - P2 ',KBDS( 4)
! PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5)
! PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6)
! PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7)
! PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8)
! PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9)
! PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10)
! PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11)
! PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22)
! PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13)
! PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14)
! PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15)
! PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16)
! PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17)
! PRINT *,'REFNCE VAL ',REFNCE
! ************************* PROCESS DATA **********************
! FOR EACH GRID POINT ENTRY
!
scale2 = 2.0**kbds(11)
scal10 = 10.0**kpds(22)
! PRINT *,'SCALE VALUES - ',SCALE2,SCAL10
DO i = 1, kptr(10)
! GET NEXT MASTER BIT MAP BIT POSITION
! IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1)
IF (kbms(i)) THEN
! WRITE(6,900)I,KBMS(I)
! 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4)
IF (kbds(14) /= 0) THEN
CALL grbgbyte (msga,kbit,kbds(6),1)
ELSE
CALL grbgbyte (bmap2,kbit,kbds(6),1)
END IF
! PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT
kbds(6) = kbds(6) + 1
IF (kbit /= 0) THEN
! PRINT *,' SOB ON'
! GET NEXT FIRST ORDER PACKED VALUE
CALL grbgbyte (msga,ifoval,kbds(7),kbds(13))
kbds(7) = kbds(7) + kbds(13)
! PRINT *,'FOVAL =',IFOVAL
! GET SECOND ORDER BIT WIDTH
CALL grbgbyte (msga,kbds(15),kbds(5),8)
kbds(5) = kbds(5) + 8
! PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=',
! * ,KBDS(5), 'ISOWID =',KBDS(15)
ELSE
! PRINT *,' SOB NOT ON'
END IF
isoval = 0
IF (kbds(15) == 0) THEN
! IF SECOND ORDER BIT WIDTH = 0
! THEN SECOND ORDER VALUE IS 0
! SO CALCULATE DATA VALUE FOR THIS POINT
! DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10
ELSE
CALL grbgbyte (msga,isoval,kbds(8),kbds(15))
kbds(8) = kbds(8) + kbds(15)
END IF
DATA(i) = (refnce + (FLOAT(ifoval + isoval) * &
scale2)) / scal10
! PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10
ELSE
! WRITE(6,901) I,KBMS(I)
! 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4)
DATA(i) = 0.0
END IF
! PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15)
END DO
! **************************************************************
! PRINT *,'EXIT FI636'
RETURN
END SUBROUTINE fi636
SUBROUTINE fi637(*,j,kpds,kgds,kret) 10
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: FI637 GRIB GRID/SIZE TEST
! PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 91-09-13
!
! ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH
! ON EXISTING GRIDS (BY CENTER) IS INDICATED
!
! PROGRAM HISTORY LOG:
! 91-09-13 CAVANAUGH
!
! USAGE: CALL FI637(*,J,KPDS,KGDS,KRET)
! INPUT ARGUMENT LIST:
! J - SIZE FOR INDICATED GRID
! KPDS -
! KGDS -
!
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! KRET - ERROR RETURN
!
! REMARKS:
! KRET -
! = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS
!
!$$$
INTEGER :: kpds(*)
INTEGER :: kgds(*)
INTEGER :: j
INTEGER :: i
! ---------------------------------------
SAVE
! ---------------------------------------
! IF GDS NOT INDICATED, RETURN
! ----------------------------------------
IF (IAND(kpds(4),128) == 0) RETURN
! ---------------------------------------
! GDS IS INDICATED, PROCEED WITH TESTING
! ---------------------------------------
IF (kgds(2) == 65535) THEN
RETURN
END IF
i = kgds(2) * kgds(3)
! ---------------------------------------
! INTERNATIONAL SET
! ---------------------------------------
IF (kpds(3) >= 21.AND.kpds(3) <= 26) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 37.AND.kpds(3) <= 44) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) == 50) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 61.AND.kpds(3) <= 64) THEN
IF (i /= j) THEN
RETURN 1
END IF
! ---------------------------------------
! TEST ECMWF CONTENT
! ---------------------------------------
ELSE IF (kpds(1) == 98) THEN
kret = 9
IF (kpds(3) >= 1.AND.kpds(3) <= 16) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE
kret = 5
RETURN 1
END IF
! ---------------------------------------
! U.K. MET OFFICE, BRACKNELL
! ---------------------------------------
ELSE IF (kpds(1) == 74) THEN
kret = 9
IF (kpds(3) >= 25.AND.kpds(3) <= 26) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE
kret = 5
RETURN 1
END IF
! ---------------------------------------
! CANADA
! ---------------------------------------
ELSE IF (kpds(1) == 54) THEN
PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS'
RETURN 1
! ---------------------------------------
! JAPAN METEOROLOGICAL AGENCY
! ---------------------------------------
ELSE IF (kpds(1) == 34) THEN
PRINT *,' NO CURRENT LISTING OF JMA GRIDS'
RETURN 1
! ---------------------------------------
! NAVY - FNOC
! ---------------------------------------
ELSE IF (kpds(1) == 58) THEN
IF (kpds(3) >= 220.AND.kpds(3) <= 221) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) == 223) THEN
IF (i /= j) THEN
RETURN 1
END IF
END IF
! ---------------------------------------
! U.S. GRIDS
! ---------------------------------------
ELSE IF (kpds(1) == 7) THEN
kret = 9
IF (kpds(3) >= 1.AND.kpds(3) <= 3) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) == 5.OR.kpds(3) == 6) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 27.AND.kpds(3) <= 30) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 33.AND.kpds(3) <= 34) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 37.AND.kpds(3) <= 45) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 55.AND.kpds(3) <= 56) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 67.AND.kpds(3) <= 77) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 85.AND.kpds(3) <= 86) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) == 87) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 90.AND.kpds(3) <= 95) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) == 100.OR.kpds(3) == 101) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 103.AND.kpds(3) <= 107) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE IF (kpds(3) >= 201.AND.kpds(3) <= 214) THEN
IF (i /= j) THEN
RETURN 1
END IF
ELSE
kret = 5
RETURN 1
END IF
ELSE
kret = 10
RETURN 1
END IF
! ------------------------------------
! NORMAL EXIT
! ------------------------------------
kret = 0
RETURN
END SUBROUTINE fi637
SUBROUTINE w3fi83 (DATA,npts,fval1,fdiff1,iscal2, & 1
isc10,kpds,kgds)
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: W3FI83 RESTORE DELTA PACKED DATA TO ORIGINAL
! PRGMMR: CAVANAUGH ORG: NMC421 DATE:94-03-09
!
! ABSTRACT: RESTORE DELTA PACKED DATA TO ORIGINAL VALUES
! RESTORE FROM BOUSTREPHEDONIC ALIGNMENT
!
! PROGRAM HISTORY LOG:
! 93-07-14 CAVANAUGH
! 93-07-22 STACKPOLE ADDITIONS TO FIX SCALING
! 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS
! (BOUSTROPHEDONIC PROCESSING) TO RESTORE
! DATA TO ORIGINAL SEQUENCE.
! 94-03-02 CAVANAUGH CORRECTED REVERSAL OF EVEN NUMBERED ROWS
!
! USAGE: CALL W3FI83(DATA,NPTS,FVAL1,FDIFF1,ISCAL2,
! * ISC10,KPDS,KGDS)
! INPUT ARGUMENT LIST:
! DATA - SECOND ORDER DIFFERENCES
! NPTS - NUMBER OF POINTS IN ARRAY
! FVAL1 - ORIGINAL FIRST ENTRY IN ARRAY
! FDIFF1 - ORIGINAL FIRST FIRST-DIFFERENCE
! ISCAL2 - POWER-OF-TWO EXPONENT FOR UNSCALING
! ISC10 - POWER-OF-TEN EXPONENT FOR UNSCALING
! KPDS - ARRAY OF INFORMATION FOR PDS
! KGDS - ARRAY OF INFORMATION FOR GDS
!
! OUTPUT ARGUMENT LIST:
! DATA - EXPANDED ORIGINAL DATA VALUES
!
! REMARKS:
!
! ATTRIBUTES:
! LANGUAGE: FORTRAN 77
! MACHINE: NAS
!
!$$$
REAL :: fval1,fdiff1
REAL :: DATA(*),boust(200)
INTEGER :: npts,nrow,ncol,kpds(*),kgds(*),isc10
! ---------------------------------------
SAVE
!
! REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING
!
dscal = 10.0 ** isc10
IF (dscal == 0.0) THEN
DO i=1,npts
DATA(i) = 1.0
END DO
ELSE IF (dscal == 1.0) THEN
ELSE
DO i=1,npts
DATA(i) = DATA(i) * dscal
END DO
END IF
!
DATA(1) = fval1
DATA(2) = fdiff1
DO j = 3,2,-1
DO k = j, npts
DATA(k) = DATA(k) + DATA(k-1)
END DO
END DO
!
! NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD
! AND THE DECIMAL SCALING TOO
!
IF (dscal == 0) THEN
scale = 0.0
ELSE
scale =(2.0**iscal2)/dscal
END IF
DO i=1,npts
DATA(i) = DATA(i) * scale
END DO
! ==========================================================
IF (IAND(kpds(4),128) /= 0) THEN
nrow = kgds(3)
ncol = kgds(2)
!
! DATA LAID OUT BOUSTROPHEDONIC STYLE
!
!
! PRINT*, ' REVERSE BOUSTROPHEDON'
DO i = 2, nrow, 2
!
! REVERSE THE EVEN NUMBERED ROWS
!
DO j = 1, ncol
npos = i * ncol - j + 1
boust(j) = DATA(npos)
END DO
DO j = 1, ncol
npos = ncol * (i-1) + j
DATA(npos) = boust(j)
END DO
END DO
!
!
END IF
! =================================================================
RETURN
END SUBROUTINE w3fi83
SUBROUTINE w3fi01(lw) 5
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
! . . . .
! SUBPROGRAM: W3FI01 DETERMINES MACHINE WORD LENGTH IN BYTES
! PRGMMR: KEYSER ORG: NMC22 DATE:92-07-30
!
! ABSTRACT: DETERMINES THE NUMBER OF BYTES IN A FULL WORD FOR THE
! PARTICULAR MACHINE (IBM, CRAY, WORKSTATION, PC).
!
! PROGRAM HISTORY LOG:
! 92-01-10 R. KISTLER (W/NMC23)
! 92-05-22 D. A. KEYSER -- DOCBLOCKED/COMMENTED
! 93-03-29 R.E.JONES -- ADD SAVE STATEMENT
!
! USAGE: CALL W3FI01(LW)
! OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
! LW - MACHINE WORD LENGTH IN BYTES
!
! OUTPUT FILES:
! FT06F001 - PRINTOUT
!
! REMARKS: NONE.
!
! ATTRIBUTES:
! LANGUAGE: IBM AIX XL FORTRAN Compiler/6000
! MACHINE: IBM RS6000 model 530
!
!$$$
!
CHARACTER (LEN=8) :: ctest1,ctest2
!
INTEGER :: itest1,itest2
!
EQUIVALENCE (ctest1,itest1),(ctest2,itest2)
!
SAVE
!
DATA ctest1/'12345678'/
!
itest2 = itest1
!CCCC PRINT *,' CTEST1 = ',CTEST1,' CTEST2 = ',CTEST2
IF (ctest1 == ctest2) THEN
!CCCC PRINT*,' MACHINE WORD LENGTH IS 8 BYTES'
lw = 8
ELSE
!CCCC PRINT*,' MACHINE WORD LENGTH IS 4 BYTES'
lw = 4
END IF
RETURN
END SUBROUTINE w3fi01
SUBROUTINE w3fi04(iendn,itypec,lw)
!$$$ SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM: W3FI04 FIND WORD SIZE, ENDIAN, CHARACTER SET
! PRGMNR: JONES,R.E. ORG: W/NMC42 DATE: 94-10-07
!
! ABSTRACT: SUBROUTINE COMPUTES WORD SIZE, THE TYPE OF CHARACTER
! SET, ASCII OR EBCDIC, AND IF THE COMPUTER IS BIG-ENDIAN, OR
! LITTLE-ENDIAN.
!
! PROGRAM HISTORY LOG:
! 94-10-07 R.E.JONES
!
! USAGE: CALL W3FI04 (IENDN, ITYPEC, LW)
!
! OUTPUT ARGUMENT LIST:
! IENDN - INTEGER FOR BIG-ENDIAN OR LITTLE-ENDIAN
! = 0 BIG-ENDIAN
! = 1 LITTLE-ENDIAN
! = 2 CANNOT COMPUTE
! ITYPEC - INTEGER FOR TYPE OF CHARACTER SET
! = 0 ASCII CHARACTER SET
! = 1 EBCDIC CHARACTER SET
! = 2 NOT ASCII OR EBCDIC
! LW - INTEGER FOR WORDS SIZE OF COMPUTER IN BYTES
! = 4 FOR 32 BIT COMPUTERS
! = 8 FOR 64 BIT COMPUTERS
!
! ATTRIBUTES:
! LANGUAGE: SiliconGraphics 3.5 FORTRAN 77
! MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, INDY
!
!$$$
!
INTEGER :: itest1
INTEGER :: itest2
INTEGER :: itest3
INTEGER :: iendn
INTEGER :: itypec
INTEGER :: lw
!
CHARACTER (LEN=8) :: ctest1
CHARACTER (LEN=8) :: ctest2
CHARACTER (LEN=1) :: ctest3(8)
CHARACTER (LEN=1) :: BLANK
!
EQUIVALENCE (ctest1,itest1),(ctest2,itest2)
!
EQUIVALENCE (itest3,ctest3(1))
!
DATA ctest1/'12345678'/
DATA itest3/z'01020304'/
DATA BLANK /' '/
!
SAVE
!
! TEST FOR TYPE OF CHARACTER SET
! BLANK IS 32 (20 HEX) IN ASCII, 64 (40 HEX) IN EBCDEC
!
IF (ICHAR(BLANK) == 32) THEN
itypec = 0
ELSE IF (ICHAR(BLANK) == 64) THEN
!
! COMPUTER IS PROBABLY AN IBM360, 370, OR 390 WITH
! A 32 BIT WORD SIZE, AND BIG-ENDIAN.
!
itypec = 1
ELSE
itypec = 2
END IF
!
! TEST FOR WORD SIZE, SET LW TO 4 FOR 32 BIT COMPUTER,
! 8 FOR FOR 64 BIT COMPUTERS
!
itest2 = itest1
IF (ctest1 == ctest2) THEN
!
! COMPUTER MAY BE A CRAY, OR COULD BE DEC VAX ALPHA
! OR SGI WITH R4000, R4400, R8800 AFTER THEY CHANGE
! FORTRAN COMPILERS FOR 64 BIT INTEGER.
!
lw = 8
ELSE
lw = 4
END IF
!
! IF CHARACTER SET IS NOT ASCII OR EBCDIC SET IENDN = 2
! CAN NOT TEST FOR ENDIAN TYPE
!
IF (itypec == 2) THEN
iendn = 2
RETURN
END IF
!
! USING ITEST3 WITH Z'01020304' EQUIVALNCED TO CTEST3
! ON A 32 BIT BIG-ENDIAN COMPUTER 03 IS IN THE 3RD
! BYTE OF A 4 BYTE WORD. ON A 32 BIT LITTLE-ENDIAN
! COMPUTER IT IS IN 2ND BYTE.
! ON A 64 BIT COMPUTER Z'01020304' IS RIGHT ADJUSTED IN
! A 64 BIT WORD, 03 IS IN THE 7TH BYTE. ON A LITTLE-
! ENDIAN 64 BIT COMPUTER IT IS IN THE 2ND BYTE.
!
IF (lw == 4) THEN
IF (ICHAR(ctest3(3)) == 3) THEN
iendn = 0
ELSE IF (ICHAR(ctest3(3)) == 2) THEN
iendn = 1
ELSE
iendn = 2
END IF
ELSE IF (lw == 8) THEN
IF (ICHAR(ctest3(7)) == 3) THEN
iendn = 0
ELSE IF (ICHAR(ctest3(2)) == 3) THEN
iendn = 1
ELSE
iendn = 2
END IF
ELSE
iendn = 2
END IF
!
RETURN
END SUBROUTINE w3fi04