|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 SUBROUTINE CODEGA (PFDATA,KLENF,KBITS,KNBIT,KB1PAR, 00002 C KB2PAR,PVERT,KLENV,KGRIB,KLENG,KWORD, 00003 C KROUND,KCPACK,KSCALP,KERR,PMIN,PMAX,LDARPE) 00004 USE PARKIND1, ONLY : JPRB 00005 USE YOMHOOK , ONLY : LHOOK, DR_HOOK 00006 C 00007 C 00008 C******************************************************************** 00009 C* 00010 C* NAME : CODEGA 00011 C* 00012 C* FUNCTION : CODE ARRAY OF FLOATING POINT VALUES 00013 C* IN WMO GRIB CODE. 00014 C* 00015 C* INPUT : PARAMETERS FOR BLOCK 1 , PRODUCT DEFINITION BLOCK. 00016 C* -------------------------------------------------- 00017 C* KB1PAR - INTEGER ARRAY (DIMENSION 19) OF PRODUCT 00018 C* DEFINITION INFORMATION. 00019 C* 00020 C* WORD CONTENTS 00021 C* ---- -------- 00022 C* 1 ORIGINATING CENTRE IDENTIFIER. 00023 C* 2 MODEL IDENTIFICATION. 00024 C* 3 GRID DEFINITION. 00025 C* 4 FLAG ( CODE TABLE 1 ). 00026 C* 5 PARAMETER IDENTIFIER (CODE TABLE 2). 00027 C* 6 TYPE OF LEVEL (CODE TABLE 3). 00028 C* 7-8 VALUE(S) OF LEVEL (CODE TABLE 3). 00029 C* 9 YEAR OF DATA 00030 C* 10 MONTH OF DATA 00031 C* 11 DAY OF DATA 00032 C* 12 HOUR OF DATA 00033 C* 13 MINUTE OF DATA 00034 C* 14 TIME UNIT (CODE TABLE 4). 00035 C* 15 TIME RANGE ONE 00036 C* 16 TIME RANGE TWO 00037 C* 17 TIME RANGE FLAG (CODE TABLE 5). 00038 C* 18 NUMBER AVERAGED OR ACCUMULATED. 00039 C* 19 NUMBER MISSING FROM AVERAGES/ACCUMULATIONS. 00040 C* 00041 C* VALUE(S) OF LEVEL CAN OCCUPY 2 WORDS. 00042 C* FOR A LAYER THE FIRST WORD DEFINES THE TOP 00043 C* AND THE SECOND THE BOTTOM OF THE LAYER. 00044 C* FOR A SINGLE LEVEL, ONLY THE FIRST WORD IS 00045 C* USED. 00046 C* 00047 C* PARAMETERS FOR BLOCK 2 , GRID DEFINITION BLOCK. 00048 C* ----------------------------------------------- 00049 C* KB2PAR - INTEGER ARRAY (DIMENSION 17) CONTAINING GRID 00050 C* DEFINITION INFORMATION. 00051 C* USE VARIES WITH REPRESENTATION TYPE. 00052 C* 00053 C* WORD LAT/LONG GRID 00054 C* ---- ------------- 00055 C* 1 DATA REPRESENTATION TYPE (CODE TABLE 6) 00056 C* 2 NO. OF POINTS ALONG A LATITUDE 00057 C* 3 NO. OF POINTS ALONG A MERIDIAN 00058 C* 4 LATITUDE OF ORIGIN (SOUTH - IVE). 00059 C* 5 LONGITUDE OF ORIGIN (WEST - IVE). 00060 C* 6 RESOLUTION FLAG. (CODE TABLE 7) 00061 C* 7 LATITUDE OF EXTREME POINT (SOUTH - IVE). 00062 C* 8 LONGITUDE OF EXTREME POINT (WEST - IVE). 00063 C* 9 LATITUDE INCREMENT 00064 C* 10 LONGITUDE INCREMENT 00065 C* 11 SCANNING MODE FLAGS (CODE TABLE 8) 00066 C* 00067 C* WORD GAUSSIAN GRID 00068 C* ---- ------------- 00069 C* 1-9 AS FOR LAT/LONGITUDE GRID. 00070 C* 10 THE NUMBER OF LATITUDE LINES BETWEEN A POLE 00071 C* AND THE EQUATOR. 00072 C* 11 SCANNING MODE FLAGS (CODE TABLE 8) 00073 C* 00074 C* WORD SPHERICAL HARMONICS 00075 C* ---- ------------------- 00076 C* 1 DATA REPRESENTATION TYPE (CODE TABLE 6) 00077 C* 2 J - PENTAGONAL RESOLUTION PARAMETER 00078 C* 3 K - PENTAGONAL RESOLUTION PARAMETER 00079 C* 4 M - PENTAGONAL RESOLUTION PARAMETER 00080 C* 5 REPRESENTATION TYPE (CODE TABLE 9) 00081 C* 6 REPRESENTATION MODE (CODE TABLE 10) 00082 C* 7-11 NOT USED 00083 C* 00084 C* 00085 C* USE FOR OTHER DATA REPRESENTATION TYPES IS 00086 C* TO BE DEFINED LATER. 00087 C* 00088 C* PVERT - REAL ARRAY OF VERTICAL COORDINATE PARAMETERS 00089 C* KLENV - LENGTH OF THIS ARRAY (NUMBER OF COORDINATE 00090 C* PARAMETERS). 00091 C* 00092 C* USED FOR HYBRID LEVELS ONLY. 00093 C* 00094 C* 00095 C* PARAMETERS FOR BLOCK 3 , BIT-MAP DEFINITION BLOCK. 00096 C* -------------------------------------------------- 00097 C* 00098 C* TO BE DEFINED LATER. 00099 C* 00100 C* PARAMETERS FOR BLOCK 4 , BINARY DATA BLOCK. 00101 C* ------------------------------------------- 00102 C* PFDATA - ARRAY OF FLOATING POINT VALUES. 00103 C* 00104 C* **** 00105 C* VALUES IN THIS ARRAY ARE OVERWRITTEN 00106 C* BY THE SUBROUTINE. 00107 C* **** 00108 C* 00109 C* KLENF - LENGTH OF THIS ARRAY (NUMBER OF DATA 00110 C* VALUES TO BE CODED) 00111 C* KBITS - NUMBER OF BITS FOR CODED DATA VALUES. 00112 C* 00113 C* KCPACK - KCPACK GREATER THAN ZERO INDICATES COMPLEX 00114 C* PACKING, WITH A *TRIANGULAR* SUB-TRUNCATION 00115 C* "UNPACKED" OF ORDER KCPACK. 00116 C 00117 C* KSCALP - FOR COMPLEX PACKING OF SPECTRAL COEFFICIENTS 00118 C* ONLY, LAPLACIAN SCALING FACTOR. 00119 C* 00120 C* TO INDICATE MISSING DATA VALUES, KLENF IS 00121 C* MADE NEGATIVE AND ALL DATA VALUES SET TO 0. 00122 C* 00123 C* OTHER PARAMETERS 00124 C* ---------------- 00125 C* 00126 C* KNBIT - NUMBER OF BITS IN COMPUTER WORD. 00127 C* 00128 C* KGRIB - ARRAY TO RECEIVE DATA IN GRIB CODE. 00129 C* KLENG - LENGTH OF THIS ARRAY. 00130 C* 00131 C* KROUND - 0 , NO ROUNDING. 00132 C* 1 , ROUND TO NEAREST 120 OCTETS. 00133 C* 00134 C* LDARPE - .TRUE., modifications for ARPEGE coding. 00135 C* .FALSE., no such modifications. 00136 C* 00137 C* OUTPUT : KGRIB - DATA CODED IN GRIB CODE. 00138 C* KWORD - NUMBER OF WORDS OCCUPIED BY CODED DATA. 00139 C* 00140 C* KERR - ERROR INDICATOR. 00141 C* 00142 C* 0, NO ERROR. 00143 C* 00144 C* -1, NUMBER OF BITS PER DATA VALUE EXCEEDS 00145 C* WORD LENGTH, OR MAXIMUM ALLOWED. 00146 C* -2, OUTPUT ARRAY TOO SMALL TO HOLD CODED 00147 C* DATA VALUES. 00148 C* -3, CURRENTLY UNDEFINED OPTION SELECTED. 00149 C* -4, MISSING DATA FIELD CONTAINS NON-ZERO. 00150 C* -5, INVALID COMPLEX PACKING MODE. 00151 C* -6, INVALID LAPLACIAN SCALING FACTOR. 00152 C* 00153 C* 1, INVALID ORIGINATING CENTRE. 00154 C* 2, INVALID MODEL IDENTIFICATION. 00155 C* 3, INVALID GRID DEFINITION. 00156 C* 4, INVALID BLOCK INDICATOR FLAG 00157 C* 5, INVALID PARAMETER IDENTIFIER. 00158 C* 6, INVALID LEVEL TYPE INDICATOR. 00159 C* 7, ERROR IN DESCRIPTION OF LEVELS. 00160 C* 8, DATE/TIME ERROR. 00161 C* 9, INVALID TIME UNIT OR RANGE. 00162 C* 10, INVALID DATA REPRESENTATION TYPE. 00163 C* 11, INVALID EXTREME POINT/INCREMENT FLAG. 00164 C* 12, INVALID SCANNING MODE FLAGS. 00165 C* 13, INVALID COMPLEX PACKING MODE. 00166 C* 00167 C* PMIN - MINIMUM VALUE OF THE FIELD DATA. 00168 C* 00169 C* PMAX - MAXIMUM VALUE OF THE FIELD DATA. 00170 C* 00171 C* JOHN HENNESSY , ECMWF , NOVEMBER 1985 00172 C* 00173 C* Modifications by Mats HAMRUD, ECMWF, to handle complex packing of 00174 C* spectral harmonics data, 1988. 00175 C* 00176 C* Modifications by Jean CLOCHARD, French DMN, January 1990: 00177 C* 00178 C* - to remove automatic arrays introduced by the last modification 00179 C* ( *** BUT INPUT ARRAY PFDATA IS OVERWRITTEN AGAIN *** ); 00180 C* - to comply with the "DOCTOR" norm; 00181 C* - to use (standard case) as reference value the highest 32-bit 00182 C* value not exceeding the minimum of the field, this reference 00183 C* value being used to compute departures from this value; 00184 C* - to allow modifications of the packing for ARPEGE files use, 00185 C* in an optional way. 00186 C* 00187 C******************************************************************** 00188 C 00189 C 00190 C 00191 C 00192 C 00193 C 00194 #include "precision.h" 00195 C 00196 INTEGER KLENF, KBITS, KNBIT, KLENG, KWORD, KROUND, KCPACK, KSCALP 00197 INTEGER KERR, KLENV 00198 C 00199 REAL (KIND=JPDBLR) PFDATA(*), PVERT(KLENV) 00200 C 00201 REAL (KIND=JPDBLR) PMIN, PMAX 00202 C 00203 LOGICAL LDARPE 00204 C 00205 INTEGER (KIND=JPDBLE) KGRIB(KLENG) 00206 INTEGER KB1PAR(19), KB2PAR(17) 00207 C 00208 INTEGER IMAX, ILENF, IMISS, J, IBYTE, INVAL, IOFF, ITEMP, IERR 00209 INTEGER IERY, IERD, IERM, IERH, IERN, I, IEXP, IMANT, IPW, IPB 00210 INTEGER IREP, IFLAG, ICPACK, ILEN, ISCALE, ISCALX, ISTPA, IRESTE 00211 INTEGER ISCALP, IAUXIL, ILENFM, ILBIN, IL, ILNIL, IBITS, INUMBI 00212 INTEGER (KIND=JPDBLE) IL8, ILEXP, ILMANT, ILFLAG, ILSCALX 00213 INTEGER (KIND=JPDBLE) ILAUXIL, ILLBIN, ILBITS, ILSTPA, ILSCALP 00214 C 00215 INTEGER IBLOCK(24) 00216 INTEGER ILAT(2) 00217 INTEGER (KIND=JPDBLE) ILBLOCK(24), ILB2PAR(17), ILLAT(2) 00218 C 00219 REAL (KIND=JPDBLR) ZCOEFF, ZEPSIL, ZAUXIL, ZSCALE, ZS, ZREFER 00220 REAL (KIND=JPDBLR) ZAUXI2 00221 C 00222 C SET MAXIMUM NUMBER OF BITS PER DATA FIELD. 00223 C 00224 SAVE IMAX 00225 DATA IMAX /60/ 00226 C 00227 C CLEAR ERROR INDICATOR. 00228 C 00229 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00230 IF (LHOOK) CALL DR_HOOK('CODEGA',0,ZHOOK_HANDLE) 00231 KERR = 0 00232 C 00233 C 00234 C 00235 C 00236 C 00237 C******************************************************************** 00238 C* 00239 C* CHECK FOR MISSING DATA INDICATORS. 00240 C* 00241 C******************************************************************** 00242 C 00243 C 00244 IF (KLENF.LT.0) 00245 C THEN 00246 ILENF = - KLENF 00247 IMISS = 1 00248 C 00249 DO 50 J=1,ILENF 00250 C 00251 IF (PFDATA(J).NE.0.) THEN 00252 KERR = -4 00253 WRITE (*,9012) 00254 9012 FORMAT (TR1,'NON-ZERO VALUE IN MISSING DATA', 00255 C ' FIELD.') 00256 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00257 RETURN 00258 ENDIF 00259 50 CONTINUE 00260 C 00261 ELSE 00262 ILENF = KLENF 00263 IMISS = 0 00264 ENDIF 00265 C 00266 C 00267 C 00268 C 00269 C******************************************************************** 00270 C* 00271 C* CHECK NUMBER OF BITS PER DATA FIELD. 00272 C* 00273 C******************************************************************** 00274 C 00275 C 00276 IF (KBITS.GT.KNBIT.OR.KBITS.GT.IMAX) 00277 C THEN 00278 KERR = -1 00279 WRITE (*,9000) KBITS,KNBIT,IMAX 00280 9000 FORMAT (TR1,'NUMBER OF BITS PER DATA VALUE, ',I3, 00281 C 'EXCEEDS WORD LENGTH, ',I3,' OR MAXIMUM ', 00282 C ' PERMITTED VALUE, ',I3) 00283 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00284 RETURN 00285 ENDIF 00286 C 00287 C 00288 C 00289 C 00290 C 00291 C 00292 C 00293 C 00294 C 00295 C 00296 C 00297 C******************************************************************** 00298 C* 00299 C* BLOCK 0 - INDICATOR BLOCK. 00300 C* 00301 C******************************************************************** 00302 C 00303 C 00304 C 00305 C*** 00306 C* THE LETTERS G R I B ARE INSERTED IN THE 00307 C* FIRST 4 ELEMENTS OF 'IBLOCK'. 00308 C*** 00309 C 00310 IBLOCK(1) = 71 00311 IBLOCK(2) = 82 00312 IBLOCK(3) = 73 00313 IBLOCK(4) = 66 00314 C 00315 KWORD = 1 00316 IBYTE = 8 00317 INVAL = 4 00318 IOFF = 0 00319 C 00320 C PACK 4 8-BIT FIELDS IN BLOCK 0 OF CODED ARRAY. 00321 C 00322 ILBLOCK=IBLOCK 00323 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,IBYTE,0,INVAL, 00324 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 00325 IF (KERR.NE.0) THEN 00326 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00327 RETURN 00328 ENDIF 00329 C 00330 C 00331 C 00332 C 00333 C 00334 C 00335 C 00336 C 00337 C******************************************************************** 00338 C* 00339 C* BLOCK 1 - PRODUCT DEFINITION BLOCK. 00340 C* 00341 C******************************************************************** 00342 C 00343 C 00344 C 00345 C*** 00346 C* LENGTH OF BLOCK 1 (IN OCTETS) IN FIRST 3 OCTETS. 00347 C*** 00348 C 00349 IBLOCK(1) = 0 00350 IBLOCK(2) = 0 00351 IBLOCK(3) = 24 00352 C 00353 C 00354 C 00355 C 00356 C*** 00357 C* FOURTH OCTET RESERVED AND SET TO 0. 00358 C*** 00359 C 00360 IBLOCK(4) = 0 00361 C 00362 C 00363 C 00364 C 00365 C 00366 C 00367 C*** 00368 C* IDENTIFICATION OF CENTRE 00369 C*** 00370 IBLOCK(5) = KB1PAR(1) 00371 IF (KB1PAR(1).LT.1.OR.KB1PAR(1).GT.98) 00372 C THEN 00373 KERR = 1 00374 WRITE (*,9001) KB1PAR(1) 00375 9001 FORMAT (TR1,'INVALID ORIGINATING CENTRE ',I3) 00376 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00377 RETURN 00378 ENDIF 00379 C 00380 C 00381 C 00382 C 00383 C 00384 C 00385 C 00386 C*** 00387 C* MODEL IDENTIFICATION 00388 C*** 00389 C 00390 IBLOCK(6) = KB1PAR(2) 00391 IF (KB1PAR(2).LT.1.OR.KB1PAR(2).GT.255) 00392 C THEN 00393 KERR = 2 00394 WRITE (*,9002) KB1PAR(2) 00395 9002 FORMAT (TR1,'INVALID MODEL IDENTIFICATION ',I4) 00396 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00397 RETURN 00398 ENDIF 00399 C 00400 C 00401 C 00402 C 00403 C 00404 C 00405 C 00406 C 00407 C*** 00408 C* GRID DEFINITION 00409 C*** 00410 C 00411 IBLOCK(7) = KB1PAR(3) 00412 IF (KB1PAR(3).LT.1.OR.KB1PAR(3).GT.255) 00413 C THEN 00414 KERR = 3 00415 WRITE (*,9003) KB1PAR(3) 00416 9003 FORMAT (TR1,'INVALID GRID IDENTIFICATION ',I4) 00417 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00418 RETURN 00419 ENDIF 00420 C 00421 C 00422 C 00423 C 00424 C 00425 C 00426 C 00427 C 00428 C*** 00429 C* OPTIONAL BLOCK INDICATOR FLAGS ( CODE TABLE 1 ). 00430 C*** 00431 C 00432 C BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE 00433 C 00434 C NONE 00000000 0 00435 C 2 10000000 128 00436 C 3 01000000 64 00437 C 2 AND 3 11000000 192 00438 C 00439 IBLOCK(8) = KB1PAR(4) 00440 C 00441 C SHIFT 2-BIT FLAG FIELD RIGHT BY 6 BITS TO FACILITATE CHECKING 00442 C 00443 ITEMP = KB1PAR(4) / 64 00444 C 00445 IF (ITEMP.LT.0.OR.ITEMP.GT.3) KERR = 4 00446 C 00447 C CHECK IF GRID SPECIFIED IS UNCATALOGUED. 00448 C 00449 IF (KB1PAR(3).EQ.255.AND.KB1PAR(4).EQ.0) KERR = 4 00450 IF (KB1PAR(3).EQ.255.AND.KB1PAR(4).EQ.64) KERR = 4 00451 C 00452 IF (KERR.NE.0) THEN 00453 CALL PRTBIN_MF (KB1PAR(4),8,ITEMP,IERR) 00454 WRITE (*,9004) ITEMP 00455 9004 FORMAT (TR1,'INVALID BLOCK INDICATOR FLAG ',I8.8) 00456 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00457 RETURN 00458 ENDIF 00459 C 00460 C 00461 C 00462 C 00463 C*** 00464 C* PARAMETER IDENTIFIER ( CODE TABLE 2 ). 00465 C*** 00466 C 00467 IBLOCK(9) = KB1PAR(5) 00468 IF (KB1PAR(5).LT.0.OR.KB1PAR(5).GT.255) 00469 C THEN 00470 KERR = 5 00471 WRITE (*,9005) KB1PAR(5) 00472 9005 FORMAT (TR1,'INVALID PARAMETER ',I4) 00473 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00474 RETURN 00475 ENDIF 00476 C 00477 C 00478 C 00479 C 00480 C*** 00481 C* INDICATOR OF LEVEL TYPE ( CODE TABLE 3 ). 00482 C*** 00483 C 00484 IBLOCK(10) = KB1PAR(6) 00485 C 00486 C* CODE FIGURES FOR LEVEL TYPE RANGE FROM 0 - 210, WITH 200 00487 C BEING USED FOR PSEUDO-LEVELS. 00488 C 00489 IF (KB1PAR(6).LT.0.OR.KB1PAR(6).GT.210) KERR = 6 00490 IF (KERR.EQ.6) 00491 C THEN 00492 WRITE (*,9006) KB1PAR(6) 00493 9006 FORMAT (TR1,'INVALID LEVEL TYPE ',I4) 00494 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00495 RETURN 00496 ENDIF 00497 C 00498 C 00499 C 00500 C 00501 C 00502 C 00503 C 00504 C 00505 C 00506 C 00507 C 00508 C 00509 C 00510 C 00511 C 00512 C 00513 C 00514 C*** 00515 C* DESCRIPTION OF LEVEL OR LAYER ( CODE TABLE 3 ). 00516 C*** 00517 C 00518 C 00519 C 00520 C FOR CERTAIN SPECIAL LEVELS NO FURTHER DESCRIPTION IS 00521 C NECESSARY, AND THE FIELDS ARE SET TO 0. 00522 C 00523 IF (KB1PAR(6).LT.100.OR.KB1PAR(6).EQ.102) 00524 C THEN 00525 KB1PAR(7) = 0 00526 KB1PAR(8) = 0 00527 ENDIF 00528 C 00529 IBLOCK(11) = KB1PAR(7) 00530 IBLOCK(12) = KB1PAR(8) 00531 C 00532 C CERTAIN LEVEL TYPES REQUIRE THAT THE DESCRIPTION OCCUPY 00533 C BOTH 8 BIT FIELDS. 00534 C 00535 IF( (KB1PAR(6).NE. 20).AND. 00536 X (KB1PAR(6).NE.100).AND. 00537 X (KB1PAR(6).NE.103).AND. 00538 X (KB1PAR(6).NE.105).AND. 00539 X (KB1PAR(6).NE.107).AND. 00540 X (KB1PAR(6).NE.109).AND. 00541 X (KB1PAR(6).NE.111).AND. 00542 X (KB1PAR(6).NE.113).AND. 00543 X (KB1PAR(6).NE.115).AND. 00544 X (KB1PAR(6).NE.117).AND. 00545 X (KB1PAR(6).NE.125).AND. 00546 X (KB1PAR(6).NE.127).AND. 00547 X (KB1PAR(6).NE.160).AND. 00548 X (KB1PAR(6).NE.210) ) THEN 00549 C 00550 IF (KB1PAR(7).GT.255.OR.KB1PAR(8).GT.255) KERR = 7 00551 ELSE 00552 C 00553 C 8 LOW ORDER BITS IN IBLOCK(12) 00554 C HIGH ORDER BITS IN IBLOCK(11) 00555 C 00556 IBLOCK(12) = IBLOCK(11) 00557 IBLOCK(11) = IBLOCK(11) / 256 00558 IBLOCK(12) = IBLOCK(12) - IBLOCK(11) * 256 00559 C 00560 C CHECK MAXIMUM POSSIBLE IN 16 BITS. 00561 C 00562 IF (KB1PAR(7).GT.65535) KERR = 7 00563 ENDIF 00564 C 00565 IF (KERR.NE.0) 00566 C THEN 00567 WRITE (*,9007) KB1PAR(7),KB1PAR(8) 00568 9007 FORMAT (TR1,'LEVEL DESCRIPTION ERROR ',I8,3X,I8) 00569 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00570 RETURN 00571 ENDIF 00572 C 00573 C 00574 C 00575 C 00576 C 00577 C 00578 C 00579 C 00580 C 00581 C 00582 C 00583 C 00584 C 00585 C 00586 C 00587 C 00588 C 00589 C 00590 C 00591 C 00592 C 00593 C 00594 C*** 00595 C* DATE AND TIME. CHECK VALID RANGES AND MISSING DATA VALUES. 00596 C*** 00597 C 00598 IBLOCK(13) = KB1PAR(9) 00599 IERY = 0 00600 IF (KB1PAR(9).LT.0.OR.KB1PAR(9).GT.99) IERY = 1 00601 IF (KB1PAR(9).EQ.255) IERY = 0 00602 IBLOCK(14) = KB1PAR(10) 00603 IERM = 0 00604 IF (KB1PAR(10).LT.1.OR.KB1PAR(10).GT.12) IERM = 1 00605 IF (KB1PAR(10).EQ.255) IERM = 0 00606 IBLOCK(15) = KB1PAR(11) 00607 IERD = 0 00608 IF (KB1PAR(11).LT.1.OR.KB1PAR(11).GT.31) IERD = 1 00609 IF (KB1PAR(11).EQ.255) IERD = 0 00610 IBLOCK(16) = KB1PAR(12) 00611 IERH = 0 00612 IF (KB1PAR(12).LT.0.OR.KB1PAR(12).GT.23) IERH = 1 00613 IF (KB1PAR(12).EQ.255) IERH = 0 00614 IBLOCK(17) = KB1PAR(13) 00615 IERN = 0 00616 IF (KB1PAR(13).LT.0.OR.KB1PAR(13).GT.59) IERN = 1 00617 IF (KB1PAR(13).EQ.255) IERN = 0 00618 C 00619 KERR = IERY + IERM + IERD + IERH + IERN 00620 C 00621 IF (KERR.NE.0) 00622 C THEN 00623 KERR = 8 00624 WRITE (*,9008) KB1PAR(9),KB1PAR(10),KB1PAR(11),KB1PAR(12), 00625 C KB1PAR(13) 00626 9008 FORMAT (TR1,'INVALID DATE/TIME ',3I2,' / ',2I2) 00627 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00628 RETURN 00629 ENDIF 00630 C 00631 C 00632 C 00633 C 00634 C 00635 C 00636 C 00637 C 00638 C 00639 C 00640 C 00641 C 00642 C 00643 C 00644 C 00645 C 00646 C 00647 C 00648 C 00649 C 00650 C 00651 C 00652 C 00653 C*** 00654 C* UNIT OF TIME - ( CODE TABLE 4 ). 00655 C* TIME RANGE(S) AND TIME RANGE INDICATOR ( CODE TABLE 5 ). 00656 C*** 00657 C 00658 C TIME UNIT. 00659 C 00660 IBLOCK(18) = KB1PAR(14) 00661 IF (KB1PAR(14).LT.0.OR.KB1PAR(14).GT.7) KERR = 9 00662 C 00663 C* TIME UNIT CODES ARE IN THE RANGE 0 - 7, WITH 254 USED FOR SECONDS. 00664 C 00665 IF (KB1PAR(14).EQ.254) KERR = 0 00666 C 00667 C THERE CAN BE ONE OR TWO TIME RANGES, EACH IN 1 OCTECT OR 00668 C ONE TIME RANGE IN 2 OCTECTS. 00669 C 00670 IF (KB1PAR(17).EQ.0.OR.KB1PAR(17).EQ.1 00671 C .OR.KB1PAR(17).EQ.10) KB1PAR(16) = 0 00672 C 00673 C CROSS CHECK RANGE VALUES AND FLAG VALUES. 00674 C 00675 IF (KB1PAR(15).GT.65535.OR.KB1PAR(15).LT.0) KERR = 9 00676 IF (KB1PAR(15).GT.255.AND.KB1PAR(17).NE.10) KERR = 9 00677 IF (KB1PAR(16).GT.255.OR.KB1PAR(16).LT.0) KERR = 9 00678 IF (KB1PAR(17).LT.0.OR.KB1PAR(17).GT.10) KERR = 9 00679 IF (KERR.NE.0) 00680 C THEN 00681 WRITE (*,9009) KB1PAR(14),KB1PAR(15),KB1PAR(16),KB1PAR(17) 00682 9009 FORMAT (TR1,'TIME UNIT/TIME 1/TIME 2/INDICATOR ERROR - ', 00683 C I8,2X,'/',I8,2X,'/',I8,2X,'/',I8) 00684 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00685 RETURN 00686 ENDIF 00687 C 00688 IBLOCK(19) = KB1PAR(15) 00689 IBLOCK(20) = KB1PAR(16) 00690 C 00691 C ONE TIME RANGE OCCUPYING BOTH OCTETS. 00692 C 00693 IF (KB1PAR(17).EQ.10) 00694 C THEN 00695 C 8 LOW ORDER BITS IN IBLOCK(20) 00696 C HIGH ORDER BITS IN IBLOCK(19) 00697 C 00698 IBLOCK(20) = IBLOCK(19) 00699 IBLOCK(19) = IBLOCK(19) / 256 00700 IBLOCK(20) = IBLOCK(20) - IBLOCK(19) * 256 00701 ENDIF 00702 C 00703 C TIME RANGE INDICATOR 00704 C 00705 IBLOCK(21) = KB1PAR(17) 00706 C 00707 C 00708 C 00709 C 00710 C 00711 C 00712 C 00713 C*** 00714 C* NUMBER AVERAGED OR ACCUMULATED. 00715 C*** 00716 C 00717 IBLOCK(22) = 0 00718 IBLOCK(23) = 0 00719 C 00720 C 00721 C CHECK CONSISTENCY INDICATOR AND NUMBER FIELD. 00722 C 00723 IF (KB1PAR(17).EQ.3.AND.KB1PAR(18).EQ.0) 00724 C THEN 00725 KERR = 12 00726 WRITE (*,9013) KB1PAR(17),KB1PAR(18) 00727 9013 FORMAT (TR1,'INDICATOR/NUMBER AVERAGED ERROR - ', 00728 C I8,2X,'/',I8) 00729 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00730 RETURN 00731 ENDIF 00732 C 00733 C VALUE IN TWO OCTETS. 00734 C 00735 IBLOCK(22) = KB1PAR(18) 00736 C 00737 C 8 LOW ORDER BITS IN IBLOCK(23) 00738 C HIGH ORDER BITS IN IBLOCK(22) 00739 C 00740 IBLOCK(23) = IBLOCK(22) 00741 IBLOCK(22) = IBLOCK(22) / 256 00742 IBLOCK(23) = IBLOCK(23) - IBLOCK(22) * 256 00743 C 00744 C 00745 C 00746 C 00747 C 00748 C 00749 C*** 00750 C* NUMBER MISSING FROM AVERAGES/ACCUMULATIONS. 00751 C*** 00752 C 00753 IBLOCK(24) = KB1PAR(19) 00754 C 00755 C 00756 C 00757 C 00758 C 00759 C 00760 C 00761 C*** 00762 C* 00763 C* PACK 24 8-BIT FIELDS OF BLOCK 1 IN CODED ARRAY. 00764 C* 00765 C*** 00766 C 00767 IBYTE = 8 00768 INVAL = 24 00769 C 00770 ILBLOCK=IBLOCK 00771 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,IBYTE,0,INVAL, 00772 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 00773 IF (KERR.NE.0) THEN 00774 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00775 RETURN 00776 ENDIF 00777 C 00778 C 00779 C 00780 C 00781 C 00782 C 00783 C 00784 C 00785 C 00786 C 00787 C 00788 C 00789 C 00790 C 00791 C 00792 C 00793 C 00794 C 00795 C 00796 C 00797 C 00798 C 00799 C 00800 C 00801 C 00802 C 00803 C 00804 C 00805 C 00806 C 00807 C 00808 C******************************************************************** 00809 C* 00810 C* BLOCK 2 - GRID DESCRIPTION BLOCK. 00811 C* 00812 C******************************************************************** 00813 C 00814 C 00815 IF (KB1PAR(4).LT.128) GOTO 333 00816 C 00817 C 00818 C*** 00819 C* SET ARRAY IBLOCK TO 0 . IT IS USED TO ZERO FILL RESERVED OCTETS. 00820 C*** 00821 C 00822 DO 100 J=1,24 00823 IBLOCK(J) = 0 00824 100 CONTINUE 00825 C 00826 C 00827 C 00828 C 00829 C*** 00830 C* LAT/LONGITUDE GRID, GAUSSIAN GRID AND SPHERICAL HARMONICS 00831 C* ARE THE ONLY DATA REPRESENTATIONS HANDLED. 00832 C*** 00833 C 00834 IF (KB1PAR(4).EQ.128.OR.KB1PAR(4).EQ.192) 00835 C THEN 00836 IF (KB2PAR(1).NE.0.AND.KB2PAR(1).NE.4.AND.KB2PAR(1).NE.50 00837 C .AND.KB2PAR(1).NE.80) 00838 C THEN 00839 WRITE (*,*)'GRID DESCRIPTION BLOCK NOT YET DEFINED' 00840 KERR = -3 00841 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00842 RETURN 00843 ENDIF 00844 C 00845 C 00846 C 00847 C 00848 C*** 00849 C* LENGTH OF GRID DESCRIPTION BLOCK. 00850 C*** 00851 C 00852 C LENGTH IS 32 OCTETS FOR LAT/LONG, GAUSSIAN AND SPHERICAL 00853 C HARMONICS . FOR ANY DATA ON HYBRID LEVELS THE 00854 C VERTICAL COORDINATES ARE ADDED. 00855 C 00856 IF(KB2PAR(1).EQ.80) THEN 00857 I=52 00858 ELSE 00859 I = 32 00860 ENDIF 00861 IF (KB1PAR(6).GT.108) I = I + KLENV * 4 00862 C 00863 IL8=I 00864 CALL SBYTE_MF (KGRIB(KWORD),IL8,IOFF,24) 00865 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00866 IF (KERR.NE.0) THEN 00867 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00868 RETURN 00869 ENDIF 00870 C 00871 C 00872 C 00873 C 00874 C*** 00875 C* NUMBER OF UNUSED BITS AT END OF BLOCK. 00876 C* CURRENT DEFINITION IMPLIES 0. 00877 C*** 00878 C 00879 ILBLOCK=IBLOCK 00880 CALL SBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,8) 00881 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00882 IF (KERR.NE.0) THEN 00883 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00884 RETURN 00885 ENDIF 00886 C 00887 C 00888 C 00889 C 00890 C 00891 C*** 00892 C* NEXT OCTET IS RESERVED. 00893 C*** 00894 C 00895 ILBLOCK=IBLOCK 00896 CALL SBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,8) 00897 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00898 IF (KERR.NE.0) THEN 00899 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00900 RETURN 00901 ENDIF 00902 C 00903 C 00904 C 00905 C 00906 C 00907 C 00908 C*** 00909 C* DATA REPRESENTATION TYPE. 00910 C*** 00911 C 00912 ILB2PAR=KB2PAR 00913 CALL SBYTE_MF (KGRIB(KWORD),ILB2PAR(1),IOFF,8) 00914 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00915 IF (KERR.NE.0) THEN 00916 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00917 RETURN 00918 ENDIF 00919 C 00920 C 00921 C 00922 C 00923 C 00924 C 00925 C 00926 C 00927 C 00928 C 00929 C 00930 C 00931 C 00932 C 00933 C 00934 C 00935 C 00936 C 00937 C*** 00938 C* LAT/LONG OR GAUSSIAN GRID. 00939 C*** 00940 C 00941 IF (KB2PAR(1).EQ.0.OR.KB2PAR(1).EQ.4) 00942 C THEN 00943 C 00944 C NUMBER OF LAT/LONG POINTS. 00945 C 00946 ILB2PAR=KB2PAR 00947 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(2),IOFF,16,0,2, 00948 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 00949 IF (KERR.NE.0) THEN 00950 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00951 RETURN 00952 ENDIF 00953 C 00954 C LAT/LONG OF ORIGIN. 00955 C SIGN BIT SET TO 1 IF VALUES ARE NEGATIVE. 00956 C 00957 DO 200 J=1,2 00958 C 00959 IF (KB2PAR(J+3).GE.0) THEN 00960 ILAT(J) = KB2PAR(J+3) 00961 ELSE 00962 ILAT(J) = 2**23 - KB2PAR(J+3) 00963 ENDIF 00964 C 00965 200 CONTINUE 00966 C 00967 ILBLOCK=IBLOCK 00968 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,24,0,2, 00969 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 00970 IF (KERR.NE.0) THEN 00971 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00972 RETURN 00973 ENDIF 00974 C 00975 C RESOLUTION FLAG. 00976 C 00977 C INCREMENTS BINARY CODE DECIMAL VALUE 00978 C 00979 C NOT GIVEN 00000000 0 00980 C GIVEN 10000000 128 00981 C 00982 C 00983 C SHIFT 1 BIT FLAG FIELD TO LOW ORDER BIT 00984 C 00985 ITEMP = KB2PAR(6) / 128 00986 C 00987 IF (ITEMP.LE.0.OR.ITEMP.GT.1) 00988 C THEN 00989 CALL PRTBIN_MF (KB2PAR(6),8,ITEMP,IERR) 00990 WRITE (*,9011) ITEMP 00991 9011 FORMAT (TR1,'INVALID RESOLUTION FLAG ',I8.8) 00992 KERR = 11 00993 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 00994 RETURN 00995 ENDIF 00996 C 00997 C SET TO ALL 1-BITS UNUSED INCREMENT FIELDS. 00998 C 00999 IF (KB2PAR(6).EQ.0) 01000 C THEN 01001 C 1111111111111111 BINARY = 65535 DECIMAL 01002 KB2PAR(9) = 65535 01003 KB2PAR(10) = 65535 01004 ENDIF 01005 C 01006 ILB2PAR=KB2PAR 01007 CALL SBYTE_MF (KGRIB(KWORD),ILB2PAR(6),IOFF,8) 01008 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01009 IF (KERR.NE.0) THEN 01010 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01011 RETURN 01012 ENDIF 01013 C 01014 C LAT/LONG OF EXTREME POINT. 01015 C 01016 C SIGN BIT SET TO 1 IF VALUES ARE NEGATIVE. 01017 C 01018 DO 300 J=1,2 01019 C 01020 IF (KB2PAR(J+6).GE.0) THEN 01021 ILAT(J) = KB2PAR(J+6) 01022 ELSE 01023 ILAT(J) = 2**23 - KB2PAR(J+6) 01024 ENDIF 01025 C 01026 300 CONTINUE 01027 C 01028 ILLAT=ILAT 01029 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 01030 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01031 IF (KERR.NE.0) THEN 01032 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01033 RETURN 01034 ENDIF 01035 C 01036 C 01037 C 01038 C DIRECTION INCREMENTS / NUMBER OF LATITUDE LINES. 01039 C 01040 ILB2PAR=KB2PAR 01041 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(9),IOFF,16,0,2, 01042 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01043 IF (KERR.NE.0) THEN 01044 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01045 RETURN 01046 ENDIF 01047 C 01048 C SCANNING MODE FLAGS. 01049 C 01050 C VALID VALUES VALUE / 32 01051 C BINARY DECIMAL 01052 C 01053 C 00000000 0 01054 C 10000000 4 01055 C 01000000 2 01056 C 11000000 6 01057 C 00100000 1 01058 C 10100000 5 01059 C 01100000 3 01060 C 11100000 7 01061 C 01062 C SHIFT 3 BIT FLAG FIELD TO LOW ORDER BITS. 01063 C 01064 ITEMP = KB2PAR(11) / 32 01065 C 01066 IF (ITEMP.LT.0.OR.ITEMP.GT.7) 01067 C THEN 01068 CALL PRTBIN_MF (KB2PAR(11),8,ITEMP,IERR) 01069 WRITE (*,9014) ITEMP 01070 9014 FORMAT (TR1,'INVALID SCANNING MODE FLAGS ',I8.8) 01071 KERR = 12 01072 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01073 RETURN 01074 ENDIF 01075 C 01076 ILB2PAR=KB2PAR 01077 CALL SBYTE_MF (KGRIB(KWORD),ILB2PAR(11),IOFF,8) 01078 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01079 IF (KERR.NE.0) THEN 01080 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01081 RETURN 01082 ENDIF 01083 C 01084 C 4 RESERVED OCTETS. 01085 C 01086 ILBLOCK=IBLOCK 01087 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,8,0,4, 01088 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01089 IF (KERR.NE.0) THEN 01090 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01091 RETURN 01092 ENDIF 01093 C 01094 ENDIF 01095 C 01096 C 01097 C 01098 C 01099 C 01100 C 01101 C 01102 C 01103 C 01104 C 01105 C 01106 C*** 01107 C* SPHERICAL HARMONIC DATA. 01108 C*** 01109 C 01110 IF (KB2PAR(1).EQ.50.OR.KB2PAR(1).EQ.80) 01111 C THEN 01112 C 01113 C PENTAGONAL RESOLUTION PARAMETERS. 01114 C 01115 ILB2PAR=KB2PAR 01116 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(2),IOFF,16,0,3, 01117 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01118 IF (KERR.NE.0) THEN 01119 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01120 RETURN 01121 ENDIF 01122 C 01123 C REPRESENTATION TYPE AND MODE. 01124 C 01125 ILB2PAR=KB2PAR 01126 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(5),IOFF,8,0,2, 01127 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01128 IF (KERR.NE.0) THEN 01129 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01130 RETURN 01131 ENDIF 01132 C 01133 C 18 RESERVED OCTETS. 01134 C 01135 ILBLOCK=IBLOCK 01136 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,8,0,18, 01137 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01138 IF (KERR.NE.0) THEN 01139 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01140 RETURN 01141 ENDIF 01142 C 01143 ENDIF 01144 C 01145 C 01146 C*** 01147 C* ADD PARAMETERS NEEDED TO DESCRIBE STRETCHED AND ROTATED 01148 C* SPHERICAL HARMONICS DATA 01149 C*** 01150 C 01151 IF(KB2PAR(1).EQ.80) THEN 01152 C 01153 C* POLE OF ROTATION 01154 C 01155 DO 310 J=1,2 01156 C 01157 IF (KB2PAR(J+11).GE.0) THEN 01158 ILAT(J) = KB2PAR(J+11) 01159 ELSE 01160 ILAT(J) = 2**23 - KB2PAR(J+11) 01161 ENDIF 01162 C 01163 310 CONTINUE 01164 C 01165 ILLAT=ILAT 01166 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 01167 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01168 IF (KERR.NE.0) THEN 01169 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01170 RETURN 01171 ENDIF 01172 C 01173 C* ANGLE OF ROTATION 01174 ILB2PAR=KB2PAR 01175 CALL CONFP_MF (ILB2PAR(14),IEXP,IMANT) 01176 ILEXP=IEXP 01177 CALL SBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01178 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01179 IF (KERR.NE.0) THEN 01180 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01181 RETURN 01182 ENDIF 01183 ILMANT=IMANT 01184 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01185 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01186 IF (KERR.NE.0) THEN 01187 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01188 RETURN 01189 ENDIF 01190 C 01191 C* POLE OF STRETCHING 01192 C 01193 DO 320 J=1,2 01194 C 01195 IF (KB2PAR(J+14).GE.0) THEN 01196 ILAT(J) = KB2PAR(J+14) 01197 ELSE 01198 ILAT(J) = 2**23 - KB2PAR(J+14) 01199 ENDIF 01200 C 01201 320 CONTINUE 01202 ILLAT=ILAT 01203 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 01204 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01205 IF (KERR.NE.0) THEN 01206 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01207 RETURN 01208 ENDIF 01209 C 01210 C* STRETCHING FACTOR 01211 ILB2PAR=KB2PAR 01212 CALL CONFP_MF (ILB2PAR(17),IEXP,IMANT) 01213 ILEXP=IEXP 01214 CALL SBYTE_MF (KGRIB(KWORD),IEXP,IOFF,8) 01215 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01216 IF (KERR.NE.0) THEN 01217 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01218 RETURN 01219 ENDIF 01220 ILMANT=IMANT 01221 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01222 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01223 IF (KERR.NE.0) THEN 01224 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01225 RETURN 01226 ENDIF 01227 ENDIF 01228 C 01229 C 01230 C 01231 C*** 01232 C* ADD VERTICAL COORDINATE PARAMETERS FOR HYBRID LEVELS. 01233 C*** 01234 C 01235 IF (KB1PAR(6).GT.108) THEN 01236 C 01237 DO 400 J=1,KLENV 01238 CALL CONFP_MF (PVERT(J),IEXP,IMANT) 01239 ILEXP=IEXP 01240 CALL SBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01241 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01242 IF (KERR.NE.0) THEN 01243 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01244 RETURN 01245 ENDIF 01246 ILMANT=IMANT 01247 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01248 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01249 IF (KERR.NE.0) THEN 01250 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01251 RETURN 01252 ENDIF 01253 400 CONTINUE 01254 C 01255 ENDIF 01256 C 01257 ENDIF 01258 C 01259 C 01260 C 01261 C 01262 C 01263 C 01264 C 01265 333 CONTINUE 01266 C 01267 C 01268 C******************************************************************** 01269 C* 01270 C* BLOCK 3 (IF REQUIRED) - BIT MAP BLOCK. 01271 C* 01272 C******************************************************************** 01273 C 01274 IF (KB1PAR(4).EQ.64.OR.KB1PAR(4).EQ.192) 01275 C THEN 01276 WRITE (*,*)'BIT MAP BLOCK NOT YET DEFINED' 01277 KERR = -3 01278 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01279 RETURN 01280 ENDIF 01281 C 01282 C 01283 C 01284 C 01285 C 01286 C 01287 C 01288 C 01289 C 01290 C 01291 C 01292 C 01293 C 01294 C 01295 C 01296 C 01297 C 01298 C 01299 C 01300 C 01301 C 01302 C 01303 C 01304 C 01305 C******************************************************************** 01306 C* 01307 C* BLOCK 4 - BINARY DATA BLOCK. 01308 C* 01309 C******************************************************************** 01310 C 01311 C 01312 C*** 01313 C* RETAIN POINTERS TO WORD AND BIT POSITION OF BINARY DATA 01314 C* BLOCK LENGTH FIELD. ENTER LENGTH AS 0. 01315 C*** 01316 C 01317 IPW = KWORD 01318 IPB = IOFF 01319 C 01320 ILBLOCK=IBLOCK 01321 CALL SBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,24) 01322 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01323 IF (KERR.NE.0) THEN 01324 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01325 RETURN 01326 ENDIF 01327 C 01328 C 01329 C 01330 C 01331 C 01332 C 01333 C 01334 C 01335 C 01336 C 01337 C 01338 C*** 01339 C* 4 BIT FLAG / 4 BIT COUNT OF UNUSED BITS AT END OF BLOCK OCTET. 01340 C*** 01341 C 01342 C FLAG IS 1000 FOR SPHERICAL HARMONICS, 0000 FOR LAT/LONG 01343 C OR GAUSSIAN GRID, 1100 FOR SPHERICAL HARM. COMPLEX PACKING 01344 C 01345 IREP = 0 01346 IFLAG=0 01347 ICPACK=KCPACK 01348 C 01349 IF (KB2PAR(1).EQ.50.OR.KB2PAR(1).EQ.80) THEN 01350 IFLAG=128 01351 IREP=1 01352 C 01353 IF (ICPACK.LT.0) THEN 01354 WRITE (*,*) 'CODEGA : COMPLEX PACKING CODE ERROR' 01355 KERR = -5 01356 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01357 RETURN 01358 ELSEIF (IABS (KSCALP).GE.2**15) THEN 01359 WRITE (*,*) 'CODEGA : LAPLACIAN SCALING FACTOR ERROR' 01360 KERR = -6 01361 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01362 RETURN 01363 ENDIF 01364 C 01365 IF(ICPACK.NE.0.AND.KB2PAR(6).EQ.2) THEN 01366 IFLAG=IFLAG+64 01367 IREP=(ICPACK+1)**2 01368 ELSE 01369 ICPACK=0 01370 ENDIF 01371 C 01372 ENDIF 01373 C 01374 ILFLAG=IFLAG 01375 CALL SBYTE_MF (KGRIB(KWORD),ILFLAG,IOFF,8) 01376 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01377 IF (KERR.NE.0) THEN 01378 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01379 RETURN 01380 ENDIF 01381 C 01382 C 01383 C 01384 C 01385 C 01386 C 01387 C 01388 C 01389 C 01390 C 01391 C 01392 C*** 01393 C* FIND MAXIMUM AND MINIMUM VALUES IN DATA ARRAY. FOR 01394 C* DATA IN SPHERICAL HARMONIC FORM THE FIRST WORD CONTAINS 01395 C* THE REAL (0,0)COEFFICIENT, WHICH IS TREATED SEPARATELY. 01396 C* FOR COMPLEX PACKING AND SPECTRAL DATA REPRESENTATION MODE=2 01397 C* THE FIRST (ICPACK+1)**2 COEFFICENTS ARE NOT PACKED 01398 C*** 01399 C 01400 C 01401 ILEN = ILENF - IREP 01402 CALL MXMN_MF (PFDATA(IREP+1),ILEN,PMAX,PMIN) 01403 C 01404 C 01405 C 01406 C 01407 C 01408 C 01409 C 01410 C 01411 C 01412 C 01413 C 01414 C 01415 C 01416 C 01417 C 01418 C 01419 C*** 01420 C* COMPUTE REFERENCE VALUE AND SCALE FACTOR. 01421 C*** 01422 C 01423 IF (LDARPE) THEN 01424 C 01425 ZCOEFF = PMAX - PMIN 01426 ZEPSIL=1.E-290 01427 C 01428 IF ( ZCOEFF .LE. ZEPSIL ) THEN 01429 ZAUXIL=MIN ( ABS (PMIN), ABS (PMAX) ) 01430 IF ( ZAUXIL .LE. ZEPSIL ) ZAUXIL=0. 01431 C 01432 PMAX=SIGN (ZAUXIL,PMAX) 01433 PMIN=PMAX 01434 ZSCALE=0. 01435 ELSE 01436 ZSCALE=REAL (2**KBITS-1) / ZCOEFF 01437 ENDIF 01438 C 01439 C Scale factor and reference value forced to zero. 01440 C 01441 ISCALE=0 01442 ZREFER=PMIN 01443 IEXP=0 01444 IMANT=0 01445 C 01446 ELSEIF (IMISS.EQ.1) THEN 01447 C 01448 C Scaling factor, 01449 C EXPONENT AND MANTISSA SET TO ALL 1-BITS FOR MISSING DATA. 01450 C 01451 ISCALE = 65535 01452 IEXP = 255 01453 IMANT = 16777215 01454 ZREFER = PMIN 01455 C 01456 ELSE 01457 C 01458 C CONVERT MINIMUM VALUE (PMIN) TO GRIB FORMAT (IEXP,IMANT). 01459 C 01460 C Its image decoded back is being used as reference value to compute 01461 C (in PACKGB) normalized integer field values that will be 01462 C chained into the binary string. 01463 C 01464 CALL CONFI (PMIN,IEXP,IMANT,ZREFER) 01465 C 01466 ZS = (PMAX-ZREFER)/(2**(KBITS+1)-1) 01467 ZAUXIL=1. 01468 ZAUXI2=2. 01469 C 01470 C CONFI may return ZREFER > PMAX if the range 01471 C of PMAX-PMIN is smaller than the GRIB accuracy 01472 C 01473 IF (ZS.GT.0.) THEN 01474 ZS = LOG(ZS)/LOG(ZAUXI2) + ZAUXI2 01475 ELSE 01476 ZS=0. 01477 ENDIF 01478 ISCALE = MIN(INT(ZS),INT(ZS+SIGN(ZAUXIL,ZS))) 01479 C 01480 C Absolute value of ISCALE is limited, to avoid problems due to 01481 C fields constant except on a few points. 01482 C 01483 ISCALE = MAX(-99,MIN(99,ISCALE)) 01484 ZSCALE = ZAUXI2** (-ISCALE) 01485 C 01486 ENDIF 01487 C 01488 C 01489 C 01490 C 01491 C SET SIGN BIT (BIT 16) AND PUT SCALE FACTOR INTO REMAINING 01492 C 15 BITS OF CODED 16 BIT FIELD. 01493 C 01494 IF (ISCALE.GE.0) THEN 01495 ISCALX = ISCALE 01496 ELSE 01497 ISCALX= 2**15 - ISCALE 01498 ENDIF 01499 C 01500 ILSCALX=ISCALX 01501 CALL SBYTE_MF (KGRIB(KWORD),ILSCALX,IOFF,16) 01502 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01503 IF (KERR.NE.0) THEN 01504 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01505 RETURN 01506 ENDIF 01507 C 01508 C 01509 C 01510 C 01511 C 01512 IF (IEXP.EQ.0.AND.IMANT.EQ.0) THEN 01513 ILMANT=IMANT 01514 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,32) 01515 CALL OFFSET_MF (IOFF,1,KWORD,32,KNBIT,KLENG,KERR) 01516 ELSE 01517 ILEXP=IEXP 01518 CALL SBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01519 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01520 IF (KERR.NE.0) THEN 01521 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01522 RETURN 01523 ENDIF 01524 ILMANT=IMANT 01525 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01526 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01527 ENDIF 01528 C 01529 IF (KERR.NE.0) THEN 01530 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01531 RETURN 01532 ENDIF 01533 C 01534 C 01535 C 01536 C 01537 C*** 01538 C* NUMBER OF BITS IN EACH DATA VALUE. 01539 C*** 01540 C 01541 ILBITS=KBITS 01542 CALL SBYTE_MF (KGRIB(KWORD),ILBITS,IOFF,8) 01543 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01544 IF (KERR.NE.0) THEN 01545 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01546 RETURN 01547 ENDIF 01548 C 01549 C 01550 C 01551 C 01552 C*** 01553 C* IF COMPLEX PACKING DESCRIBE PACKING 01554 C*** 01555 C 01556 IF (IREP.NE.0.AND.ICPACK.NE.0) THEN 01557 C 01558 C START OF PACKED DATA 01559 C 01560 ISTPA=19+IREP*4 01561 C 01562 C Removing of the padding (06 sept 2000, not correct and useless) 01563 C 01564 C IRESTE=MOD (IOFF+40+IREP*32,KNBIT) 01565 CC 01566 C IF (IRESTE.NE.0) THEN 01567 CC 01568 C IF ( MOD (KNBIT,KBITS).EQ.0 .AND. MOD (IRESTE,8).EQ.0 .AND. 01569 C S MOD (KBITS,IRESTE).NE.0 ) THEN 01570 CC 01571 CC Packed data will start on a word boundary, 01572 CC and each packed data will be into a single word. 01573 CC 01574 C ISTPA=ISTPA+IRESTE/8 01575 C ENDIF 01576 CC 01577 C ENDIF 01578 C 01579 ILSTPA=ISTPA 01580 CALL SBYTE_MF (KGRIB(KWORD),ILSTPA,IOFF,16) 01581 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01582 IF (KERR.NE.0) THEN 01583 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01584 RETURN 01585 ENDIF 01586 C 01587 C SCALING FACTOR. 01588 C 01589 IF (KSCALP.GE.0) THEN 01590 ISCALP=KSCALP 01591 ELSE 01592 ISCALP=2**15-KSCALP 01593 ENDIF 01594 C 01595 ILSCALP=ISCALP 01596 CALL SBYTE_MF (KGRIB(KWORD),ILSCALP,IOFF,16) 01597 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01598 IF (KERR.NE.0) THEN 01599 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01600 RETURN 01601 ENDIF 01602 C 01603 C TRUNCATION FOR UNPACKED PART OF SPECTRAL DATA, CURRENTLY 01604 C ONLY TRIANGULAR TRUNCATION SUPPORTED 01605 C 01606 IAUXIL=ICPACK*(1+2**8*(1+2**8)) 01607 ILAUXIL=IAUXIL 01608 CALL SBYTE_MF (KGRIB(KWORD),ILAUXIL,IOFF,24) 01609 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01610 IF (KERR.NE.0) THEN 01611 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01612 RETURN 01613 ENDIF 01614 C 01615 ENDIF 01616 C*** 01617 C* IF SPHERICAL HARMONICS DATA, NEXT 4 OCTETS ARE DIFFERENT FORMAT. 01618 C*** 01619 C 01620 IF (IREP.NE.0) 01621 C THEN 01622 C 01623 C STORE IREP COEFFICIENTS IN FLOATING 01624 C POINT FORM. 01625 C 01626 IF (LDARPE) THEN 01627 C 01628 C THE "UNPACKED" PART IS FILLED WITH ZEROES. 01629 C 01630 IEXP=0 01631 IMANT=0 01632 C 01633 DO 510 J=1,IREP 01634 ILMANT=IMANT 01635 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,32) 01636 CALL OFFSET_MF (IOFF,1,KWORD,32,KNBIT,KLENG,KERR) 01637 IF (KERR.NE.0) THEN 01638 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01639 RETURN 01640 ENDIF 01641 510 CONTINUE 01642 C 01643 ELSE 01644 C 01645 C STANDARD CASE. 01646 C 01647 DO 520 J=1,IREP 01648 CALL CONFP_MF (PFDATA(J),IEXP,IMANT) 01649 C 01650 ILEXP=IEXP 01651 CALL SBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01652 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01653 IF (KERR.NE.0) THEN 01654 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01655 RETURN 01656 ENDIF 01657 ILMANT=IMANT 01658 CALL SBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01659 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01660 IF (KERR.NE.0) THEN 01661 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01662 RETURN 01663 ENDIF 01664 520 CONTINUE 01665 C 01666 ENDIF 01667 C 01668 ENDIF 01669 C 01670 C 01671 C 01672 C 01673 C*** 01674 C* SCALE AND STORE DATA VALUES. 01675 C*** 01676 C 01677 C DO 600 J = IREP+1 , ILENF 01678 C IPDATA = NINT ( (PFDATA(J)-ZREFER) * ZSCALE ) 01679 C PFDATA(J)=OR (IPDATA,0) 01680 C 600 CONTINUE 01681 C 01682 ILENFM = ILENF - IREP 01683 CALL PACKGB (PFDATA(IREP+1),PFDATA(IREP+1),ZREFER,ZSCALE,ILENFM) 01684 CALL GSBYTE_MF (KGRIB(KWORD),PFDATA(IREP+1),IOFF,KBITS,0,ILENFM, 01685 S KNBIT,'C',KLENG,KERR,KWORD,.TRUE.) 01686 IF (KERR.NE.0) THEN 01687 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01688 RETURN 01689 ENDIF 01690 C 01691 C 01692 C 01693 C 01694 C 01695 C 01696 C 01697 C 01698 C 01699 C 01700 C 01701 C*** 01702 C* ENTER LENGTH OF BINARY DATA BLOCK, HAVING ENSURED THAT 01703 C* THE LENGTH IS AN EVEN NUMBER OF OCTETS. 01704 C*** 01705 C 01706 C LENGTH OF BINARY DATA BLOCK IN BITS. 01707 C 01708 ILBIN = (KWORD-IPW) * KNBIT + IOFF - IPB 01709 C 01710 IL = MOD (ILBIN,16) 01711 C 01712 C FILL UNUSED PORTION OF LAST 2 OCTETS WITH BINARY ZEROES. 01713 C 01714 ILNIL = 0 01715 C 01716 IF (IL.NE.0) THEN 01717 ILNIL = 16 - IL 01718 ILBLOCK=IBLOCK 01719 CALL SBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,ILNIL) 01720 CALL OFFSET_MF (IOFF,1,KWORD,ILNIL,KNBIT,KLENG,KERR) 01721 IF (KERR.NE.0) THEN 01722 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01723 RETURN 01724 ENDIF 01725 ENDIF 01726 C 01727 ILBIN = (KWORD-IPW) * KNBIT + IOFF - IPB 01728 C 01729 C ENTER LENGTH - IN OCTETS - OF DATA BLOCK. 01730 C 01731 ILBIN = ILBIN / 8 01732 ILLBIN=ILBIN 01733 CALL SBYTE_MF (KGRIB(IPW),ILLBIN,IPB,24) 01734 CALL OFFSET_MF (IPB,1,IPW,24,KNBIT,KLENG,KERR) 01735 C 01736 C ENTER NUMBER OF UNUSED BITS IN FLAG/BIT COUNT FIELD. 01737 C 01738 IFLAG = IFLAG + ILNIL 01739 ILFLAG=IFLAG 01740 CALL SBYTE_MF (KGRIB(IPW),ILFLAG,IPB,8) 01741 C 01742 C 01743 C 01744 C 01745 C 01746 C 01747 C 01748 C 01749 C 01750 C 01751 C 01752 C 01753 C 01754 C 01755 C 01756 C 01757 C 01758 C 01759 C 01760 C 01761 C******************************************************************** 01762 C* 01763 C* BLOCK 5 - END BLOCK. 01764 C* 01765 C******************************************************************** 01766 C 01767 C 01768 C*** 01769 C* ADD 7 7 7 7 TO CODED DATA. 01770 C*** 01771 C 01772 IBLOCK(1) = 55 01773 IBLOCK(2) = 55 01774 IBLOCK(3) = 55 01775 IBLOCK(4) = 55 01776 C 01777 ILBLOCK=IBLOCK 01778 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,8,0,4, 01779 S KNBIT,'C',KLENG,KERR,KWORD,.FALSE.) 01780 IF (KERR.NE.0) THEN 01781 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01782 RETURN 01783 ENDIF 01784 C 01785 C 01786 C*** 01787 C* SET ANY UNUSED PART OF LAST WORD TO BINARY ZEROES. 01788 C*** 01789 C 01790 IF (IOFF.NE.KNBIT) 01791 C THEN 01792 IBITS = KNBIT - IOFF 01793 ILBLOCK=IBLOCK 01794 CALL SBYTE_MF (KGRIB(KWORD),ILBLOCK(5),IOFF,IBITS) 01795 ENDIF 01796 C 01797 C 01798 C 01799 C*** 01800 C* ROUND TO 120 OCTETS, IF REQUIRED. 01801 C*** 01802 C 01803 IF (KROUND.EQ.1) 01804 C THEN 01805 INUMBI = KWORD * KNBIT 01806 I = INUMBI / 960 01807 I = I * 960 01808 I = INUMBI - I 01809 IF (I.NE.0) I = (960 - I) / KNBIT 01810 C 01811 DO 700 J=KWORD+1,KWORD+I 01812 KGRIB(J) = 0 01813 700 CONTINUE 01814 C 01815 KWORD = KWORD + I 01816 ENDIF 01817 C 01818 IF (LHOOK) CALL DR_HOOK('CODEGA',1,ZHOOK_HANDLE) 01819 END 01820
1.8.0
