| 1 | C----------------------------------------------------------------------- |
|---|
| 2 | SUBROUTINE GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, |
|---|
| 3 | & EXTRACT,K,GRIBM,LENG,IRET) |
|---|
| 4 | C$$$ SUBPROGRAM DOCUMENTATION BLOCK |
|---|
| 5 | C |
|---|
| 6 | C SUBPROGRAM: GETGB2P FINDS AND EXTRACTS A GRIB MESSAGE |
|---|
| 7 | C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 |
|---|
| 8 | C |
|---|
| 9 | C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE. |
|---|
| 10 | C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) |
|---|
| 11 | C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. |
|---|
| 12 | C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED. |
|---|
| 13 | C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP |
|---|
| 14 | C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND |
|---|
| 15 | C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER |
|---|
| 16 | C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) |
|---|
| 17 | C IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE |
|---|
| 18 | C GRIB FILE AND RETURNED. |
|---|
| 19 | C IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. |
|---|
| 20 | C |
|---|
| 21 | C PROGRAM HISTORY LOG: |
|---|
| 22 | C 94-04-01 IREDELL |
|---|
| 23 | C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS |
|---|
| 24 | C AND ALLOWED FOR UNSPECIFIED INDEX FILE |
|---|
| 25 | C 2002-01-11 GILBERT MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2 |
|---|
| 26 | C 2003-12-17 GILBERT MODIFIED FROM GETGB2 TO RETURN PACKED GRIB2 MESSAGE. |
|---|
| 27 | C |
|---|
| 28 | C USAGE: CALL GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, |
|---|
| 29 | C & EXTRACT,K,GRIBM,LENG,IRET) |
|---|
| 30 | C INPUT ARGUMENTS: |
|---|
| 31 | C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. |
|---|
| 32 | C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING |
|---|
| 33 | C THIS ROUTINE. |
|---|
| 34 | C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE. |
|---|
| 35 | C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE |
|---|
| 36 | C CALLING THIS ROUTINE. |
|---|
| 37 | C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) |
|---|
| 38 | C J INTEGER NUMBER OF FIELDS TO SKIP |
|---|
| 39 | C (=0 TO SEARCH FROM BEGINNING) |
|---|
| 40 | C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD |
|---|
| 41 | C ( IF = -1, ACCEPT ANY DISCIPLINE) |
|---|
| 42 | C ( SEE CODE TABLE 0.0 ) |
|---|
| 43 | C 0 - Meteorological products |
|---|
| 44 | C 1 - Hydrological products |
|---|
| 45 | C 2 - Land surface products |
|---|
| 46 | C 3 - Space products |
|---|
| 47 | C 10 - Oceanographic products |
|---|
| 48 | C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION |
|---|
| 49 | C (=-9999 FOR WILDCARD) |
|---|
| 50 | C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE |
|---|
| 51 | C ( SEE COMMON CODE TABLE C-1 ) |
|---|
| 52 | C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE |
|---|
| 53 | C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER |
|---|
| 54 | C ( SEE CODE TABLE 1.0 ) |
|---|
| 55 | C 0 - Experimental |
|---|
| 56 | C 1 - Initial operational version number |
|---|
| 57 | C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER |
|---|
| 58 | C ( SEE CODE TABLE 1.1 ) |
|---|
| 59 | C 0 - Local tables not used |
|---|
| 60 | C 1-254 - Number of local tables version used |
|---|
| 61 | C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2) |
|---|
| 62 | C 0 - Analysis |
|---|
| 63 | C 1 - Start of forecast |
|---|
| 64 | C 2 - Verifying time of forecast |
|---|
| 65 | C 3 - Observation time |
|---|
| 66 | C JIDS(6) = YEAR ( 4 DIGITS ) |
|---|
| 67 | C JIDS(7) = MONTH |
|---|
| 68 | C JIDS(8) = DAY |
|---|
| 69 | C JIDS(9) = HOUR |
|---|
| 70 | C JIDS(10) = MINUTE |
|---|
| 71 | C JIDS(11) = SECOND |
|---|
| 72 | C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA |
|---|
| 73 | C ( SEE CODE TABLE 1.3 ) |
|---|
| 74 | C 0 - Operational products |
|---|
| 75 | C 1 - Operational test products |
|---|
| 76 | C 2 - Research products |
|---|
| 77 | C 3 - Re-analysis products |
|---|
| 78 | C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 ) |
|---|
| 79 | C 0 - Analysis products |
|---|
| 80 | C 1 - Forecast products |
|---|
| 81 | C 2 - Analysis and forecast products |
|---|
| 82 | C 3 - Control forecast products |
|---|
| 83 | C 4 - Perturbed forecast products |
|---|
| 84 | C 5 - Control and perturbed forecast products |
|---|
| 85 | C 6 - Processed satellite observations |
|---|
| 86 | C 7 - Processed radar observations |
|---|
| 87 | C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N) |
|---|
| 88 | C ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY ) |
|---|
| 89 | C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION |
|---|
| 90 | C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH |
|---|
| 91 | C (=-9999 FOR WILDCARD) |
|---|
| 92 | C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M) |
|---|
| 93 | C ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY ) |
|---|
| 94 | C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION |
|---|
| 95 | C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH |
|---|
| 96 | C (=-9999 FOR WILDCARD) |
|---|
| 97 | C EXTRACT LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2 |
|---|
| 98 | C MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE |
|---|
| 99 | C GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD. |
|---|
| 100 | C .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED |
|---|
| 101 | C FIELD. |
|---|
| 102 | C .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE |
|---|
| 103 | C REQUESTED FIELD. |
|---|
| 104 | C |
|---|
| 105 | C OUTPUT ARGUMENTS: |
|---|
| 106 | C K INTEGER FIELD NUMBER RETURNED. |
|---|
| 107 | C GRIBM RETURNED GRIB MESSAGE. |
|---|
| 108 | C LENG LENGTH OF RETURNED GRIB MESSAGE IN BYTES. |
|---|
| 109 | C IRET INTEGER RETURN CODE |
|---|
| 110 | C 0 ALL OK |
|---|
| 111 | C 96 ERROR READING INDEX FILE |
|---|
| 112 | C 97 ERROR READING GRIB FILE |
|---|
| 113 | C 99 REQUEST NOT FOUND |
|---|
| 114 | C |
|---|
| 115 | C SUBPROGRAMS CALLED: |
|---|
| 116 | C GETG2I READ INDEX FILE |
|---|
| 117 | C GETG2IR READ INDEX BUFFER FROM GRIB FILE |
|---|
| 118 | C GETGB2S SEARCH INDEX RECORDS |
|---|
| 119 | C GETGB2RP READ A PACKED GRIB RECORD |
|---|
| 120 | C GF_FREE FREES MEMORY USED BY GFLD ( SEE REMARKS ) |
|---|
| 121 | C |
|---|
| 122 | C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. |
|---|
| 123 | C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. |
|---|
| 124 | C |
|---|
| 125 | C Note that derived type gribfield contains pointers to many |
|---|
| 126 | C arrays of data. The memory for these arrays is allocated |
|---|
| 127 | C when the values in the arrays are set, to help minimize |
|---|
| 128 | C problems with array overloading. Because of this users |
|---|
| 129 | C are encouraged to free up this memory, when it is no longer |
|---|
| 130 | C needed, by an explicit call to subroutine gf_free. |
|---|
| 131 | C ( i.e. CALL GF_FREE(GFLD) ) |
|---|
| 132 | C |
|---|
| 133 | C ATTRIBUTES: |
|---|
| 134 | C LANGUAGE: FORTRAN 90 |
|---|
| 135 | C |
|---|
| 136 | C$$$ |
|---|
| 137 | USE GRIB_MOD |
|---|
| 138 | |
|---|
| 139 | INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN |
|---|
| 140 | INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*) |
|---|
| 141 | LOGICAL,INTENT(IN) :: EXTRACT |
|---|
| 142 | INTEGER,INTENT(OUT) :: K,IRET,LENG |
|---|
| 143 | CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM |
|---|
| 144 | |
|---|
| 145 | TYPE(GRIBFIELD) :: GFLD |
|---|
| 146 | |
|---|
| 147 | CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF |
|---|
| 148 | PARAMETER(MSK1=32000,MSK2=4000) |
|---|
| 149 | |
|---|
| 150 | SAVE CBUF,NLEN,NNUM |
|---|
| 151 | DATA LUX/0/ |
|---|
| 152 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 153 | C DECLARE INTERFACES (REQUIRED FOR CBUF POINTER) |
|---|
| 154 | INTERFACE |
|---|
| 155 | SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET) |
|---|
| 156 | CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF |
|---|
| 157 | INTEGER,INTENT(IN) :: LUGI |
|---|
| 158 | INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET |
|---|
| 159 | END SUBROUTINE GETG2I |
|---|
| 160 | SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM, |
|---|
| 161 | & NMESS,IRET) |
|---|
| 162 | CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF |
|---|
| 163 | INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM |
|---|
| 164 | INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET |
|---|
| 165 | END SUBROUTINE GETG2IR |
|---|
| 166 | SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET) |
|---|
| 167 | INTEGER,INTENT(IN) :: LUGB |
|---|
| 168 | CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*) |
|---|
| 169 | LOGICAL,INTENT(IN) :: EXTRACT |
|---|
| 170 | INTEGER,INTENT(OUT) :: LENG,IRET |
|---|
| 171 | CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM |
|---|
| 172 | END SUBROUTINE GETGB2RP |
|---|
| 173 | END INTERFACE |
|---|
| 174 | |
|---|
| 175 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 176 | C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED |
|---|
| 177 | IRGI=0 |
|---|
| 178 | IF(LUGI.GT.0.AND.LUGI.NE.LUX) THEN |
|---|
| 179 | CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRGI) |
|---|
| 180 | LUX=LUGI |
|---|
| 181 | ELSEIF(LUGI.LE.0.AND.LUGB.NE.LUX) THEN |
|---|
| 182 | MSKP=0 |
|---|
| 183 | CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,CBUF,NLEN,NNUM,NMESS,IRGI) |
|---|
| 184 | LUX=LUGB |
|---|
| 185 | ENDIF |
|---|
| 186 | IF(IRGI.GT.1) THEN |
|---|
| 187 | IRET=96 |
|---|
| 188 | LUX=0 |
|---|
| 189 | RETURN |
|---|
| 190 | ENDIF |
|---|
| 191 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 192 | C SEARCH INDEX BUFFER |
|---|
| 193 | CALL GETGB2S(CBUF,NLEN,NNUM,J,-1,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, |
|---|
| 194 | & JK,GFLD,LPOS,IRGS) |
|---|
| 195 | IF(IRGS.NE.0) THEN |
|---|
| 196 | IRET=99 |
|---|
| 197 | CALL GF_FREE(GFLD) |
|---|
| 198 | RETURN |
|---|
| 199 | ENDIF |
|---|
| 200 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 201 | C EXTRACT GRIB MESSAGE FROM FILE |
|---|
| 202 | CALL GETGB2RP(LUGB,CBUF(LPOS:),EXTRACT,GRIBM,LENG,IRET) |
|---|
| 203 | ! IF ( EXTRACT ) THEN |
|---|
| 204 | ! PRINT *,'NOT SUPPOSED TO BE HERE.' |
|---|
| 205 | ! ELSE |
|---|
| 206 | ! IPOS=(LPOS+3)*8 |
|---|
| 207 | ! CALL G2LIB_GBYTE(CBUF,ISKIP,IPOS,32) ! BYTES TO SKIP IN FILE |
|---|
| 208 | ! IPOS=IPOS+(32*8) |
|---|
| 209 | ! CALL G2LIB_GBYTE(CBUF,LENG,IPOS,32) ! LENGTH OF GRIB MESSAGE |
|---|
| 210 | ! IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG)) |
|---|
| 211 | ! CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM) |
|---|
| 212 | ! IF ( LENG .NE. LREAD ) THEN |
|---|
| 213 | ! IRET=97 |
|---|
| 214 | ! CALL GF_FREE(GFLD) |
|---|
| 215 | ! RETURN |
|---|
| 216 | ! ENDIF |
|---|
| 217 | ! ENDIF |
|---|
| 218 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 219 | K=JK |
|---|
| 220 | CALL GF_FREE(GFLD) |
|---|
| 221 | C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
|---|
| 222 | RETURN |
|---|
| 223 | END |
|---|
