SUBROUTINE W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: W3AI08 UNPK GRIB FIELD TO GRIB GRID
C PRGMMR: BOSTELMAN ORG: NMC421 DATE:90-07-31
C
C ABSTRACT: UNPACK A GRIB FIELD TO THE EXACT GRID SPECIFIED IN THE
C MESSAGE, ISOLATE THE BIT MAP AND MAKE THE VALUES OF THE PRODUCT
C DESCRIPTION SEC (PDS) AND THE GRID DESCRIPTION SEC (GDS)
C AVAILABLE IN RETURN ARRAYS.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 90-05-11 CAVANAUGH TO ASSURE THAT ALL U.S. GRIDS IN THE
C GRIB DECODER COMPLY WITH SIZE CHANGES
C IN THE DECEMBER 1989 REVISIONS.
C 90-05-24 CAVANAUGH CORRECTS SEARCHING AN IMPROPER LOCATION
C FOR GRIB VERSION NUMBER IN GRIB MESSAGES.
C 90-07-15 BOSTELMAN MODIIFED SUB. AI084 SO THAT IT WILL TEST
C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT
C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED.
C 90-09-14 R.E.JONES CHANGE'S FOR ANSI FORTRAN, AND PDS VERSION 1
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C 02-10-15 VUONG REPLACED FUNCTION ICHAR WITH MOVA2I
C
C USAGE: CALL W3AI08(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET)
C INPUT ARGUMENT LIST:
C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1
C
C OUTPUT ARGUMENT LIST:
C DATA - ARRAY CONTAINING DATA ELEMENTS
C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 0)
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR INCLUDING CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - GRIB SPECIFICATION EDITION NUMBER
C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1)
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR INCLUDING CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C (19) - VERSION NR OF PARAMETER TABLE
C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0)
C KGDS - ARRAY CONTAINING GDS ELEMENTS.
C (1) - DATA REPRESENTATION TYPE
C LATITUDE/LONGITUDE GRIDS
C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESOLUTION FLAG
C (7) - LA(2) LATITUDE OF EXTREME POINT
C (8) - LO(2) LONGITUDE OF EXTREME POINT
C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT
C (10) - DJ LATITUNDINAL DIRECTION OF INCREMENT
C (11) - SCANNING MODE FLAG
C POLAR STEREOGRAPHIC GRIDS
C (2) - N(I) NR POINTS ALONG LAT CIRCLE
C (3) - N(J) NR POINTS ALONG LON CIRCLE
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESERVED
C (7) - LOV GRID ORIENTATION
C (8) - DX - X DIRECTION INCREMENT
C (9) - DY - Y DIRECTION INCREMENT
C (10) - PROJECTION CENTER FLAG
C (11) - SCANNING MODE
C SPHERICAL HARMONIC COEFFICIENTS
C (2) - J PENTAGONAL RESOLUTION PARAMETER
C (3) - K " " "
C (4) - M " " "
C (5) - REPRESENTATION TYPE
C (6) - COEFFICIENT STORAGE MODE
C MERCATOR GRIDS
C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESOLUTION FLAG
C (7) - LA(2) LATITUDE OF LAST GRID POINT
C (8) - LO(2) LONGITUDE OF LAST GRID POINT
C (9) - LONGIT DIR INCREMENT
C (10) - LATIT DIR INCREMENT
C (11) - SCANNING MODE FLAG
C (12) - LATITUDE INTERSECTION
C LAMBERT CONFORMAL GRIDS
C (2) - NX NR POINTS ALONG X-AXIS
C (3) - NY NR POINTS ALONG Y-AXIS
C (4) - LA1 LAT OF ORIGIN (LOWER LEFT)
C (5) - LO1 LON OF ORIGIN (LOWER LEFT)
C (6) - RESERVED
C (7) - LOV - ORIENTATION OF GRID
C (8) - DX - X-DIR INCREMENT
C (9) - DY - Y-DIR INCREMENT
C (10) - PROJECTION CENTER FLAG
C (11) - SCANNING MODE FLAG
C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C KRET - FLAG INDICATING QUALITY OF COMPLETION
C
C REMARKS: VALUES FOR RETURN FLAG (KRET)
C KRET = 0 - NORMAL RETURN, NO ERRORS
C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS
C = 2 - '7777' NOT IN CORRECT LOCATION
C = 3 - UNPACKED FIELD IS LARGER THAN 32768
C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES
C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED
C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF
C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
C =10 - INCORRECT CENTER INDICATOR
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C 4 AUG 1988
C W3AI08
C
C
C GRIB UNPACKING ROUTINE
C
C
C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID
C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE
C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID
C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS.
C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT
C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN
C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE
C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER.
C
C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS:
C
C CALL W3AI08(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET)
C
C INPUT:
C
C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS
C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES.
C
C OUTPUT:
C
C KPDS(100) INTEGER
C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT
C DEFINITION SEC .
C (VERSION 0)
C KPDS(1) - ID OF CENTER
C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
C KPDS(4) - GDS/BMS FLAG
C BIT DEFINITION
C 25 0 - GDS OMITTED
C 1 - GDS INCLUDED
C 26 0 - BMS OMITTED
C 1 - BMS INCLUDED
C NOTE:- LEFTMOST BIT = 1,
C RIGHTMOST BIT = 32
C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
C KPDS(8) - YEAR OF CENTURY
C KPDS(9) - MONTH OF YEAR
C KPDS(10) - DAY OF MONTH
C KPDS(11) - HOUR OF DAY
C KPDS(12) - MINUTE OF HOUR
C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
C TABLE 8)
C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
C KPDS(17) - NUMBER INCLUDED IN AVERAGE
C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
C
C (VERSION 1)
C KPDS(1) - ID OF CENTER
C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1)
C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2)
C KPDS(4) - GDS/BMS FLAG
C BIT DEFINITION
C 25 0 - GDS OMITTED
C 1 - GDS INCLUDED
C 26 0 - BMS OMITTED
C 1 - BMS INCLUDED
C NOTE:- LEFTMOST BIT = 1,
C RIGHTMOST BIT = 32
C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5)
C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7)
C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL
C KPDS(8) - YEAR INCLUDING CENTURY
C KPDS(9) - MONTH OF YEAR
C KPDS(10) - DAY OF MONTH
C KPDS(11) - HOUR OF DAY
C KPDS(12) - MINUTE OF HOUR
C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB"
C TABLE 8)
C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A)
C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A)
C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A)
C KPDS(17) - NUMBER INCLUDED IN AVERAGE
C KPDS(18) - VERSION NR OF GRIB SPECIFICATION
C KPDS(19) - VERSION NR OF PARAMETER TABLE
C KPDS(20) - TOTAL LENGTH 0F GRIB MESSAGE
C (INCLUDING SECTION 0)
C KGDS(13) INTEGER
C ARRAY CONTAINING GDS ELEMENTS.
C
C KGDS(1) - DATA REPRESENTATION TYPE
C
C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10)
C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE
C CIRCLE
C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE
C CIRCLE
C KGDS(4) - LA(1) LATITUDE OF ORIGIN
C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
C KGDS(6) - RESOLUTION FLAG
C BIT MEANING
C 25 0 - DIRECTION INCREMENTS NOT
C GIVEN
C 1 - DIRECTION INCREMENTS GIVEN
C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT
C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT
C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT
C KGDS(10) - REGULAR LAT/LON GRID
C DJ - LATITUDINAL DIRECTION
C INCREMENT
C GAUSSIAN GRID
C N - NUMBER OF LATITUDE CIRCLES
C BETWEEN A POLE AND THE EQUATOR
C KGDS(11) - SCANNING MODE FLAG
C BIT MEANING
C 25 0 - POINTS ALONG A LATITUDE
C SCAN FROM WEST TO EAST
C 1 - POINTS ALONG A LATITUDE
C SCAN FROM EAST TO WEST
C 26 0 - POINTS ALONG A MERIDIAN
C SCAN FROM NORTH TO SOUTH
C 1 - POINTS ALONG A MERIDIAN
C SCAN FROM SOUTH TO NORTH
C 27 0 - POINTS SCAN FIRST ALONG
C CIRCLES OF LATITUDE, THEN
C ALONG MERIDIANS
C (FORTRAN: (I,J))
C 1 - POINTS SCAN FIRST ALONG
C MERIDIANS THEN ALONG
C CIRCLES OF LATITUDE
C (FORTRAN: (J,I))
C
C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12)
C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE
C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE
C KGDS(4) - LA(1) LATITUDE OF ORIGIN
C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
C KGDS(6) - RESERVED
C KGDS(7) - LOV GRID ORIENTATION
C KGDS(8) - DX - X DIRECTION INCREMENT
C KGDS(9) - DY - Y DIRECTION INCREMENT
C KGDS(10) - PROJECTION CENTER FLAG
C KGDS(11) - SCANNING MODE
C
C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14)
C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER
C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER
C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER
C KGDS(5) - REPRESENTATION TYPE
C KGDS(6) - COEFFICIENT STORAGE MODE
C
C MERCATOR GRIDS
C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE
C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
C KGDS(4) - LA(1) LATITUDE OF ORIGIN
C KGDS(5) - LO(1) LONGITUDE OF ORIGIN
C KGDS(6) - RESOLUTION FLAG
C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT
C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT
C KGDS(9) - LONGIT DIR INCREMENT
C KGDS(10) - LATIT DIR INCREMENT
C KGDS(11) - SCANNING MODE FLAG
C KGDS(12) - LATITUDE INTERSECTION
C LAMBERT CONFORMAL GRIDS
C KGDS(2) - NX NR POINTS ALONG X-AXIS
C KGDS(3) - NY NR POINTS ALONG Y-AXIS
C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT)
C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT)
C KGDS(6) - RESERVED
C KGDS(7) - LOV - ORIENTATION OF GRID
C KGDS(8) - DX - X-DIR INCREMENT
C KGDS(9) - DY - Y-DIR INCREMENT
C KGDS(10) - PROJECTION CENTER FLAG
C KGDS(11) - SCANNING MODE FLAG
C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF
C SECANT CONE INTERSECTION
C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF
C SECANT CONE INTERSECTION
C
C LBMS(32768) LOGICAL
C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE
C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A
C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE,
C ONE WILL BE GENERATED AUTOMATICALLY BY THE
C UNPACKING ROUTINE.
C
C
C DATA(32768) REAL
C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS.
C
C NOTE:- 32768 IS MAXIMUN FIELD SIZE ALLOWABLE
C
C KPTR(10) INTEGER
C ARRAY CONTAINING STORAGE FOR THE FOLLOWING
C PARAMETERS.
C
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS (IN BYTES)
C (4) - LENGTH OF GDS (IN BYTES)
C (5) - LENGTH OF BMS (IN BYTES)
C (6) - LENGTH OF BDS (IN BYTES)
C (7) - USED BY UNPACKING ROUTINE
C (8) - NUMBER OF DATA POINTS FOR GRID
C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER
C (10) - USED BY UNPACKING ROUTINE
C
C
C KRET INTEGER
C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR.
C
C 0 - NO ERRORS DETECTED.
C
C 1 - 'GRIB' NOT FOUND IN FIRST 100
C CHARACTERS.
C
C 2 - '7777' NOT FOUND, EITHER MISSING OR
C TOTAL OF SEC COUNTS OF INDIVIDUAL
C SEC'S IS INCORRECT.
C
C 3 - UNPACKED FIELD IS LARGER THAN 32768.
C
C 4 - IN GDS, DATA REPRESENTATION TYPE
C NOT ONE OF THE CURRENTLY ACCEPTABLE
C VALUES. SEE "GRIB" TABLE 9. VALUE
C OF INCORRECT TYPE RETURNED IN KGDS(1).
C
C 5 - GRID INDICATED IN KPDS(3) IS NOT
C AVAILABLE FOR THE CENTER INDICATED IN
C KPDS(1) AND NO GDS SENT.
C
C 7 - VERSION INDICATED IN KPDS(18) HAS NOT
C YET BEEN INCLUDED IN THE DECODER.
C
C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD
C GRID) BUT FLAG INDICATING PRESENCE OF
C GDS IS TURNED OFF. NO METHOD OF
C GENERATING PROPER GRID.
C
C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT
C MATCH STANDARD NUMBER OF POINTS FOR THIS
C GRID (FOR OTHER THAN SPECTRALS). THIS
C WILL OCCUR ONLY IF THE GRID.
C IDENTIFICATION, KPDS(3), AND A
C TRANSMITTED GDS ARE INCONSISTENT.
C
C 10 - CENTER INDICATOR WAS NOT ONE INDICATED
C IN "GRIB" TABLE 1. PLEASE CONTACT AD
C PRODUCTION MANAGEMENT BRANCH (W/NMC42)
C IF THIS ERROR IS ENCOUNTERED.
C
C
C
C LIST OF TEXT MESSAGES FROM CODE
C
C
C W3AI08/AI082
C
C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY
C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
C (W/NMC42)'
C
C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY
C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
C (W/NMC42)'
C
C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL
C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION,
C PRODUCTION MANAGEMENT BRANCH (W/NMC42)'
C
C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY
C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH
C (W/NMC42)'
C
C
C W3AI08/AI083
C
C 'POLAR STEREO PROCESSING NOT AVAILABLE' *
C
C W3AI08/AI084
C
C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL
C COEFFICIENTS'
C
C
C W3AI08/AI087
C
C 'NO CURRENT LISTING OF FNOC GRIDS' *
C
C
C * WILL BE AVAILABLE IN NEXT UPDATE
C ***************************************************************
C
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C BIT MAP
LOGICAL KBMS(*)
C
C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS)
INTEGER KPDS(*)
C ELEMENTS OF GRID DESCRIPTION SEC (PDS)
INTEGER KGDS(*)
C
C CONTAINER FOR GRIB GRID
REAL DATA(*)
C
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(*)
C
C *****************************************************************
C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE
C FIND 'GRIB' CHARACTERS
C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE
C IF '7777' IS IN PROPER PLACE.
C 3.0 PARSE PRODUCT DEFINITION SECTION.
C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED)
C 5.0 PARSE BIT MAP SEC (IF INCLUDED)
C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID
C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT
C DATA AND PLACE INTO PROPER ARRAY.
C *******************************************************************
C
C MAIN DRIVER
C
C *******************************************************************
KPTR(10) = 0
C SEE IF PROPER 'GRIB' KEY EXISTS, THEN
C USING SEC COUNTS, DETERMINE IF '7777'
C IS IN THE PROPER LOCATION
C
CALL AI081(MSGA,KPTR,KPDS,KRET)
IF (KRET.NE.0) GO TO 900
C
C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION
C
IF (KPDS(18).EQ.0) THEN
CALL AI082(MSGA,KPTR,KPDS,KRET)
ELSE IF (KPDS(18).EQ.1) THEN
CALL AI082A(MSGA,KPTR,KPDS,KRET)
ELSE
PRINT *,'GRIB EDITION',KPDS(18),' NOT PROGRAMMED FOR'
KRET = 7
GO TO 900
END IF
IF (KRET.NE.0) GO TO 900
C
C EXTRACT NEW GRID DESCRIPTION
C
CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET)
IF (KRET.NE.0) GO TO 900
C
C EXTRACT OR GENERATE BIT MAP
C
CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
IF (KRET.NE.0) GO TO 900
C
C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC ,
C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES.
C
IF (KPDS(18).EQ.0) THEN
CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
ELSE IF (KPDS(18).EQ.1) THEN
CALL AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
ELSE
PRINT *,'AI085 NOT PROGRAMMED FOR VERSION NR',KPDS(18)
KRET = 7
END IF
C
900 RETURN
END
SUBROUTINE AI081(MSGA,KPTR,KPDS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI081 FIND 'GRIB' CHARS & RESET POINTERS
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT
C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND
C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY
C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C
C USAGE: CALL AI081(MSGA,KPTR,KPDS,KRET)
C INPUT ARGUMENT LIST:
C MSGA - GRIB FIELD - "GRIB" THRU "7777"
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE
C (10) - GRIB/GRID ELEMENT COUNT
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR OF CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C KPTR - SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C ERROR RETURNS
C KRET = 1 - NO 'GRIB'
C 2 - NO '7777' OR MISLOCATED (BY COUNTS)
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(*)
C PRODUCT DESCRIPTION SECTION DATA.
INTEGER KPDS(*)
C
INTEGER KRET
C
C DATA MASK40/Z00000040/
C DATA MASK80/Z00000080/
C
DATA MASK40/64/
DATA MASK80/128/
C
C ******************************************************************
KRET = 0
C ------------------- FIND 'GRIB' KEY
DO 100 I = 1, 105
IF (MOVA2I(MSGA(I )).NE.71) GO TO 100
IF (MOVA2I(MSGA(I+1)).NE.82) GO TO 100
IF (MOVA2I(MSGA(I+2)).NE.73) GO TO 100
IF (MOVA2I(MSGA(I+3)).NE.66) GO TO 100
KPTR(9) = I
GO TO 200
100 CONTINUE
KRET = 1
RETURN
C
200 CONTINUE
IS = KPTR(9)
C ------------------- HAVE 'GRIB' KEY
KCNT = 0
C --------------- EXTRACT COUNT FROM PDS OR GRIB
ISS = IS + 4
DO 300 I = 0, 2
KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS))
300 CONTINUE
C
C TEST FOR VERSION NUMBER OF PDS 0 OR 1
C
IF (KCNT.EQ.24) THEN
KPTR(3) = KCNT
IGRIBL = 4
C
C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 0
C
KPDS(18) = MOVA2I(MSGA(ISS + 3))
ELSE
IGRIBL = 8
ISS = IS + IGRIBL
C --------------- EDITION NR OF GRIB SPECIFICATION, VERSION 1
KPDS(18) = MOVA2I(MSGA(IS + 7))
C
C --------------- PARAMETER TABLE VERSION NUMBER FOR INTERNATIONAL
C EXCHANGE (CURRENTLY NO. 1)
C
KPDS(19) = MOVA2I(MSGA(ISS + 3))
C
C ---------------- SAVE TOTAL LENGTH OF MESSAGE (INCLUDING SECTION 0)
C
KPDS(20) = KCNT
C
C --------------- EXTRACT COUNT FROM PDS VERSION 1
C
KCNT = 0
DO 400 I = 0, 2
KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS))
400 CONTINUE
KPTR(3) = KCNT
ENDIF
C
C --------------- GET GDS, BMS INDICATOR
C
KPDS(4) = MOVA2I(MSGA(ISS+7))
C
C READY FOR NEXT SECTION
C
KPTR(4) = 0
KPTR(5) = 0
IF (IAND(KPDS(4),MASK80).EQ.0) GO TO 600
C
C --------------- EXTRACT COUNT FROM GDS
C
ISS = KPTR(3) + IS + IGRIBL
KCNT = 0
DO 500 I = 0, 2
KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS))
500 CONTINUE
KPTR(4) = KCNT
600 CONTINUE
IF (IAND(KPDS(4),MASK40).EQ.0) GO TO 800
C
C ---------------- EXTRACT COUNT FROM BMS
C
ISS = KPTR(3) + KPTR(4) + IS + IGRIBL
KCNT = 0
DO 700 I = 0, 2
KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS))
700 CONTINUE
KPTR(5) = KCNT
C
C --------------- EXTRACT COUNT FROM BDS
C
800 CONTINUE
KCNT = 0
ISS = KPTR(3) + KPTR(4) + KPTR(5) + IS + IGRIBL
DO 900 I = 0, 2
KCNT = KCNT * 256 + MOVA2I(MSGA(I+ISS))
900 CONTINUE
KPTR(6) = KCNT
C
C --------------- TEST FOR '7777'
C
ISS = KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + IS + IGRIBL
KRET = 0
DO 1000 I = 0, 3
IF (MOVA2I(MSGA(I+ISS)).EQ.55) THEN
GO TO 1000
ELSE
KRET = 2
RETURN
END IF
1000 CONTINUE
RETURN
END
SUBROUTINE AI082(MSGA,KPTR,KPDS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI082 GATHER INFO FROM PGM DESC SECTION
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION
C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE
C IN OFFICE NOTE 84 FORMAT.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI082(MSGA,KPTR,KPDS,KRET)
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING GRIB MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF PDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR OF CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NUMBER OF GRIB SPEFICATION
C (19) - VERSION NR OF PARAMETER TABLE
C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0)
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C ERROR RETURN = 0 - NO ERRORS
C = 8 - TEMP GDS INDICATED, BUT NO GDS
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(*)
C PRODUCT DESCRIPTION SECTION ENTRIES
INTEGER KPDS(*)
C
INTEGER KRET
C
C -------------------- COLLECT PDS VALUES
C KPDS(1) - ID OF CENTER
C KPDS(2) - MODEL IDENTIFICATION
C KPDS(3) - GRID IDENTIFICATION
C KPDS(4) - GDS/BMS FLAG
C KPDS(5) - INDICATOR OF PARAMETER
C ----------- KPDS(6) - TYPE OF LEVEL
IS = KPTR(9)
ISS = IS + 8
DO 200 I = 0, 5
KPDS(I+1) = MOVA2I(MSGA(I+ISS))
200 CONTINUE
IF (KPDS(3).NE.255) GO TO 250
IF (IAND(KPDS(4),128).NE.0) GO TO 250
KRET = 8
RETURN
250 CONTINUE
ISS = IS + 14
KPDS(7) = 0
DO 300 I = 0, 1
KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS))
300 CONTINUE
C ----------- KPDS(8) - YEAR OF CENTURY
C KPDS(9) - MONTH OF YEAR
C KPDS(10) - DAY OF MONTH
C KPDS(11) - HOUR OF DAY
C KPDS(12) - MINUTE OF HOUR
C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
C KPDS(14) - TIME RANGE 1
C KPDS(15) - TIME RANGE 2
C ----------- KPDS(16) - TIME RANGE FLAG
C
ISS = IS + 16
DO 400 I = 0, 7
KPDS(I+8) = MOVA2I(MSGA(I+ISS))
400 CONTINUE
C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
ISS = IS + 25
KPDS(17) = 0
DO 500 I = 0, 1
KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS))
500 CONTINUE
C -----------SKIP OVER SOURCE BYTE 24
C ----------- TEST FOR NEW GRID
IF (IAND(KPDS(4),128).NE.0) THEN
IF (IAND(KPDS(4),64).NE.0) THEN
IF (KPDS(3).NE.255) THEN
IF (KPDS(1).EQ.7) THEN
IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN
ELSE IF (KPDS(3).EQ.50) THEN
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
ELSE IF (KPDS(3).EQ.70) THEN
ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN
ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN
ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' NMC'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.98) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' ECMWF'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.74) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
ELSE IF (KPDS(3).EQ.70) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' U.K. MET OFFICE, BRACKNELL'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.58) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' FNOC,'
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 AI082A(MSGA,KPTR,KPDS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI082A GATHER INFO FROM PGM DESC SECTION
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION SECTION
C (VERSION 1)
C
C PROGRAM HISTORY LOG:
C 89-11-20 CAVANAUGH
C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI082A(MSGA,KPTR,KPDS,KRET)
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING GRIB MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF PDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C
C OUTPUT ARGUMENT LIST:
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR (INCLUDING CENTURY)
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C (19) - VERSION NR OF PARAMETER TABLE
C (20) - TOTAL BYTE COUNT FOR SOURCE MESSAGE
C
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C SOURCE PDS STRUCTURE (VERSION 1)
C 1-3 - LENGTH OF PDS SECTION IN BYTES
C 4 - PARAMETER TABLE VERSION NO. FOR INTERNATIONAL
C EXCHANGE (CRRENTLY NO. 1)
C 5 - CENTER ID
C 6 - MODEL ID
C 7 - GRID ID
C 8 - FLAG FOR GDS/BMS
C 9 - INDICATOR FOR PARAMETER
C 10 - INDICATOR FOR TYPE OF LEVEL
C 11-12 - HEIGHT, PRESSURE OF LEVEL
C 13 - YEAR OF CENTURY
C 14 - MONTH
C 15 - DAY
C 16 - HOUR
C 17 - MINUTE
C 18 - FORECAST TIME UNIT
C 19 - P1 - PD OF TIME
C 20 - P2 - PD OF TIME
C 21 - TIME RANGE INDICATOR
C 22-23 - NUMBER IN AVERAGE
C 24 - NUMBER MISG FROM AVERAGES
C 25 - CENTURY
C 26 - INDICATOR OF PARAMETER IN LOCALLY RE-DEFINED
C PARAMETER TABLE.
C 27-28 - UNITS DECIMAL SCALE FACTOR (D)
C 29-40 - RESERVED: NEED NOT BE PRESENT
C 41-NN - NATIONAL USE
C .
C
C ERROR RETURN = 0 - NO ERRORS
C = 8 - TEMP GDS INDICATED, BUT NO GDS
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(*)
C PRODUCT DESCRIPTION SECTION ENTRIES
INTEGER KPDS(*)
C
INTEGER KRET
C
IS = KPTR(9)
IGRIBL = 8
C -------------------- COLLECT PDS VALUES
C KPDS(1) - ID OF CENTER
C KPDS(2) - MODEL IDENTIFICATION
C KPDS(3) - GRID IDENTIFICATION
C KPDS(4) - GDS/BMS FLAG
C KPDS(5) - INDICATOR OF PARAMETER
C ----------- KPDS(6) - TYPE OF LEVEL
ISS = IS + IGRIBL + 4
DO 200 I = 0, 5
KPDS(I+1) = MOVA2I(MSGA(I+ISS))
200 CONTINUE
IF (KPDS(3).NE.255) GO TO 250
IF (IAND(KPDS(4),128).NE.0) GO TO 250
KRET = 8
RETURN
250 CONTINUE
C HEIGHT, PRESS OF LEVEL
ISS = IS + IGRIBL + 10
KPDS(7) = 0
DO 300 I = 0, 1
KPDS(7) = KPDS(7) * 256 + MOVA2I(MSGA(I+ISS))
300 CONTINUE
C
C ----------- KPDS(8) - YEAR (INCLUDING CENTURY)
C
ISS = IS + IGRIBL + 12
ICEN = IS + IGRIBL + 24
C
KPDS(8) = MOVA2I(MSGA(ICEN)) * 100 + MOVA2I(MSGA(ISS))
C
C KPDS(9) - MONTH OF YEAR
C KPDS(10) - DAY OF MONTH
C KPDS(11) - HOUR OF DAY
C KPDS(12) - MINUTE OF HOUR
C KPDS(13) - INDICATOR OF FORECAST TIME UNIT
C KPDS(14) - TIME RANGE 1
C KPDS(15) - TIME RANGE 2
C ----------- KPDS(16) - TIME RANGE FLAG
C
ISS = IS + IGRIBL + 13
DO 400 I = 0, 7
KPDS(I+9) = MOVA2I(MSGA(I+ISS))
400 CONTINUE
C ----------- KPDS(17) - NUMBER INCLUDED IN AVERAGE
ISS = IS + IGRIBL + 21
KPDS(17) = 0
DO 500 I = 0, 1
KPDS(17) = KPDS(17) * 256 + MOVA2I(MSGA(I+ISS))
500 CONTINUE
C -----------SKIP OVER SOURCE BYTE 28
C ----------- TEST FOR NEW GRID
IF (IAND(KPDS(4),128).NE.0) THEN
IF (IAND(KPDS(4),64).NE.0) THEN
IF (KPDS(3).NE.255) THEN
IF (KPDS(1).EQ.7) THEN
IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN
ELSE IF (KPDS(3).EQ.50) THEN
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
ELSE IF (KPDS(3).EQ.70) THEN
ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.86) THEN
ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.103) THEN
ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' NMC'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.98) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' ECMWF'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.74) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
ELSE IF (KPDS(3).EQ.70) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' U.K. MET OFFICE, BRACKNELL'
PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION'
PRINT *,' PRODUCTION MANAGEMENT BRANCH'
PRINT *,' W/NMC42)'
END IF
ELSE IF (KPDS(1).EQ.58) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
ELSE
PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR',
* ' FNOC,'
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 AI083(MSGA,KPTR,KPDS,KGDS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI083 EXTRACT INFO FROM GRIB-GDS
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW
C CONVERSION TO OFFICE NOTE 84 FORMAT.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 89-03-16 CAVANAUGH ADDED MERCATOR & LAMBERT CONFORMAL PROCESSING
C 89-07-12 CAVANAUGH CORRECTED CHANGE ENTERED 89-03-16 REORDERING
C PROCESSING FOR LAMBERT CONFORMAL AND MERCATOR
C GRIDS.
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C
C USAGE: CALL AI083(MSGA,KPTR,KPDS,KGDS,KRET)
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING GRIB MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR OF CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KGDS - ARRAY CONTAINING GDS ELEMENTS.
C (1) - DATA REPRESENTATION TYPE
C LATITUDE/LONGITUDE GRIDS
C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESOLUTION FLAG
C (7) - LA(2) LATITUDE OF EXTREME POINT
C (8) - LO(2) LONGITUDE OF EXTREME POINT
C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT
C (10) - DJ LATITUDINAL DIRECTION OF INCREMENT
C (11) - SCANNING MODE FLAG
C POLAR STEREOGRAPHIC GRIDS
C (2) - N(I) NR POINTS ALONG LAT CIRCLE
C (3) - N(J) NR POINTS ALONG LON CIRCLE
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESERVED
C (7) - LOV GRID ORIENTATION
C (8) - DX - X DIRECTION INCREMENT
C (9) - DY - Y DIRECTION INCREMENT
C (10) - PROJECTION CENTER FLAG
C (11) - SCANNING MODE
C SPHERICAL HARMONIC COEFFICIENTS
C (2) - J PENTAGONAL RESOLUTION PARAMETER
C (3) - K " " "
C (4) - M " " "
C (5) - REPRESENTATION TYPE
C (6) - COEFFICIENT STORAGE MODE
C MERCATOR GRIDS
C (2) - N(I) NR POINTS ON LATITUDE CIRCLE
C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN
C (4) - LA(1) LATITUDE OF ORIGIN
C (5) - LO(1) LONGITUDE OF ORIGIN
C (6) - RESOLUTION FLAG
C (7) - LA(2) LATITUDE OF LAST GRID POINT
C (8) - LO(2) LONGITUDE OF LAST GRID POINT
C (9) - LONGIT DIR INCREMENT
C (10) - LATIT DIR INCREMENT
C (11) - SCANNING MODE FLAG
C (12) - LATITUDE INTERSECTION
C LAMBERT CONFORMAL GRIDS
C (2) - NX NR POINTS ALONG X-AXIS
C (3) - NY NR POINTS ALONG Y-AXIS
C (4) - LA1 LAT OF ORIGIN (LOWER LEFT)
C (5) - LO1 LON OF ORIGIN (LOWER LEFT)
C (6) - RESERVED
C (7) - LOV - ORIENTATION OF GRID
C (8) - DX - X-DIR INCREMENT
C (9) - DY - Y-DIR INCREMENT
C (10) - PROJECTION CENTER FLAG
C (11) - SCANNING MODE FLAG
C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER
C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C KRET = 0
C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C ************************************************************
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C
C ARRAY GDS ELEMENTS
INTEGER KGDS(*)
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(*)
C ARRAY OF PDS ELEMENTS
INTEGER KPDS(*)
C
INTEGER KRET
C
C DATA MSK80 /Z00000080/
C
DATA MSK80 /128/
C ********************************************************
C IF FLAG IN PDS INDICATE THAT THERE IS NO GDS ,
C RETURN IMMEDIATELY
C ************************************************************
IF (IAND(KPDS(4),MSK80).EQ.0) GO TO 900
C ------------------- BYTE 1-3 COUNT
IS = KPTR(9)
IF (KPDS(18).EQ.0) THEN
IGRIBL = 4
ELSE
IGRIBL = 8
ENDIF
ISS = IS + KPTR(3) + IGRIBL
C ------------------- BYTE 4 NUMBER OF UNUSED BITS AT END OF SEC
C ------------------- BYTE 5 RESERVED
C ------------------- BYTE 6 DATA REPRESENTATION TYPE
KGDS(1) = MOVA2I(MSGA(ISS+5))
C ------------------- DIVERT TO PROCESS CORRECT TYPE
IF (KGDS(1).EQ.0) THEN
GO TO 1000
ELSE IF (KGDS(1).EQ.1) THEN
GO TO 4000
ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN
GO TO 2000
ELSE IF (KGDS(1).EQ.3) THEN
GO TO 5000
ELSE IF (KGDS(1).EQ.4) THEN
GO TO 1000
ELSE IF (KGDS(1).EQ.50) THEN
GO TO 3000
ELSE
C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE
KRET = 4
GO TO 900
END IF
C
C ------------------- LATITUDE/LONGITUDE GRIDS
C
C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
1000 KGDS(2) = 0
DO 1005 I = 0, 1
KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6))
1005 CONTINUE
C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
KGDS(3) = 0
DO 1010 I = 0, 1
KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8))
1010 CONTINUE
C ------------------- BYTE 11-13 LATITUE OF ORIGIN
KGDS(4) = 0
DO 1020 I = 0, 2
KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10))
1020 CONTINUE
IF (IAND(KGDS(4),8388608).NE.0) THEN
KGDS(4) = IAND(KGDS(4),8388607) * (-1)
END IF
C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
KGDS(5) = 0
DO 1030 I = 0, 2
KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13))
1030 CONTINUE
IF (IAND(KGDS(5),8388608).NE.0) THEN
KGDS(5) = - IAND(KGDS(5),8388607)
END IF
C ------------------- BYTE 17 RESOLUTION FLAG
KGDS(6) = MOVA2I(MSGA(ISS+16))
C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT
KGDS(7) = 0
DO 1040 I = 0, 2
KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17))
1040 CONTINUE
IF (IAND(KGDS(7),8388608).NE.0) THEN
KGDS(7) = - IAND(KGDS(7),8388607)
END IF
C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT
KGDS(8) = 0
DO 1050 I = 0, 2
KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20))
1050 CONTINUE
IF (IAND(KGDS(8),8388608).NE.0) THEN
KGDS(8) = - IAND(KGDS(8),8388607)
END IF
C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT
KGDS(9) = 0
DO 1060 I = 0, 1
KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23))
1060 CONTINUE
C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID
C HAVE LONGIT DIR INCREMENT
C ELSE IF GAUSSIAN GRID
C HAVE NR OF LAT CIRCLES
C BETWEEN POLE AND EQUATOR
KGDS(10) = 0
DO 1070 I = 0, 1
KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25))
1070 CONTINUE
C ------------------- BYTE 28 SCANNING MODE FLAGS
KGDS(11) = MOVA2I(MSGA(ISS+27))
C ------------------- BYTE 29-32 RESERVED
C -------------------
GO TO 900
C -------------------
C ' POLAR STEREO PROCESSING '
C
C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS
2000 KGDS(2) = 0
DO 2005 I = 0, 1
KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6))
2005 CONTINUE
C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
KGDS(3) = 0
DO 2010 I = 0, 1
KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8))
2010 CONTINUE
C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
KGDS(4) = 0
DO 2020 I = 0, 2
KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10))
2020 CONTINUE
IF (IAND(KGDS(4),8388608).NE.0) THEN
KGDS(4) = - IAND(KGDS(4),8388607)
END IF
C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
KGDS(5) = 0
DO 2030 I = 0, 2
KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13))
2030 CONTINUE
IF (IAND(KGDS(5),8388608).NE.0) THEN
KGDS(5) = - IAND(KGDS(5),8388607)
END IF
C ------------------- BYTE 17 RESERVED
KGDS(6) = MOVA2I(MSGA(ISS+16))
C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID
KGDS(7) = 0
DO 2040 I = 0, 2
KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17))
2040 CONTINUE
IF (IAND(KGDS(7),8388608).NE.0) THEN
KGDS(7) = - IAND(KGDS(7),8388607)
END IF
C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT
KGDS(8) = 0
DO 2050 I = 0, 2
KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20))
2050 CONTINUE
IF (IAND(KGDS(8),8388608).NE.0) THEN
KGDS(8) = - IAND(KGDS(8),8388607)
END IF
C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT
KGDS(9) = 0
DO 2060 I = 0, 2
KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23))
2060 CONTINUE
IF (IAND(KGDS(9),8388608).NE.0) THEN
KGDS(9) = - IAND(KGDS(9),8388607)
END IF
C ------------------- BYTE 27 PROJECTION CENTER FLAG
KGDS(10) = MOVA2I(MSGA(ISS+26))
C ------------------- BYTE 28 SCANNING MODE
KGDS(11) = MOVA2I(MSGA(ISS+27))
C ------------------- BYTE 29-32 RESERVED
C -------------------
GO TO 900
C
C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF.
C
C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER
3000 KGDS(2) = 0
DO 3010 I = 0, 1
KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6))
3010 CONTINUE
C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER
KGDS(3) = 0
DO 3020 I = 0, 1
KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8))
3020 CONTINUE
C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER
KGDS(4) = 0
DO 3030 I = 0, 1
KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10))
3030 CONTINUE
C ------------------- BYTE 13 REPRESENTATION TYPE
KGDS(5) = MOVA2I(MSGA(ISS+12))
C ------------------- BYTE 14 COEFFICIENT STORAGE MODE
KGDS(6) = MOVA2I(MSGA(ISS+13))
C ------------------- EMPTY FIELDS - BYTES 15 - 32
KRET = 0
GO TO 900
C ------------------- PROCESS MERCATOR GRIDS
C
C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE
4000 KGDS(2) = 0
DO 4005 I = 0, 1
KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6))
4005 CONTINUE
C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN
KGDS(3) = 0
DO 4010 I = 0, 1
KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8))
4010 CONTINUE
C ------------------- BYTE 11-13 LATITUE OF ORIGIN
KGDS(4) = 0
DO 4020 I = 0, 2
KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10))
4020 CONTINUE
IF (IAND(KGDS(4),8388608).NE.0) THEN
KGDS(4) = - IAND(KGDS(4),8388607)
END IF
C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN
KGDS(5) = 0
DO 4030 I = 0, 2
KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13))
4030 CONTINUE
IF (IAND(KGDS(5),8388608).NE.0) THEN
KGDS(5) = - IAND(KGDS(5),8388607)
END IF
C ------------------- BYTE 17 RESOLUTION FLAG
KGDS(6) = MOVA2I(MSGA(ISS+16))
C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT
KGDS(7) = 0
DO 4040 I = 0, 2
KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17))
4040 CONTINUE
IF (IAND(KGDS(7),8388608).NE.0) THEN
KGDS(7) = - IAND(KGDS(7),8388607)
END IF
C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT
KGDS(8) = 0
DO 4050 I = 0, 2
KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20))
4050 CONTINUE
IF (IAND(KGDS(8),8388608).NE.0) THEN
KGDS(8) = - IAND(KGDS(8),8388607)
END IF
C ------------------- BYTE 24-25 LONGITUDE DIR INCREMENT
KGDS(9) = 0
DO 4070 I = 0, 1
KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23))
4070 CONTINUE
IF (IAND(KGDS(9),8388608).NE.0) THEN
KGDS(9) = - IAND(KGDS(9),32768)
END IF
C ------------------- BYTE 26-27 LATIT DIR INCREMENT
KGDS(10) = 0
DO 4080 I = 0, 1
KGDS(10) = KGDS(10) * 256 + MOVA2I(MSGA(I+ISS+25))
4080 CONTINUE
IF (IAND(KGDS(10),8388608).NE.0) THEN
KGDS(10) = - IAND(KGDS(10),32768)
END IF
C ------------------- BYTE 28 SCANNING MODE FLAGS
KGDS(11) = MOVA2I(MSGA(ISS+27))
C ------------------- BYTE 29-31 INTERSECTION LATITUDE
KGDS(12) = 0
DO 4060 I = 0, 2
KGDS(12)= KGDS(12) * 256 + MOVA2I(MSGA(I+ISS+28))
4060 CONTINUE
C ------------------- BYTE 32 RESERVED
C -------------------
GO TO 900
C ------------------- PROCESS LAMBERT CONFORMAL
C
C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS
5000 KGDS(2) = 0
DO 5005 I = 0, 1
KGDS(2) = KGDS(2) * 256 + MOVA2I(MSGA(I+ISS+6))
5005 CONTINUE
C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS
KGDS(3) = 0
DO 5010 I = 0, 1
KGDS(3) = KGDS(3) * 256 + MOVA2I(MSGA(I+ISS+8))
5010 CONTINUE
C ------------------- BYTE 11-13 LATITUDE OF ORIGIN
KGDS(4) = 0
DO 5020 I = 0, 2
KGDS(4) = KGDS(4) * 256 + MOVA2I(MSGA(I+ISS+10))
5020 CONTINUE
IF (IAND(KGDS(4),8388608).NE.0) THEN
KGDS(4) = - IAND(KGDS(4),8388607)
END IF
C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT)
KGDS(5) = 0
DO 5030 I = 0, 2
KGDS(5) = KGDS(5) * 256 + MOVA2I(MSGA(I+ISS+13))
5030 CONTINUE
IF (IAND(KGDS(5),8388608).NE.0) THEN
KGDS(5) = - IAND(KGDS(5),8388607)
END IF
C ------------------- BYTE 17 RESERVED
C KGDS(6) =
C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID
KGDS(7) = 0
DO 5040 I = 0, 2
KGDS(7) = KGDS(7) * 256 + MOVA2I(MSGA(I+ISS+17))
5040 CONTINUE
IF (IAND(KGDS(7),8388608).NE.0) THEN
KGDS(7) = - IAND(KGDS(7),8388607)
END IF
C ------------------- BYTE 21-23 DX - X-DIR INCREMENT
KGDS(8) = 0
DO 5060 I = 0, 2
KGDS(8) = KGDS(8) * 256 + MOVA2I(MSGA(I+ISS+20))
5060 CONTINUE
C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT
KGDS(9) = 0
DO 5070 I = 0, 2
KGDS(9) = KGDS(9) * 256 + MOVA2I(MSGA(I+ISS+23))
5070 CONTINUE
C ------------------- BYTE 27 PROJECTION CENTER FLAG
KGDS(10) = MOVA2I(MSGA(ISS+26))
C ------------------- BYTE 28 SCANNING MODE
KGDS(11) = MOVA2I(MSGA(ISS+27))
C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE
KGDS(12) = 0
DO 5050 I = 0, 2
KGDS(12)= KGDS(12)* 256 + MOVA2I(MSGA(I+ISS+28))
5050 CONTINUE
IF (IAND(KGDS(12),8388608).NE.0) THEN
KGDS(12) = - IAND(KGDS(12),8388607)
END IF
C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE
KGDS(13) = 0
DO 5055 I = 0, 2
KGDS(13)= KGDS(13)* 256 + MOVA2I(MSGA(I+ISS+31))
5055 CONTINUE
IF (IAND(KGDS(13),8388608).NE.0) THEN
KGDS(13) = - IAND(KGDS(13),8388607)
END IF
C -------------------
900 CONTINUE
RETURN
END
SUBROUTINE AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI084 EXTRACT OR GENERATE BIT MAP FOR OUTPUT
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT
C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 89-02-24 CAVANAUGH INCREMENT OF POSITION IN BIT MAP WHEN BIT MAP
C WAS INCLUDED WAS HANDLED IMPROPERLY.
C CORRECTED THIS DATA.
C 89-07-12 CAVANAUGH ALTERED METHOD OF CALCULATING NR OF BITS
C IN A BIT MAP CONTAINED IN GRIB MESSAGE.
C 90-05-07 CAVANAUGH BRINGS ALL U.S. GRIDS TO
C REVISED VALUES AS OF DEC 89.
C 90-07-15 BOSTELMAN MODIIFED TO TEST
C THE GRIB BDS BYTE SIZE TO DETERMINE WHAT
C ECMWF GRID ARRAY SIZE IS TO BE SPECIFIED.
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI084(MSGA,KPTR,KPDS,KGDS,KBMS,KRET)
C INPUT ARGUMENT LIST:
C MSGA - BUFR MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR OF CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C
C OUTPUT ARGUMENT LIST:
C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C KRET = 0 - NO ERROR
C = 5 - GRID NOT AVAIL FOR CENTER INDICATED
C =10 - INCORRECT CENTER INDICATOR
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C
C INCOMING MESSAGE HOLDER
CHARACTER*1 MSGA(*)
C
C BIT MAP
LOGICAL KBMS(*)
C
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPTR(10)
C ARRAY OF POINTERS AND COUNTERS
INTEGER KPDS(20)
INTEGER KGDS(13)
C
INTEGER KRET
INTEGER MASK(8)
C ----------------------GRID 21 AND GRID 22 ARE THE SAME
LOGICAL GRD21( 1369)
C ----------------------GRID 23 AND GRID 24 ARE THE SAME
LOGICAL GRD23( 1369)
LOGICAL GRD25( 1368)
LOGICAL GRD26( 1368)
C ----------------------GRID 27 AND GRID 28 ARE THE SAME
C ----------------------GRID 29 AND GRID 30 ARE THE SAME
C ----------------------GRID 33 AND GRID 34 ARE THE SAME
LOGICAL GRD50(1188)
C -----------------------GRID 61 AND GRID 62 ARE THE SAME
LOGICAL GRD61( 4186)
C -----------------------GRID 63 AND GRID 64 ARE THE SAME
LOGICAL GRD63( 4186)
C
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/
C LINE 1-4
& 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,
& 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE.,
C LINE 5-8
& 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,
& 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE.,
C LINE 9-12
& 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,
& 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE.,
C LINE 13-16
& 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,
& 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE.,
C LINE 17-20
& 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,
& 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE.,
C LINE 21-24
& 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,
& 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE.,
C LINE 25-28
& .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE.,
& 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE.,
C 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/
C DATA MSK40 /Z00000040/
DATA MSK40 /64/
C
IS = KPTR(9)
IF (KPDS(18).EQ.0) THEN
IGRIBL = 4
ELSE
IGRIBL = 8
ENDIF
ISS = IS + KPTR(3) + KPTR(4) + IGRIBL
C **********************************************************
C IF THE FLAG IN PDS INDICATES THAT THERE IS NO BMS,
C SET BIT MAP WITH ALL BITS ON
C ELSE
C RECOVER BIT MAP
C THEN RETURN
C **********************************************************
C ---------------- NON-STANDARD GRID
IF (KPDS(3).EQ.255) THEN
J = KGDS(2) * KGDS(3)
KPTR(10) = J
DO 600 I = 1, J
KBMS(I) = .TRUE.
600 CONTINUE
END IF
IF (IAND(KPDS(4),MSK40).EQ.0)THEN
C PRINT *,' NO BIT MAP',MSK40,KPDS(4)
GO TO 400
ELSE
PRINT *,' HAVE A BIT MAP'
END IF
C ---------------- FLAG INDICATING PRESENCE OF BIT MAP IS ON
IF (KGDS(1).EQ.50) THEN
PRINT *,' W3AI08/AI084 WARNING - BIT MAP MAY NOT BE',
* ' ASSOCIATED WITH SPHERICAL COEFFICIENTS'
RETURN
ENDIF
C GET NUMBER OF UNUSED BITS
IUBITS = MOVA2I(MSGA(ISS+3))
C SEE IF BIT MAP IS CONTAINED
KFLAG = 0
DO 150 I = 0, 1
KFLAG = KFLAG * 256 + MOVA2I(MSGA(I+ISS+4))
150 CONTINUE
PRINT *,'KFLAG=',KFLAG
C ----------------- IF KFLAG = 0 PICK UP NEW BIT MAP
C ELSE
C ------------------ USE PREDEFINED BIT MAP
MAXBYT = KPTR(5) - 6
IF (KFLAG.EQ.0) THEN
C ------------------ UTILIZE BIT MAP FROM MESSAGE
II = 1
DO 300 I = 1, MAXBYT
KCNT = MOVA2I(MSGA(I+ISS+6))
DO 200 K = 1, 8
IF (IAND(KCNT,MASK(K)).NE.0) THEN
KBMS(II) = .TRUE.
ELSE
KBMS(II) = .FALSE.
END IF
II = II + 1
200 CONTINUE
300 CONTINUE
KPTR(10) = 8 * (KPTR(5) - 6) - IUBITS
GO TO 900
ELSE
PRINT *,'KFLAG SAYS USE STD BIT MAP',KFLAG
END IF
C ---------------------- PREDEFINED BIT MAP IS INDICATED
C IF GRID NUMBER DOES NOT MATCH AN
C EXISTING GRID, SET KRET TO 5 AND
C ---------------------- RETURN.
400 CONTINUE
KRET = 0
C ---------------------- ECMWF MAP GRIDS
IF (KPDS(1).EQ.98) THEN
IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN
J = 1073
C*** TEST FOR FULL HEMISPHERIC GRID ****
IF (KPTR(6) .GT. 2158) J= 1369
C*** *** **** *** ***
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 1000 I = 1, J
KBMS(I) = .TRUE.
1000 CONTINUE
ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN
J = 361
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 1013 I = 1, J
KBMS(I) = .TRUE.
1013 CONTINUE
ELSE
KRET = 5
RETURN
END IF
C ---------------------- U.K. MET OFFICE BRACKNELL
ELSE IF (KPDS(1).EQ.74) THEN
IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN
C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369
J = 1369
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3021 I = 1, 1369
KBMS(I) = GRD21(I)
3021 CONTINUE
ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN
C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369
J = 1369
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3023 I = 1, 1369
KBMS(I) = GRD23(I)
3023 CONTINUE
ELSE IF (KPDS(3).EQ.25) THEN
C ----- INT'L GRID 25 - MAP SIZE 1368
J = 1368
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3025 I = 1, 1368
KBMS(I) = GRD25(I)
3025 CONTINUE
ELSE IF (KPDS(3).EQ.26) THEN
C ----- INT'L GRID 26 - MAP SIZE 1368
J = 1368
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3026 I = 1, 1368
KBMS(I) = GRD26(I)
3026 CONTINUE
ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186
J = 4186
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3061 I = 1, 4186
KBMS(I) = GRD61(I)
3061 CONTINUE
ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186
J = 4186
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3063 I = 1, 4186
KBMS(I) = GRD63(I)
3063 CONTINUE
ELSE IF (KPDS(3).EQ.70) THEN
C ----- U.S. GRID 70 - MAP SIZE 16380
J = 16380
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 3070 I = 1, J
KBMS(I) = .TRUE.
3070 CONTINUE
ELSE
KRET = 5
RETURN
END IF
C ---------------------- FNOC NAVY
ELSE IF (KPDS(1).EQ.58) THEN
PRINT *,' NO STANDARD FNOC GRID AT THIS TIME'
RETURN
C ---------------------- U.S. GRIDS
ELSE IF (KPDS(1).EQ.7) THEN
IF (KPDS(3).EQ.5) THEN
C ----- U.S. GRID 5 - MAP SIZE 3021
J = 3021
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2005 I = 1, J
KBMS(I) = .TRUE.
2005 CONTINUE
ELSE IF (KPDS(3).EQ.6) THEN
C ----- U.S. GRID 6 - MAP SIZE 2385
J = 2385
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2006 I = 1, J
KBMS(I) = .TRUE.
2006 CONTINUE
ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN
C ----- U.S. GRIDS 21, 22 - MAP SIZE 1369
J = 1369
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2021 I = 1, 1369
KBMS(I) = GRD21(I)
2021 CONTINUE
ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN
C ----- U.S GRIDS 23, 24 - MAP SIZE 1369
J = 1369
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2023 I = 1, 1369
KBMS(I) = GRD23(I)
2023 CONTINUE
ELSE IF (KPDS(3).EQ.25) THEN
C ----- U.S. GRID 25 - MAP SIZE 1368
J = 1368
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2025 I = 1, 1368
KBMS(I) = GRD25(I)
2025 CONTINUE
ELSE IF (KPDS(3).EQ.26) THEN
C ----- U.S.GRID 26 - MAP SIZE 1368
J = 1368
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2026 I = 1, 1368
KBMS(I) = GRD26(I)
2026 CONTINUE
ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN
C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225
J = 4225
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2027 I = 1, J
KBMS(I) = .TRUE.
2027 CONTINUE
ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30)THEN
C ----- U.S. GRIDS 29,30 - MAP SIZE 5365
J = 5365
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2029 I = 1, J
KBMS(I) = .TRUE.
2029 CONTINUE
ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN
C ----- U.S GRID 33, 34 - MAP SIZE 8326 (181 X 46)
J = 8326
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2033 I = 1, J
KBMS(I) = .TRUE.
2033 CONTINUE
ELSE IF (KPDS(3).EQ.50) THEN
C ----- U.S. GRID 50 - MAP SIZE 964
J = 1188
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2050 I = 1, 1188
KBMS(I) = GRD50(I)
2050 CONTINUE
ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN
C ----- U.S. GRIDS 61, 62 - MAP SIZE 4186
J = 4186
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2061 I = 1, 4186
KBMS(I) = GRD61(I)
2061 CONTINUE
ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN
C ----- U.S. GRIDS 63, 64 - MAP SIZE 4186
J = 4186
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2063 I = 1, 4186
KBMS(I) = GRD63(I)
2063 CONTINUE
ELSE IF (KPDS(3).EQ.70) THEN
C ----- U.S. GRID 70 - MAP SIZE 16380
J = 16380
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2070 I = 1, J
KBMS(I) = .TRUE.
2070 CONTINUE
ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN
C ----- U.S. GRIDS 85, 86 - MAP SIZE 32400 (360 X 90)
J = 32400
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2085 I = 1, J
KBMS(I) = .TRUE.
2085 CONTINUE
ELSE IF (KPDS(3).EQ.100) THEN
C ----- U.S. GRID 100 - MAP SIZE 6889 (83 X 83)
J = 6889
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 1100 I = 1, J
KBMS(I) = .TRUE.
1100 CONTINUE
ELSE IF (KPDS(3).EQ.101) THEN
C ----- U.S. GRID 101 - MAP SIZE 10283 (113 X 91)
J = 10283
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2101 I = 1, J
KBMS(I) = .TRUE.
2101 CONTINUE
ELSE IF (KPDS(3).EQ.102) THEN
C ----- U.S. GRID 102 - MAP SIZE 14375 (115 X 125)
J = 14375
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2102 I = 1, J
KBMS(I) = .TRUE.
2102 CONTINUE
ELSE IF (KPDS(3).EQ.103) THEN
C ----- U.S. GRID 103 - MAP SIZE 3640 (65 X 56)
J = 3640
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2103 I = 1, J
KBMS(I) = .TRUE.
2103 CONTINUE
ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN
IF (KPDS(3).EQ.201) J = 4225
IF (KPDS(3).EQ.202) J = 2795
IF (KPDS(3).EQ.203) J = 1755
IF (KPDS(3).EQ.204) J = 5609
IF (KPDS(3).EQ.205) J = 1755
IF (KPDS(3).EQ.206) J = 2091
IF (KPDS(3).EQ.207) J = 1715
IF (KPDS(3).EQ.208) J = 625
IF (KPDS(3).EQ.209) J = 8181
IF (KPDS(3).EQ.210) J = 625
IF (KPDS(3).EQ.211) J = 2915
IF (KPDS(3).EQ.212) J = 4225
IF (KPDS(3).EQ.213) J = 10965
IF (KPDS(3).EQ.214) J = 6693
KPTR(10) = J
CALL AI087(*900,J,KPDS,KGDS,KRET)
DO 2201 I = 1, J
KBMS(I) = .TRUE.
2201 CONTINUE
ELSE
KRET = 5
RETURN
END IF
ELSE
KRET = 10
RETURN
END IF
900 CONTINUE
RETURN
END
SUBROUTINE AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI085 EXTRACT GRIB DATA ELEMENTS
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 88-01-20
C
C ABSTRACT: EXTRACT GRIB DATA AND PLACE INTO OUTPUT ARRY IN
C PROPER POSITION.
C
C PROGRAM HISTORY LOG:
C 88-01-20 CAVANAUGH
C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI085(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING GRIB MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C KPDS - ARRAY CONTAINING PDS ELEMENTS.
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR OF CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
C
C OUTPUT ARGUMENT LIST:
C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE.
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C ERROR RETURN
C 3 = UNPACKED FIELD IS LARGER THAN 32768
C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID
C 7 = NUMBER OF BITS IN FILL TOO LARGE
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C *************************************************************
CHARACTER*1 MSGA(*)
CHARACTER*1 KREF(8)
CHARACTER*1 KK(8)
C
LOGICAL KBMS(*)
C
INTEGER KPDS(*)
INTEGER KPTR(*)
INTEGER NRBITS
INTEGER KSAVE(105000)
INTEGER KSCALE
C
REAL DATA(*)
REAL REFNCE
REAL SCALE
REAL REALKK
C
LOGICAL IBM370
C
EQUIVALENCE (REFNCE,KREF(1),IREF)
EQUIVALENCE (KK(1),REALKK,IKK)
C
C DATA MSK0F /Z0000000F/
C DATA MSK80 /Z00000080/
C DATA MSK40 /Z00000040/
C
DATA MSK0F /15/
DATA MSK80 /128/
DATA MSK40 /64/
C
C *************************************************************
KRET = 0
IS = KPTR(9)
ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + 4
C BYTE 4
KSPL = MOVA2I(MSGA(ISS+3))
C POINT TO BYTE 5 OF BDS
C
C ------------- GET SCALE FACTOR
C
KSCALE = 0
DO 100 I = 0, 1
KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4))
100 CONTINUE
IF (IAND(KSCALE,32768).NE.0) THEN
KSCALE = - IAND(KSCALE,32767)
END IF
SCALE = 2.0**KSCALE
C
C ------------ GET REFERENCE VALUE
C
IREF = 0
DO 200 I = 0, 3
KREF(I+1) = MSGA(I+ISS+6)
200 CONTINUE
C
C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
C NUMBER OF YOUR MACHINE TYPE.
C
IBM370 = .FALSE.
C
IF (.NOT.IBM370) THEN
KOFF = 0
C GET 1 BIT SIGN
CALL GBYTE(IREF,ISGN,0,1)
C GET 7 BIT EXPONENT
CALL GBYTE(IREF,IEXP,1,7)
C GET 24 BIT FRACTION
CALL GBYTE(IREF,IFR,8,24)
IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN
REFNCE = 0.0
ELSE
REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6)
IF (ISGN.NE.0) REFNCE = - REFNCE
ENDIF
ENDIF
C
C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
C
KBITS = MOVA2I(MSGA(ISS+10))
KENTRY = KPTR(10)
C
C ------------- MAX SIZE CHECK
C
IF (KENTRY.GT.105000) THEN
KRET = 3
RETURN
END IF
IF (KBITS.EQ.0) THEN
C
C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
C
DO 210 I = 1, KENTRY
DATA(I) = 0.0
IF (KBMS(I)) THEN
DATA(I) = REFNCE
END IF
210 CONTINUE
GO TO 900
END IF
C
C --------------------
C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
C ENTRIES.
C
C ------------- UNUSED BITS IN DATA AREA
C
LESSBT = IAND(KSPL,MSK0F)
C
C ------------- NUMBER OF BYTES IN DATA AREA
C
NRBYTE = KPTR(6) - 11
C
C ------------- TOTAL NR OF USABLE BITS
C
NRBITS = NRBYTE * 8 - LESSBT
C
C ------------- TOTAL NR OF ENTRIES
C
KENTRY = NRBITS / KBITS
C
C ------------- MAX SIZE CHECK
C
IF (KENTRY.GT.105000) THEN
KRET = 3
RETURN
END IF
C
IBMS = IAND(KPDS(4),MSK40)
C
C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
C IF YES,
C GO AND PROCESS AS SUCH
C ELSE
C CONTINUE PROCESSING
C
IF (IAND(KSPL,MSK80).EQ.0) THEN
C
C ------------- SET POINTERS
C
C XMOVEX MOVES THE DATA TO MAKE SURE IT IS ON A INTEGER WORD
C BOUNDARY, ON SOME COMPUTERS THIS DOES NOT HAVE TO BE DONE.
C (IBM PC, VAX)
C
C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
C ------------- UNPACK ALL FIELDS
KOFF = 0
C
C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
C IN FORTRAN AN ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
C COMPUTERS. THEY ALSO HAVE A C VERSION.
C
C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
C
C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
C INTEGER WORD BOUNDARY
C
LLL = MOD(ISS+10,8)
NNN = 11 - LLL
KOFF = LLL * 8
CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY)
C
C ------------- CORRECTLY PLACE ALL ENTRIES
C
II = 1
KENTRY = KPTR(10)
DO 500 I = 1, KENTRY
IF (KBMS(I)) THEN
DATA(I) = REFNCE + FLOAT(KSAVE(II)) * SCALE
II = II + 1
ELSE
DATA(I) = 0.0
END IF
500 CONTINUE
GO TO 900
END IF
C
C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
C
IKK = 0
DO 5500 I = 0, 3
KK(I+1) = MSGA(I+ISS+11)
5500 CONTINUE
C
IF (.NOT.IBM370) THEN
KOFF = 0
C GET 1 BIT SIGN
CALL GBYTE(IKK,ISGN,0,1)
C GET 7 BIT EXPONENT
CALL GBYTE(IKK,IEXP,1,7)
C GET 24 BIT FRACTION
CALL GBYTE(IKK,IFR,8,24)
IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN
REALKK = 0.0
ELSE
REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6)
IF (ISGN.NE.0) REALKK = - REALKK
ENDIF
ENDIF
C
DATA(1) = REALKK
KOFF = 0
C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
C ------------- UNPACK ALL FIELDS
C
C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
C
C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
C INTEGER WORD BOUNDARY
C
LLL = MOD(ISS+14,8)
NNN = 15 - LLL
KOFF = LLL * 8
C
CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY)
C
C --------------
DO 6000 I = 1, KENTRY
DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE
6000 CONTINUE
900 CONTINUE
RETURN
END
SUBROUTINE AI085A(MSGA,KPTR,KPDS,KBMS,DATA,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI085A EXTRACT GRIB DATA (VER 1) ELEMENTS
C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 89-11-20
C
C ABSTRACT: EXTRACT GRIB DATA (VERSION 1) AND PLACE INTO PROPER
C POSITION IN OUTPUT ARRAY.
C
C PROGRAM HISTORY LOG:
C 89-11-20 CAVANAUGH
C 90-09-01 R.E.JONES CHANGE'S FOR ANSI FORTRAN
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI085A (MSGA,KPTR,KPDS,KBMS,DATA,KRET)
C INPUT ARGUMENT LIST:
C MSGA - ARRAY CONTAINING GRIB MESSAGE
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C (1) - UNUSED
C (2) - UNUSED
C (3) - LENGTH OF PDS
C (4) - LENGTH OF GDS
C (5) - LENGTH OF BMS
C (6) - LENGTH OF BDS
C (7) - VALUE OF CURRENT BYTE
C (8) - UNUSED
C (9) - GRIB START BYTE NR
C (10) - GRIB/GRID ELEMENT COUNT
C KPDS - ARRAY CONTAINING PDS ELEMENTS. (VERSION 1)
C (1) - ID OF CENTER
C (2) - MODEL IDENTIFICATION
C (3) - GRID IDENTIFICATION
C (4) - GDS/BMS FLAG
C (5) - INDICATOR OF PARAMETER
C (6) - TYPE OF LEVEL
C (7) - HEIGHT/PRESSURE , ETC OF LEVEL
C (8) - YEAR INCLUDING CENTURY
C (9) - MONTH OF YEAR
C (10) - DAY OF MONTH
C (11) - HOUR OF DAY
C (12) - MINUTE OF HOUR
C (13) - INDICATOR OF FORECAST TIME UNIT
C (14) - TIME RANGE 1
C (15) - TIME RANGE 2
C (16) - TIME RANGE FLAG
C (17) - NUMBER INCLUDED IN AVERAGE
C (18) - VERSION NR OF GRIB SPECIFICATION
C (19) - VERSION NR OF PARAMETER TABLE
C (20) - TOTAL LENGTH OF GRIB MESSAGE (INCLUDING SECTION 0)
C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS.
C
C OUTPUT ARGUMENT LIST:
C DATA - REAL ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE.
C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS
C SEE INPUT LIST
C KRET - ERROR RETURN
C
C REMARKS:
C STRUCTURE OF BINARY DATA SECTION (VERSION 1)
C 1-3 - LENGTH OF SECTION
C 4 - PACKING FLAGS
C 5-6 - SCALE FACTOR
C 7-10 - REFERENCE VALUE
C 11 - NUMBER OF BIT FOR EACH VALUE
C 12-N - DATA
C ERROR RETURN
C 3 = UNPACKED FIELD IS LARGER THAN 32768
C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID
C 7 = NUMBER OF BITS IN FILL TOO LARGE
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
C *************************************************************
CHARACTER*1 MSGA(*)
CHARACTER*1 KREF(8)
CHARACTER*1 KK(8)
C
LOGICAL KBMS(*)
C
INTEGER KPDS(*)
INTEGER KPTR(*)
INTEGER NRBITS
INTEGER KSAVE(105000)
INTEGER KSCALE
C
REAL DATA(*)
REAL REFNCE
REAL SCALE
REAL REALKK
C
LOGICAL IBM370
C
EQUIVALENCE (REFNCE,KREF(1),IREF)
EQUIVALENCE (KK(1),REALKK,IKK)
C
C DATA MSK0F /Z0000000F/
C DATA MSK40 /Z00000040/
C DATA MSK80 /Z00000080/
C
DATA MSK0F /15/
DATA MSK40 /64/
DATA MSK80 /128/
C
C *************************************************************
C
KRET = 0
IS = KPTR(9)
IGRIBL = 8
ISS = IS + KPTR(3) + KPTR(4) + KPTR(5) + IGRIBL
C BYTE 4
KSPL = MOVA2I(MSGA(ISS+3))
C
C ------------- POINT TO BYTE 5 OF BDS
C
C ------------- GET SCALE FACTOR
C
KSCALE = 0
DO 100 I = 0, 1
KSCALE = KSCALE * 256 + MOVA2I(MSGA(I+ISS+4))
100 CONTINUE
IF (IAND(KSCALE,32768).NE.0) THEN
KSCALE = - IAND(KSCALE,32767)
END IF
SCALE = 2.0**KSCALE
C
C -------------------- DECIMAL SCALE EXPONENT
C
IDEC = IS + IGRIBL + 26
JSCALE = 0
DO 150 I = 0, 1
JSCALE = JSCALE * 256 + MOVA2I(MSGA(I+IDEC))
150 CONTINUE
C IF HIGH ORDER BIT IS ON, HAVE NEGATIVE EXPONENT
IF (IAND(JSCALE,32768).NE.0) THEN
JSCALE = - IAND(JSCALE,32767)
END IF
ASCALE = 10.0 ** JSCALE
C
C ------------ GET REFERENCE VALUE
C
IREF = 0
DO 200 I = 0, 3
KREF(I+1) = MSGA(I+ISS+6)
200 CONTINUE
C
C THE FLOATING POINT NUMBER IN THE REFERENCE VALUE IS AN IBM370
C 32 BIT NUMBER, IF YOUR COMPUTER IS NOT AN IBM370 OR CLONE
C SET IBM370 TO .FALSE. SO THE NUMBER IS CONVERTED TO A F.P.
C NUMBER OF YOUR MACHINE TYPE.
C
IBM370 = .FALSE.
C
IF (.NOT.IBM370) THEN
KOFF = 0
C GET 1 BIT SIGN
CALL GBYTE(IREF,ISGN,0,1)
C GET 7 BIT EXPONENT
CALL GBYTE(IREF,IEXP,1,7)
C GET 24 BIT FRACTION
CALL GBYTE(IREF,IFR,8,24)
IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN
REFNCE = 0.0
ELSE
REFNCE = FLOAT(IFR) * 16.0 ** (IEXP-64-6)
IF (ISGN.NE.0) REFNCE = - REFNCE
ENDIF
ENDIF
C
C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY
C
KBITS = MOVA2I(MSGA(ISS+10))
KENTRY = KPTR(10)
C
C ------------- MAX SIZE CHECK
C
IF (KENTRY.GT.105000) THEN
KRET = 3
RETURN
END IF
C
IF (KBITS.EQ.0) THEN
C
C -------------------- HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE
C
DO 210 I = 1, KENTRY
DATA(I) = 0.0
IF (KBMS(I)) THEN
DATA(I) = REFNCE
END IF
210 CONTINUE
GO TO 900
END IF
C
C --------------------
C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER)
C ENTRIES.
C
C ------------- UNUSED BITS IN DATA AREA
C
LESSBT = IAND(KSPL,MSK0F)
C
C ------------- NUMBER OF BYTES IN DATA AREA
C
NRBYTE = KPTR(6) - 11
C
C ------------- TOTAL NR OF USABLE BITS
C
NRBITS = NRBYTE * 8 - LESSBT
C
C ------------- TOTAL NR OF ENTRIES
C
KENTRY = NRBITS / KBITS
C
C ------------- MAX SIZE CHECK
C
IF (KENTRY.GT.105000) THEN
KRET = 3
RETURN
END IF
IBMS = IAND(KPDS(4),MSK40)
C
C -------------- CHECK TO SEE IF PROCESSING COEFFICIENTS
C IF YES,
C GO AND PROCESS AS SUCH
C ELSE
C CONTINUE PROCESSING
IF (IAND(KSPL,MSK80).EQ.0) THEN
C
C ------------- SET POINTERS
C
C REPLACE XMOVEX AND W3AI41 WITH GBYTES
C CALL XMOVEX(MSGB,MSGA(ISS+11),NRBYTE)
C
C ------------- UNPACK ALL FIELDS
C
KOFF = 0
C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
C
C THE BIT UNPACKER W3AI41 WILL CONSUME MOST OF THE CPU TIME
C CONVERTING THE GRIB DATA. FOR THE IBM370 WE HAVE AN
C ASSEMBLER AND FORTRAN VERSION. THE ASSMBLER VERSION WILL
C RUN TWO TO THREE TIMES FASTER. THE FORTRAN VERSION IS TO
C MAKE THE CODE MORE PORTABLE. FOR A VAX OR IBM PC WE HAVE
C ANOTHER VERSION, IT REVERSED THE ORDER OF THE BYTES IN
C AN INTEGER WORD. W3AI41 CAN BE REPLACED BY NCAR GBYTES
C BIT UNPACKER. NCAR HAS A LARGE NUMBER OF VERSIONS OF GBYTES
C IN FORTRAN AND ASSEMBLER FOR A NUMBER OF DIFFERENT BRANDS OF
C COMPUTERS. THEY ALSO HAVE A C VERSION.
C
C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
C INTEGER WORD BOUNDARY
C
LLL = MOD(ISS+10,8)
NNN = 11 - LLL
KOFF = LLL * 8
C
CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY)
C
C ------------- CORRECTLY PLACE ALL ENTRIES
C
II = 1
KENTRY = KPTR(10)
DO 500 I = 1, KENTRY
IF (KBMS(I)) THEN
C MUST INCLUDE DECIMAL SCALE
DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) / ASCALE
II = II + 1
ELSE
DATA(I) = 0.0
END IF
500 CONTINUE
GO TO 900
END IF
C
C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS
C
IKK = 0
DO 5500 I = 0, 3
KK(I+1) = MSGA(I+ISS+11)
5500 CONTINUE
C
IF (.NOT.IBM370) THEN
KOFF = 0
C GET 1 BIT SIGN
CALL GBYTE(IKK,ISGN,0,1)
C GET 7 BIT EXPONENT
CALL GBYTE(IKK,IEXP,1,7)
C GET 24 BIT FRACTION
CALL GBYTE(IKK,IFR,8,24)
IF (IFR.EQ.0.OR.IEXP.EQ.0) THEN
REALKK = 0.0
ELSE
REALKK = FLOAT(IFR) * 16.0 ** (IEXP-64-6)
IF (ISGN.NE.0) REALKK = - REALKK
ENDIF
ENDIF
C
DATA(1) = REALKK
KOFF = 0
C CALL XMOVEX(MSGB,MSGA(ISS+15),NRBYTE)
C
C ------------- UNPACK ALL FIELDS
C
C CALL W3AI41(MSGB,KSAVE,KBITS,KENTRY,KOFF)
C --------------
C
C ALIGN CHARACTER ARRAY MSGA STARTING ADDRESS ON CRAY
C INTEGER WORD BOUNDARY
C
LLL = MOD(ISS+14,8)
NNN = 15 - LLL
KOFF = LLL * 8
C
CALL GBYTES(MSGA(ISS+NNN),KSAVE,KOFF,KBITS,0,KENTRY)
C
DO 6000 I = 1, KENTRY
DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE
6000 CONTINUE
900 CONTINUE
RETURN
END
SUBROUTINE AI087(*,J,KPDS,KGDS,KRET)
C$$$ SUBPROGRAM DOCUMENTATION BLOCK
C . . . .
C SUBPROGRAM: AI087 GRIB GRID/SIZE TEST
C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 88-02-08
C
C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH
C ON EXISTING GRIDS (BY CENTER) IS INDICATED
C
C PROGRAM HISTORY LOG:
C 88-02-08 CAVANAUGH
C 90-09-23 R.E.JONES CHANGE'S FOR CRAY CFT77 FORTRAN
C 90-12-05 R.E.JONES CHANGE'S FOR GRIB NOV. 21,1990
C
C USAGE: CALL AI087(*,J,KPDS,KGDS,KRET)
C INPUT ARGUMENT LIST:
C J - SIZE FOR INDICATED GRID
C KPDS -
C KGDS -
C
C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS)
C KRET - ERROR RETURN
C
C REMARKS:
C KRET -
C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID
C
C ATTRIBUTES:
C LANGUAGE: CRAY CFT77 FORTRAN
C MACHINE: CRAY Y-MP8/832
C
C$$$
INTEGER KPDS(20)
INTEGER KGDS(13)
INTEGER J
INTEGER I
C ---------------------------------------
C ---------------------------------------
C IF GDS NOT INDICATED, RETURN
C ----------------------------------------
IF (IAND(KPDS(4),128).EQ.0) RETURN
C ---------------------------------------
C GDS IS INDICATED, PROCEED WITH TESTING
C ---------------------------------------
I = KGDS(2) * KGDS(3)
C ---------------------------------------
C TEST ECMWF CONTENT
C ---------------------------------------
IF (KPDS(1).EQ.98) THEN
KRET = 9
IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE
KRET = 5
RETURN 1
END IF
C ---------------------------------------
C U.K. MET OFFICE, BRACKNELL
C ---------------------------------------
ELSE IF (KPDS(1).EQ.74) THEN
KRET = 9
IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.70) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE
KRET = 5
RETURN 1
END IF
C ---------------------------------------
C NAVY - FNOC
C ---------------------------------------
ELSE IF (KPDS(1).EQ.58) THEN
PRINT *,' NO CURRENT LISTING OF NAVY GRIDS'
RETURN 1
C ---------------------------------------
C U.S. GRIDS
C ---------------------------------------
ELSE IF (KPDS(1).EQ.7) THEN
KRET = 9
IF (KPDS(3).EQ.5) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.6) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.24) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.25.OR.KPDS(3).EQ.26) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.50) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.70) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.100) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.101) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.102) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).EQ.103) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE IF (KPDS(3).GE.201.AND.KPDS(3).LE.214) THEN
IF (I.NE.J) THEN
RETURN 1
END IF
ELSE
KRET = 5
RETURN 1
END IF
ELSE
KRET = 10
RETURN 1
END IF
C ------------------------------------
C NORMAL EXIT
C ------------------------------------
KRET = 0
RETURN
END