|
SURFEX v7.3
General documentation of Surfex
|
|
SURFEX v7.3
General documentation of Surfex
|
00001 SUBROUTINE DECOGA (PFDATA,KLENF,KBITS,KNBIT,KB1PAR, 00002 C KB2PAR,PVERT,KLENV,KGRIB,KLENG,KWORD, 00003 C KJLENV,KJLENF,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 00011 C 00012 C******************************************************************** 00013 C* 00014 C* NAME : DECOGA 00015 C* 00016 C* FUNCTION : DECODE WMO GRIB CODED DATA. 00017 C* 00018 C* INPUT : KNBIT - NUMBER OF BITS IN COMPUTER WORD 00019 C* 00020 C* KGRIB - INTEGER ARRAY CONTAINING DATA IN GRIB CODE. 00021 C* KLENG - LENGTH OF ARRAY KGRIB. 00022 C* 00023 C* PVERT - REAL ARRAY TO RECEIVE VERTICAL COORDINATE 00024 C* PARAMETERS. 00025 C* KLENV - LENGTH OF ARRAY PVERT. 00026 C* 00027 C* PFDATA - REAL ARRAY TO RECEIVE DECODED DATA VALUES. 00028 C* KLENF - LENGTH OF ARRAY PFDATA. 00029 C* 00030 C* ***** IF THIS IS 1 ONLY 00031 C* THE PRODUCT AND GRID DEFINITION BLOCKS 00032 C* ARE DECODED. ***** 00033 C* 00034 C* KB1PAR - INTEGER ARRAY (DIMENSION 19) TO RECEIVE 00035 C* PRODUCT DEFINITION INFORMATION. 00036 C* 00037 C* KB2PAR - INTEGER ARRAY (DIMENSION 11) TO RECEIVE GRID 00038 C* DEFINITION INFORMATION. 00039 C* 00040 C* PMIN - MINIMUM VALUE OF THE FIELD DATA. 00041 C* 00042 C* PMAX - MAXIMUM VALUE OF THE FIELD DATA. 00043 C* 00044 C* ***** These 2 last values have only to be supplied 00045 C* if next argument is .TRUE. . ***** 00046 C* 00047 C* LDARPE - .TRUE., modifications for ARPEGE coding 00048 C* have been included when coding data; 00049 C* .FALSE., no such modifications. 00050 C* 00051 C* OUTPUT : PARAMETERS FROM BLOCK 1 , PRODUCT DEFINITION BLOCK. 00052 C* -------------------------------------------------- 00053 C* KB1PAR - INTEGER ARRAY (DIMENSION 19) OF PRODUCT 00054 C* DEFINITION INFORMATION. 00055 C* 00056 C* WORD CONTENTS 00057 C* ---- -------- 00058 C* 1 ORIGINATING CENTRE IDENTIFIER. 00059 C* 2 MODEL IDENTIFICATION. 00060 C* 3 GRID DEFINITION. 00061 C* 4 FLAG ( CODE TABLE 1) 00062 C* 5 PARAMETER IDENTIFIER ( CODE TABLE 2 ). 00063 C* 6 TYPE OF LEVEL (CODE TABLE 3). 00064 C* 7-8 VALUE(S) OF LEVELS (CODE TABLE 3). 00065 C* 9 YEAR OF DATA 00066 C* 10 MONTH OF DATA 00067 C* 11 DAY OF DATA 00068 C* 12 HOUR OF DATA 00069 C* 13 MINUTE OF DATA 00070 C* 14 TIME UNIT (CODE TABLE 4). 00071 C* 15 TIME RANGE ONE 00072 C* 16 TIME RANGE TWO 00073 C* 17 TIME RANGE FLAG (CODE TABLE 5). 00074 C* 18 NUMBER AVERAGED OR ACCUMULATED. 00075 C* 19 NUMBER MISSING FROM AVERAGES/ACCUMULATIONS. 00076 C* 00077 C* VALUE(S) OF LEVEL CAN OCCUPY 2 WORDS.. 00078 C* FOR A LAYER THE FIRST WORD DEFINES THE TOP 00079 C* AND THE SECOND THE BOTTOM OF THE LAYER. 00080 C* FOR A SINGLE LEVEL, ONLY THE FIRST WORD IS 00081 C* USED. 00082 C* 00083 C* PARAMETERS FROM BLOCK 2 , GRID DEFINITION BLOCK. 00084 C* ----------------------------------------------- 00085 C* KB2PAR - INTEGER ARRAY (DIMENSION 17) CONTAINING GRID 00086 C* DEFINITION INFORMATION. 00087 C* USE VARIES WITH DATA REPRESENTATION TYPE. 00088 C* 00089 C* WORD LAT/LONG GRID 00090 C* ---- ------------- 00091 C* 1 DATA REPRESENTATION TYPE (CODE TABLE 6). 00092 C* 2 NO. OF POINTS ALONG A LATITUDE 00093 C* 3 NO. OF POINTS ALONG A MERIDIAN. 00094 C* 4 LATITUDE OF ORIGIN (SOUTH - IVE). 00095 C* 5 LONGITUDE OF ORIGIN (WEST - IVE). 00096 C* 6 RESOLUTION FLAG. (CODE TABLE 7) 00097 C* 7 LATITUDE OF EXTREME POINT (SOUTH - IVE). 00098 C* 8 LONGITUDE OF EXTREME POINT (WEST - IVE). 00099 C* 9 LATITUDE INCREMENT 00100 C* 10 LONGITUDE INCREMENT 00101 C* 11 SCANNING MODE FLAGS (CODE TABLE 8) 00102 C* 00103 C* WORD GAUSSIAN GRID 00104 C* ---- ------------- 00105 C* 1-9 AS FOR LAT/LONGITUDE GRID. 00106 C* 10 THE NUMBER OF LATITUDE LINES BETWEEN A POLE 00107 C* AND THE EQUATOR. 00108 C* 11 SCANNING MODE FLAGS (CODE TABLE 8) 00109 C* 00110 C* WORD SPHERICAL HARMONICS 00111 C* ---- ------------------- 00112 C* 1 DATA REPRESENTATION TYPE (CODE TABLE 6) 00113 C* 2 J - PENTAGONAL RESOLUTION PARAMETER 00114 C* 3 K - PENTAGONAL RESOLUTION PARAMETER 00115 C* 4 M - PENTAGONAL RESOLUTION PARAMETER 00116 C* 5 REPRESENTATION TYPE (CODE TABLE 9) 00117 C* 6 REPRESENTATION MODE (CODE TABLE 10) 00118 C* 7-11 NOT USED 00119 C* 00120 C* 00121 C* USE FOR OTHER DATA REPRESENTATION TYPES IS 00122 C* 00123 C* PVERT - REAL ARRAY OF VERTICAL COORDINATE PARAMETERS 00124 C* KJLENV - NUMBER OF VALUES IN THIS ARRAY. 00125 C* 00126 C* USED FOR HYBRID LEVELS ONLY. 00127 C* 00128 C* PARAMETERS FROM BLOCK 3 , BIT-MAP DEFINITION BLOCK. 00129 C* -------------------------------------------------- 00130 C* 00131 C* TO BE DEFINED LATER. 00132 C* 00133 C* PARAMETERS FROM BLOCK 4 , BINARY DATA BLOCK. 00134 C* ------------------------------------------- 00135 C* PFDATA - ARRAY OF FLOATING POINT VALUES. 00136 C* KJLENF - NUMBER OF VALUES IN THIS ARRAY. 00137 C* KJLENF IS NEGATIVE IF MISSING DATA CODED 00138 C* 00139 C* KBITS - NUMBER OF BITS FOR CODED DATA VALUES. 00140 C* 00141 C* KWORD - NUMBER OF WORDS DECODED. 00142 C* 00143 C* KCPACK - KCPACK GREATER THAN ZERO INDICATES COMPLEX 00144 C* PACKING, WITH A *TRIANGULAR* SUB-TRUNCATION 00145 C* "UNPACKED" OF ORDER KCPACK. 00146 C 00147 C* KSCALP - FOR COMPLEX PACKING OF SPECTRAL COEFFICIENTS 00148 C* ONLY, LAPLACIAN SCALING FACTOR. 00149 C* 00150 C* ***** THE 2 NEXT VALUES ARE SUPPLIED BY THE ROUTINE 00151 C* ONLY IF ARGUMENT "LDARPE" IS .FALSE. . ***** 00152 C* 00153 C* PMIN - MINIMUM VALUE OF THE FIELD DATA, OR A SLIGHT 00154 C* UNDER-APPROXIMATION OF THE "TRUE" MINIMUM OF 00155 C* DECODED FIELD DATA. 00156 C* 00157 C* PMAX - OVER-ESTIMATION OF THE MAXIMUM VALUE OF THE 00158 C* FIELD DATA (COMPUTED WITH PMIN, THE SCALE 00159 C* FACTOR "ISCALE" OF GRIB, AND KBITS). 00160 C* 00161 C* 00162 C* KERR - ERROR INDICATOR. 00163 C* 00164 C* 0, NO ERROR. 00165 C* 00166 C* -1, NUMBER OF BITS PER DATA VALUE EXCEEDS 00167 C* WORD LENGTH, OR MAXIMUM ALLOWED. 00168 C* -2, INPUT ARRAY HOLDS FEWER CODED VALUES 00169 C* THAN EXPECTED. 00170 C* -3, OUTPUT ARRAY TOO SMALL TO HOLD DECODED 00171 C* DATA VALUES. 00172 C* -4, CURRENTLY UNDEFINED OPTION SELECTED. 00173 C* 00174 C* 1, NO BLOCK 5 FOUND. 00175 C 2, ERROR IN CONVERTING OLD TO NEW FORM OF 00176 C BLOCK 1 OR 2. 00177 C* 3, NO BLOCK 0 FOUND. 00178 C* 00179 C* GENERAL : DECOGA CALLS GBYTE 00180 C* GSBYTE 00181 C* OFFSET 00182 C* DECFP 00183 C* 00184 C* 00185 C* MODIFIED : J. HENNESSY 17.06.87 00186 C* CONVERT OLD FORMAT BLOCK 1 AND 2 TO NEW FORMAT. 00187 C* ( DISTINCTION BETWEEN ANALYSIS AND INITIALISED 00188 C* NOT POSSIBLE ). 00189 C* 00190 C* Modifications by Mats HAMRUD, ECMWF, to handle complex unpacking 00191 C* of spectral harmonics data, 1988. 00192 C* 00193 C* Modifications by Jean CLOCHARD, French DMN, February 1990: 00194 C* 00195 C* - to remove automatic arrays introduced by the last modification; 00196 C* - to comply with the "DOCTOR" norm; 00197 C* - to allow modifications of the unpacking for ARPEGE files use, 00198 C* in an optional way. 00199 C* 00200 C******************************************************************** 00201 C 00202 C 00203 C 00204 C 00205 C 00206 C 00207 C 00208 C 00209 C 00210 00211 USE SDL_MOD , ONLY : SDL_SRLABORT 00212 00213 #include "precision.h" 00214 C 00215 INTEGER KLENF, KBITS, KNBIT, KLENV, KLENG, KWORD, KJLENV, KJLENF 00216 INTEGER KCPACK, KSCALP, KERR 00217 C 00218 INTEGER KB1PAR(19),KB2PAR(17) 00219 INTEGER (KIND=JPDBLE) KGRIB(KLENG) 00220 C 00221 REAL (KIND=JPDBLR) PMIN, PMAX 00222 C 00223 REAL (KIND=JPDBLR) PFDATA(KLENF), PVERT(KLENV) 00224 C 00225 LOGICAL LDARPE 00226 C 00227 INTEGER IMAX, IOFF, IBYTE, INVAL, ISNEW, J, ITEMP, INC, ILBLK 00228 INTEGER ILNIL, IEXP, IMANT, ILEN, IPW, IPB, ILBIN, IFLAG, IREP 00229 INTEGER ISCALX, ISCALE, IMISS, ISPDA, IPREMC, ISSUIV, IL, ILBVAL 00230 INTEGER (KIND=JPDBLE) ILEXP, ILMANT, ILFLAG, ILSCALX, ILLNIL 00231 INTEGER (KIND=JPDBLE) ILLBLK, ILLBIN, ILBITS, ILSPDA, ILSCALP 00232 INTEGER (KIND=JPDBLE) ILCPACK 00233 C 00234 C 00235 INTEGER IBLOCK(24), ILAT(2) 00236 INTEGER (KIND=JPDBLE) ILBLOCK(24), ILB2PAR(17), ILLAT(2) 00237 C 00238 REAL (KIND=JPDBLR) ZSCALE 00239 C 00240 C 00241 C SET MAXIMUM NUMBER OF BITS PER DATA FIELD. 00242 C 00243 SAVE IMAX 00244 DATA IMAX /60/ 00245 C 00246 C CLEAR ERROR INDICATOR. 00247 C 00248 REAL(KIND=JPRB) :: ZHOOK_HANDLE 00249 IF (LHOOK) CALL DR_HOOK('DECOGA',0,ZHOOK_HANDLE) 00250 KERR = 0 00251 C 00252 C 00253 C 00254 C 00255 C 00256 C 00257 C 00258 C 00259 C 00260 C 00261 C 00262 C 00263 C 00264 C 00265 C 00266 C 00267 C 00268 C******************************************************************** 00269 C* 00270 C* BLOCK 0 - INDICATOR BLOCK. 00271 C* 00272 C******************************************************************** 00273 C 00274 C 00275 C EXTRACT 4 OCTETS CONTAINING ASCII G R I B . 00276 C 00277 KWORD = 1 00278 IOFF = 0 00279 IBYTE = 8 00280 INVAL = 4 00281 C 00282 CALL GSBYTE_MF (KGRIB(1),ILBLOCK(1),IOFF,IBYTE,0,INVAL, 00283 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00284 IBLOCK=ILBLOCK 00285 C 00286 IF (KERR.NE.0) THEN 00287 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00288 RETURN 00289 ELSEIF (IBLOCK(1).NE.71.AND.IBLOCK(2).NE.82.AND. 00290 S IBLOCK(3).NE.73.AND.IBLOCK(4).NE.66) THEN 00291 KERR=3 00292 WRITE (UNIT=*,FMT=*) 'NO ''GRIB'' GROUP (BLOCK 0) FOUND' 00293 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00294 RETURN 00295 ENDIF 00296 C 00297 C 00298 C 00299 C 00300 C 00301 C 00302 C 00303 C******************************************************************** 00304 C* 00305 C* BLOCK 1 - PRODUCT DEFINITION BLOCK. 00306 C* 00307 C******************************************************************** 00308 C 00309 C 00310 C EXTRACT FIRST 4 OCTETS OF BLOCK 1. 00311 C 00312 INVAL = 4 00313 C 00314 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,IBYTE,0,INVAL, 00315 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00316 IBLOCK=ILBLOCK 00317 IF (KERR.NE.0) THEN 00318 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00319 RETURN 00320 ENDIF 00321 C 00322 C IF THESE OCTETS DO NOT CONTAIN 0, 0, 24 AND 0 RESPECTIVELY 00323 C THEN THE DATA IS IN THE OLD VERSION OF THE CODE. 00324 C 00325 IF (IBLOCK(1).EQ.0.AND.IBLOCK(2).EQ.0.AND.IBLOCK(3).EQ.24. 00326 C AND.IBLOCK(4).EQ.0) 00327 C THEN 00328 ISNEW = 1 00329 INVAL = 20 00330 ELSE 00331 ISNEW = 0 00332 INVAL = 16 00333 ENDIF 00334 C 00335 C EXTRACT NEXT 16 OR 20 OCTETS OF BLOCK 1 - NUMBER DEPENDS 00336 C ON VERSION OF CODE. 00337 C 00338 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(5),IOFF,IBYTE,0,INVAL, 00339 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00340 IBLOCK=ILBLOCK 00341 IF (KERR.NE.0) THEN 00342 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00343 RETURN 00344 ENDIF 00345 C 00346 C TRANSFER PRODUCT DEFINITION INFORMATION TO OUTPUT ARRAY. 00347 C EXCEPT FOR NUMBER AVERAGED/ACCUMULATED AND MISSING FROM AVER/ACCUM 00348 C 00349 DO 100 J=1,17 00350 KB1PAR(J) = IBLOCK(J+4*ISNEW) 00351 100 CONTINUE 00352 C 00353 C 00354 C 00355 C 00356 C NUMBER AVERAGED OCCUPIES 2 OCTETS. 00357 C 00358 KB1PAR(18) = IBLOCK(18+4*ISNEW) * 256 + IBLOCK(19+4*ISNEW) 00359 C 00360 C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS. 00361 C 00362 KB1PAR(19)=IBLOCK(20+4*ISNEW) 00363 C 00364 C 00365 C*** 00366 C* DESCRIPTION OF LEVEL OR LAYER ( CODE TABLE 3 ). 00367 C*** 00368 C 00369 C CERTAIN LEVEL TYPES REQUIRE THAT THE DESCRIPTION OCCUPY 00370 C BOTH 8 BIT FIELDS. PUT SINGLE VALUE IN FIRST LEVEL WORD. 00371 C 00372 ITEMP = 32 + (ISNEW*224) 00373 C 00374 IF( (KB1PAR(6).EQ. 20).OR. 00375 X (KB1PAR(6).EQ.100).OR. 00376 X (KB1PAR(6).EQ.103).OR. 00377 X (KB1PAR(6).EQ.105).OR. 00378 X (KB1PAR(6).EQ.107).OR. 00379 X (KB1PAR(6).EQ.109).OR. 00380 X (KB1PAR(6).EQ.111).OR. 00381 X (KB1PAR(6).EQ.113).OR. 00382 X (KB1PAR(6).EQ.115).OR. 00383 X (KB1PAR(6).EQ.117).OR. 00384 X (KB1PAR(6).EQ.125).OR. 00385 X (KB1PAR(6).EQ.127).OR. 00386 X (KB1PAR(6).EQ.160).OR. 00387 X (KB1PAR(6).EQ.210) ) THEN 00388 C 00389 KB1PAR(7) = KB1PAR(7) * ITEMP + KB1PAR(8) 00390 KB1PAR(8) = 0 00391 ENDIF 00392 C 00393 C 00394 C 00395 C 00396 C 00397 C 00398 C 00399 C 00400 C 00401 C*** 00402 C* TIME RANGE. 00403 C*** 00404 C 00405 C ONE TIME RANGE CAN OCCUPY TWO OCTETS. 00406 C 00407 IF (KB1PAR(17).EQ.10) 00408 C THEN 00409 KB1PAR(15) = KB1PAR(15) * ITEMP + KB1PAR(16) 00410 KB1PAR(16) = 0 00411 ENDIF 00412 C 00413 C 00414 C 00415 C 00416 C 00417 C 00418 C 00419 C 00420 C 00421 C 00422 C 00423 C******************************************************************** 00424 C* 00425 C* BLOCK 2 - GRID DESCRIPTION BLOCK. 00426 C* 00427 C******************************************************************** 00428 C 00429 C*** 00430 C* CHECK FLAG INDICATING IF BLOCK 2 IS INCLUDED IN CODE. 00431 C*** 00432 C 00433 C INC IS SET TO 1 , IF BLOCK 2 IS INCLUDED. 00434 C 00435 INC = 0 00436 C 00437 C 00438 IF (ISNEW.EQ.0) 00439 C THEN 00440 C OLD VERSION OF CODE 00441 C 00442 C BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE 00443 C 00444 C NONE 00000000 0 00445 C 2 00000001 1 00446 C 3 00000010 2 00447 C 2 AND 3 00000011 3 00448 C 00449 IF (KB1PAR(4).EQ.1.OR.KB1PAR(4).EQ.3) INC = 1 00450 ELSE 00451 C NEW VERSION 00452 C 00453 C BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE 00454 C 00455 C NONE 00000000 0 00456 C 2 10000000 128 00457 C 3 01000000 64 00458 C 2 AND 3 11000000 192 00459 C 00460 IF (KB1PAR(4).EQ.128.OR.KB1PAR(4).EQ.192) INC = 1 00461 ENDIF 00462 C 00463 IF (INC.EQ.1) 00464 C THEN 00465 C 00466 C 00467 C*** 00468 C* LENGTH OF GRID DESCRIPTION BLOCK. 00469 C*** 00470 C 00471 CALL GBYTE_MF (KGRIB(KWORD),ILLBLK,IOFF,24) 00472 ILBLK=ILLBLK 00473 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00474 IF (KERR.NE.0) THEN 00475 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00476 RETURN 00477 ENDIF 00478 C 00479 C 00480 C 00481 C*** 00482 C* NUMBER OF UNUSED BITS AT END OF BLOCK. 00483 C*** 00484 C 00485 CALL GBYTE_MF (KGRIB(KWORD),ILLNIL,IOFF,8) 00486 ILNIL=ILLNIL 00487 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00488 IF (KERR.NE.0) THEN 00489 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00490 RETURN 00491 ENDIF 00492 C 00493 C 00494 C 00495 C 00496 C*** 00497 C* NEXT OCTET IS RESERVED. 00498 C*** 00499 C 00500 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00501 IF (KERR.NE.0) THEN 00502 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00503 RETURN 00504 ENDIF 00505 C 00506 C 00507 C 00508 C 00509 C 00510 C 00511 C 00512 C*** 00513 C* DATA REPRESENTATION TYPE. 00514 C*** 00515 C 00516 CALL GBYTE_MF (KGRIB(KWORD),ILB2PAR(1),IOFF,8) 00517 KB2PAR=ILB2PAR 00518 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00519 IF (KERR.NE.0) THEN 00520 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00521 RETURN 00522 ENDIF 00523 C 00524 C LAT/LONGITUDE GRID, GAUSSIAN GRID AND SPHERICAL HARMONICS 00525 C ARE THE ONLY DATA REPRESENTATIONS HANDLED. 00526 C 00527 IF (KB2PAR(1).NE.0.AND.KB2PAR(1).NE.4.AND.KB2PAR(1).NE.50 00528 C .AND.KB2PAR(1).NE.80) 00529 C THEN 00530 WRITE (*,*)'GRID DESCRIPTION BLOCK NOT YET DEFINED' 00531 KERR = -4 00532 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00533 RETURN 00534 ENDIF 00535 C 00536 C 00537 C 00538 C 00539 C*** 00540 C* LAT/LONG OR GAUSSIAN GRID. 00541 C*** 00542 C 00543 IF (KB2PAR(1).EQ.0.OR.KB2PAR(1).EQ.4) 00544 C THEN 00545 C 00546 C NUMBER OF LAT/LONG POINTS. 00547 C 00548 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(2),IOFF,16,0,2, 00549 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00550 KB2PAR=ILB2PAR 00551 IF (KERR.NE.0) THEN 00552 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00553 RETURN 00554 ENDIF 00555 C 00556 C LAT/LONG OF ORIGIN. 00557 C 00558 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 00559 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00560 ILAT=ILLAT 00561 IF (KERR.NE.0) THEN 00562 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00563 RETURN 00564 ENDIF 00565 C 00566 C IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE. 00567 C 00568 DO 200 J=1,2 00569 C 00570 IF (ILAT(J).LE.2**23) THEN 00571 KB2PAR(J+3) = ILAT(J) 00572 ELSE 00573 KB2PAR(J+3) = 2**23 - ILAT(J) 00574 ENDIF 00575 C 00576 200 CONTINUE 00577 C 00578 C 00579 C RESOLUTION FLAG. 00580 C 00581 CALL GBYTE_MF (KGRIB(KWORD),ILB2PAR(6),IOFF,8) 00582 KB2PAR=ILB2PAR 00583 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00584 IF (KERR.NE.0) THEN 00585 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00586 RETURN 00587 ENDIF 00588 C 00589 C 00590 C LAT/LONG OF EXTREME POINTS. 00591 C 00592 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 00593 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00594 ILAT=ILLAT 00595 IF (KERR.NE.0) THEN 00596 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00597 RETURN 00598 ENDIF 00599 C 00600 C IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE. 00601 C 00602 DO 300 J=1,2 00603 C 00604 IF (ILAT(J).LE.2**23) THEN 00605 KB2PAR(J+6) = ILAT(J) 00606 ELSE 00607 KB2PAR(J+6) = 2**23 - ILAT(J) 00608 ENDIF 00609 C 00610 300 CONTINUE 00611 C 00612 C DIRECTION INCREMENTS / NUMBER OF LATITUDE LINES. 00613 C 00614 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(9),IOFF,16,0,2, 00615 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00616 KB2PAR=ILB2PAR 00617 IF (KERR.NE.0) THEN 00618 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00619 RETURN 00620 ENDIF 00621 C 00622 C SCANNING MODE FLAGS. 00623 C 00624 CALL GBYTE_MF (KGRIB(KWORD),ILB2PAR(11),IOFF,8) 00625 KB2PAR=ILB2PAR 00626 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00627 IF (KERR.NE.0) THEN 00628 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00629 RETURN 00630 ENDIF 00631 C 00632 C 4 RESERVED OCTETS. 00633 C 00634 CALL OFFSET_MF (IOFF,4,KWORD,8,KNBIT,KLENG,KERR) 00635 IF (KERR.NE.0) THEN 00636 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00637 RETURN 00638 ENDIF 00639 C 00640 ENDIF 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 00655 C*** 00656 C* SPHERICAL HARMONIC DATA. 00657 C*** 00658 C 00659 IF (KB2PAR(1).EQ.50.OR.KB2PAR(1).EQ.80) 00660 C THEN 00661 C 00662 C PENTAGONAL RESOLUTION PARAMETERS. 00663 C 00664 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(2),IOFF,16,0, 00665 S 3,KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00666 KB2PAR=ILB2PAR 00667 IF (KERR.NE.0) THEN 00668 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00669 RETURN 00670 ENDIF 00671 C 00672 C REPRESENTATION TYPE AND MODE. 00673 C 00674 CALL GSBYTE_MF (KGRIB(KWORD),ILB2PAR(5),IOFF,8,0,2, 00675 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00676 KB2PAR=ILB2PAR 00677 IF (KERR.NE.0) THEN 00678 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00679 RETURN 00680 ENDIF 00681 C 00682 C 18 RESERVED OCTETS. 00683 C 00684 CALL OFFSET_MF (IOFF,18,KWORD,8,KNBIT,KLENG,KERR) 00685 IF (KERR.NE.0) THEN 00686 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00687 RETURN 00688 ENDIF 00689 C 00690 ENDIF 00691 C 00692 C** 00693 C* STRETCHED AND ROTATED SHPERICAL HARMONICS. 00694 C** 00695 IF(KB2PAR(1).EQ.80) THEN 00696 C 00697 C* SOUTHERN POLE OF ROTATED GRID 00698 C 00699 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 00700 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00701 ILAT=ILLAT 00702 IF (KERR.NE.0) THEN 00703 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00704 RETURN 00705 ENDIF 00706 C 00707 C IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE. 00708 C 00709 DO 410 J=1,2 00710 C 00711 IF (ILAT(J).LE.2**23) THEN 00712 KB2PAR(J+11) = ILAT(J) 00713 ELSE 00714 KB2PAR(J+11) = 2**23 - ILAT(J) 00715 ENDIF 00716 C 00717 410 CONTINUE 00718 C 00719 C* ANGLE OF ROTATION 00720 C 00721 CALL GBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 00722 IEXP=ILEXP 00723 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00724 IF (KERR.NE.0) THEN 00725 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00726 RETURN 00727 ENDIF 00728 CALL GBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 00729 IMANT=ILMANT 00730 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00731 IF (KERR.NE.0) THEN 00732 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00733 RETURN 00734 ENDIF 00735 C 00736 CALL DECFP_MF (KB2PAR(14),IEXP,IMANT) 00737 C 00738 C* POLE OF STRETCHING 00739 C 00740 CALL GSBYTE_MF (KGRIB(KWORD),ILLAT(1),IOFF,24,0,2, 00741 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 00742 ILAT=ILLAT 00743 IF (KERR.NE.0) THEN 00744 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00745 RETURN 00746 ENDIF 00747 C 00748 C IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE. 00749 C 00750 DO 420 J=1,2 00751 C 00752 IF (ILAT(J).LE.2**23) THEN 00753 KB2PAR(J+14) = ILAT(J) 00754 ELSE 00755 KB2PAR(J+14) = 2**23 - ILAT(J) 00756 ENDIF 00757 C 00758 420 CONTINUE 00759 C 00760 C* STRETCHING FACTOR 00761 C 00762 CALL GBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 00763 IEXP=ILEXP 00764 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00765 IF (KERR.NE.0) THEN 00766 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00767 RETURN 00768 ENDIF 00769 CALL GBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 00770 IMANT=ILMANT 00771 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00772 IF (KERR.NE.0) THEN 00773 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00774 RETURN 00775 ENDIF 00776 C 00777 CALL DECFP_MF (KB2PAR(17),IEXP,IMANT) 00778 C 00779 ENDIF 00780 C 00781 C 00782 C 00783 C LENGTH IS 32 OCTETS FOR LAT/LONG, GAUSSIAN AND SPHERICAL 00784 C HARMONICS, 52 OCTETS FOR STRETCHED AND ROTATED SPHERICAL 00785 C HARMONICS.FOR ANY DATA ON HYBRID LEVELS THE 00786 C VERTICAL COORDINATES ARE ADDED. 00787 C GET NUMBER OF VERTICAL COORDINATE PARAMETERS, IF ANY. 00788 C 00789 IF(KB2PAR(1).EQ.80) THEN 00790 ILEN=52 00791 ELSE 00792 ILEN=32 00793 ENDIF 00794 C 00795 KJLENV = (ILBLK - ILEN) / 4 00796 C 00797 IF(KLENV.LT.KJLENV) THEN 00798 KERR = -3 00799 WRITE (*,9001) KJLENV,KLENV 00800 9001 FORMAT (1H ,'NUMBER OF VERTICAL COORDINATES - ',I4, 00801 C ', ARRAY SIZE IS - ',I4) 00802 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00803 RETURN 00804 ENDIF 00805 C 00806 C 00807 C 00808 C*** 00809 C* VERTICAL COORDINATE PARAMETERS FOR HYBRID LEVELS. 00810 C*** 00811 C 00812 IF (KJLENV.NE.0) THEN 00813 C 00814 DO 400 J=1,KJLENV 00815 CALL GBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 00816 IEXP=ILEXP 00817 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 00818 IF (KERR.NE.0) THEN 00819 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00820 RETURN 00821 ENDIF 00822 CALL GBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 00823 IMANT=ILMANT 00824 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00825 IF (KERR.NE.0) THEN 00826 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00827 RETURN 00828 ENDIF 00829 CALL DECFP_MF (PVERT(J),IEXP,IMANT) 00830 400 CONTINUE 00831 C 00832 ENDIF 00833 C 00834 ENDIF 00835 C 00836 C 00837 C 00838 C RETURN IF ONLY PRODUCT AND GRID DEFINITION BLOCKS REQUIRED. 00839 C 00840 IF (KLENF.EQ.1) THEN 00841 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00842 RETURN 00843 ENDIF 00844 C 00845 C 00846 C 00847 C 00848 C 00849 C 00850 C 00851 C 00852 C******************************************************************** 00853 C* 00854 C* BLOCK 3 - BIT MAP BLOCK. 00855 C* 00856 C******************************************************************** 00857 C 00858 C INC IS SET TO 1 , IF BLOCK 3 IS INCLUDED. 00859 C 00860 INC = 0 00861 C 00862 C 00863 IF (ISNEW.EQ.0) 00864 C THEN 00865 C OLD VERSION OF CODE 00866 C 00867 C BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE 00868 C 00869 C NONE 00000000 0 00870 C 2 00000001 1 00871 C 3 00000010 2 00872 C 2 AND 3 00000011 3 00873 C 00874 IF (KB1PAR(4).EQ.2.OR.KB1PAR(4).EQ.3) INC = 1 00875 ELSE 00876 C NEW VERSION 00877 C 00878 C BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE 00879 C 00880 C NONE 00000000 0 00881 C 2 10000000 128 00882 C 3 01000000 64 00883 C 2 AND 3 11000000 192 00884 C 00885 IF (KB1PAR(4).EQ.64.OR.KB1PAR(4).EQ.192) INC = 1 00886 ENDIF 00887 C 00888 IF (INC.EQ.1) 00889 C THEN 00890 WRITE (*,*)'BIT MAP BLOCK NOT YET DEFINED' 00891 KERR = -4 00892 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00893 RETURN 00894 ENDIF 00895 C 00896 C 00897 C 00898 C 00899 C********************************************************************** 00900 C* 00901 C* CONVERT VALUES IN BLOCKS 1 AND 2 TO NEW CODE VALUES. 00902 C* 00903 C********************************************************************** 00904 C 00905 C 00906 IF (ISNEW.EQ.0) 00907 C THEN 00908 C 00909 C CHANGE CODE FOR FLAG INDICATING INCLUSION OR OMISSION 00910 C OF BLOCKS 2 AND 3. 00911 C 00912 C BINARY VALUE OLD CODE = 00000001 00913 C BINARY VALUE NEW CODE = 10000000 (128 DECIMAL) 00914 C 00915 IF (KB1PAR(4).EQ.1) 00916 C THEN 00917 KB1PAR(4) = 128 00918 ELSE 00919 WRITE (*,*) 'DECOGA : BLOCK FLAG ERROR.' 00920 KERR = 2 00921 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00922 RETURN 00923 ENDIF 00924 C 00925 C CHANGE CODE FOR TIME UNIT. 00926 C 00927 IF (KB1PAR(14).EQ.40) 00928 C THEN 00929 KB1PAR(14) = 1 00930 ELSE 00931 WRITE (*,*) 'DECOGA : TIME UNIT ERROR.' 00932 KERR = 2 00933 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00934 RETURN 00935 ENDIF 00936 C 00937 C CONVERT FLAGS FOR LAT/LONG AND GAUSSIAN GRID DATA. 00938 C 00939 IF (KB2PAR(1).EQ.0.OR.KB2PAR(1).EQ.4) 00940 C THEN 00941 C 00942 C CONVERT SCANNING MODE FLAG. 00943 C 00944 IF (KB2PAR(11).EQ.1) 00945 C THEN 00946 KB2PAR(11) = 0 00947 ELSE 00948 WRITE (*,*) 'DECOGA : SCAN MODE FLAG ERROR.' 00949 KERR = 2 00950 IF (LHOOK) 00951 C CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00952 RETURN 00953 ENDIF 00954 C 00955 C CONVERT RESOLUTION FLAG. 00956 C 00957 IF (KB2PAR(6).EQ.3) 00958 C THEN 00959 KB2PAR(6) = 128 00960 ELSE 00961 WRITE (*,*) 'DECOGA : RESOLUTION FLAG ERROR.' 00962 KERR = 2 00963 IF (LHOOK) 00964 C CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00965 RETURN 00966 ENDIF 00967 ENDIF 00968 ENDIF 00969 C 00970 C 00971 C 00972 C 00973 C 00974 C 00975 C******************************************************************** 00976 C* 00977 C* BLOCK 4 - BINARY DATA BLOCK. 00978 C* 00979 C******************************************************************** 00980 C 00981 C 00982 C 00983 C*** 00984 C* GET LENGTH OF BINARY DATA BLOCK. 00985 C*** 00986 C 00987 C 00988 IPW = KWORD 00989 IPB = IOFF 00990 C 00991 CALL GBYTE_MF (KGRIB(KWORD),ILLBIN,IOFF,24) 00992 ILBIN=ILLBIN 00993 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 00994 IF (KERR.NE.0) THEN 00995 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 00996 RETURN 00997 ENDIF 00998 C 00999 C 01000 C 01001 C 01002 C*** 01003 C* 4 BIT FLAG / 4 BIT COUNT OF UNUSED BITS AT END OF BLOCK OCTET. 01004 C*** 01005 C 01006 CALL GBYTE_MF (KGRIB(KWORD),ILFLAG,IOFF,8) 01007 IFLAG=ILFLAG 01008 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01009 IF (KERR.NE.0) THEN 01010 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01011 RETURN 01012 ENDIF 01013 C 01014 IF (ISNEW.EQ.0) 01015 C THEN 01016 C OLD VERSION OF CODE 01017 C 01018 C 0000---- GRID POINT 01019 C 0001---- SPHERICAL HARMONICS 01020 C 01021 IREP = IFLAG / 16 01022 ILNIL = IFLAG - IREP * 16 01023 C 01024 ELSE 01025 C NEW VERSION OF CODE 01026 C 01027 C 0000---- GRID POINT 01028 C 1000---- SPHERICAL HARMONICS 01029 C 1100---- -''- COMPLEX PACKING 01030 C 01031 IREP = IFLAG / 128 01032 ILNIL = MOD(IFLAG,16) 01033 C 01034 ENDIF 01035 C 01036 C 01037 C 01038 C 01039 C 01040 C 01041 C 01042 C 01043 C*** 01044 C* GET SCALE FACTOR 01045 C*** 01046 C 01047 CALL GBYTE_MF (KGRIB(KWORD),ILSCALX,IOFF,16) 01048 ISCALX=ILSCALX 01049 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01050 IF (KERR.NE.0) THEN 01051 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01052 RETURN 01053 ENDIF 01054 C 01055 IF (ISCALX.LE.2**15) THEN 01056 ISCALE = ISCALX 01057 ELSE 01058 ISCALE = 2**15 - ISCALX 01059 ENDIF 01060 C 01061 C 01062 C 01063 C 01064 C*** 01065 C* GET REFERENCE VALUE (PMIN) IN GRIB FORMAT (IEXP,IMANT) 01066 C*** 01067 C 01068 C 01069 CALL GBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01070 IEXP=ILEXP 01071 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01072 IF (KERR.NE.0) THEN 01073 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01074 RETURN 01075 ENDIF 01076 CALL GBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01077 IMANT=ILMANT 01078 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01079 IF (KERR.NE.0) THEN 01080 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01081 RETURN 01082 ENDIF 01083 C 01084 C 01085 C CHECK FOR MISSING DATA INDICATORS. 01086 C 01087 IMISS = 0 01088 IF (ISCALX.EQ.65535.AND.IEXP.EQ.255.AND.IMANT.EQ.16777215) 01089 C IMISS = 1 01090 C 01091 C 01092 C 01093 C*** 01094 C* GET NUMBER OF BITS IN EACH DATA VALUE. 01095 C*** 01096 C 01097 CALL GBYTE_MF (KGRIB(KWORD),ILBITS,IOFF,8) 01098 KBITS=ILBITS 01099 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01100 IF (KERR.NE.0) THEN 01101 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01102 RETURN 01103 ENDIF 01104 C 01105 C 01106 C CHECK NUMBER OF BITS PER DATA FIELD. 01107 C 01108 IF (KBITS.GT.KNBIT.OR.KBITS.GT.IMAX) 01109 C THEN 01110 KERR = -1 01111 WRITE (*,9002) KBITS,KNBIT,IMAX 01112 9002 FORMAT (1H ,'NUMBER OF BITS PER DATA VALUE, ',I3, 01113 C 'EXCEEDS WORD LENGTH, ',I3,' OR MAXIMUM ', 01114 C ' PERMITTED VALUE, ',I3) 01115 CALL SDL_SRLABORT 01116 C 01117 ELSEIF (LDARPE) THEN 01118 C 01119 C Minimum value given as input argument... it has not been decoded 01120 C before as stored in GRIB field (should be zero). 01121 C But the scale factor may be computed, now. 01122 C 01123 ZSCALE= ( PMAX - PMIN ) / FLOAT ( 2**KBITS-1 ) 01124 C 01125 ELSEIF (IMISS.EQ.0) THEN 01126 C 01127 C 01128 C CONVERT REFERENCE VALUE AND SCALE FACTOR. 01129 C 01130 C 01131 CALL DECFP_MF (PMIN,IEXP,IMANT) 01132 ZSCALE = 2.**ISCALE 01133 PMAX=PMIN+FLOAT (2**(KBITS+1)-3) * 2.** (ISCALE-1) 01134 C 01135 ENDIF 01136 C 01137 C** 01138 C* IF COMPLEX PACKING GET ADDITIONAL PARAMETERS 01139 C** 01140 IF(IFLAG.GE.192) THEN 01141 C 01142 C GET START OCTET OF PACKED DATA 01143 C 01144 CALL GBYTE_MF (KGRIB(KWORD),ILSPDA,IOFF,16) 01145 ISPDA=ILSPDA 01146 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01147 IF (KERR.NE.0) THEN 01148 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01149 RETURN 01150 ENDIF 01151 IPREMC=1+(8*ISPDA-1)/KNBIT 01152 C 01153 IF (IPREMC.GT.KLENF) THEN 01154 KERR=-3 01155 WRITE (*,9004) KLENF,ISPDA 01156 9004 FORMAT (' OUTPUT ARRAY LENGTH (',I7, 01157 S ' WORDS) TOO SHORT, START OCTET OF PACKED DATA =', 01158 S I9) 01159 CALL SDL_SRLABORT 01160 ENDIF 01161 C 01162 C GET LAPLACIAN SCALING FACTOR 01163 C 01164 CALL GBYTE_MF (KGRIB(KWORD),ILSCALP,IOFF,16) 01165 KSCALP=ILSCALP 01166 CALL OFFSET_MF (IOFF,1,KWORD,16,KNBIT,KLENG,KERR) 01167 C 01168 IF (KERR.NE.0) THEN 01169 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01170 RETURN 01171 ELSEIF (KSCALP.GT.2**15) THEN 01172 KSCALP=2**15-KSCALP 01173 ENDIF 01174 C 01175 C GET TRUNCATION OF UNPACKED COEFFS. 01176 C 01177 DO 430 J=1,3 01178 CALL GBYTE_MF (KGRIB(KWORD),ILCPACK,IOFF,8) 01179 KCPACK=ILCPACK 01180 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01181 IF (KERR.NE.0) THEN 01182 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01183 RETURN 01184 ENDIF 01185 430 CONTINUE 01186 C 01187 C COMPUTE NUMBER OF UNPACKED DATA ITEMS 01188 C 01189 IREP=(KCPACK+1)**2 01190 ENDIF 01191 C 01192 C*** 01193 C* IF DATA IS IN SPHERICAL HARMONIC FORM, NEXT OCTETS 01194 C* CONTAIN UNPACKED COEFFICIENT(S). 01195 C*** 01196 C 01197 IF (IREP.NE.0) 01198 C THEN 01199 C 01200 C EVENTUALLY, 01201 C GET UNPACKED COEFFICIENTS IN GRIB FORMAT AND 01202 C CONVERT TO FLOATING POINT. 01203 C 01204 IF (IMISS.EQ.1) THEN 01205 C 01206 DO 440 J=1,IREP 01207 PFDATA(J)=0. 01208 440 CONTINUE 01209 C 01210 ELSEIF (LDARPE) THEN 01211 C 01212 C The "unpacked" values should then contain zeroes, 01213 C and are skipped: the corresponding values of PFDATA array 01214 C are then not provided. A positioning in KGRIB is made. 01215 C 01216 CALL OFFSET_MF (IOFF,IREP,KWORD,32,KNBIT,KLENG,KERR) 01217 IF (KERR.NE.0) THEN 01218 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01219 RETURN 01220 ENDIF 01221 C 01222 ELSE 01223 C 01224 DO 450 J=1,IREP 01225 CALL GBYTE_MF (KGRIB(KWORD),ILEXP,IOFF,8) 01226 IEXP=ILEXP 01227 CALL OFFSET_MF (IOFF,1,KWORD,8,KNBIT,KLENG,KERR) 01228 IF (KERR.NE.0) THEN 01229 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01230 RETURN 01231 ENDIF 01232 CALL GBYTE_MF (KGRIB(KWORD),ILMANT,IOFF,24) 01233 IMANT=ILMANT 01234 CALL OFFSET_MF (IOFF,1,KWORD,24,KNBIT,KLENG,KERR) 01235 IF (KERR.NE.0) THEN 01236 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01237 RETURN 01238 ENDIF 01239 CALL DECFP_MF (PFDATA(J),IEXP,IMANT) 01240 450 CONTINUE 01241 C 01242 ENDIF 01243 C 01244 IF (IFLAG.GE.192) THEN 01245 C 01246 C Proper positioning on start octet of packed data, because 01247 C it may be not the first octet following the "unpacked" data. 01248 C 01249 ISSUIV=19+IREP*4 01250 C 01251 IF (ISSUIV.LT.ISPDA) THEN 01252 CALL OFFSET_MF (IOFF,ISPDA-ISSUIV,KWORD,8,KNBIT,KLENG,KERR) 01253 IF (KERR.NE.0) THEN 01254 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01255 RETURN 01256 ENDIF 01257 ENDIF 01258 C 01259 ENDIF 01260 C 01261 ENDIF 01262 C 01263 C 01264 C 01265 C 01266 C***** 01267 C* DECODE DATA VALUES TO FLOATING POINT AND STORE IN PFDATA. 01268 C***** 01269 C 01270 C FIRST CALCULATE THE NUMBER OF DATA VALUES. 01271 C 01272 KJLENF = ILBIN - 11 - IREP * 4 01273 IF(IFLAG.GE.192) KJLENF=KJLENF-7-(ISPDA-ISSUIV) 01274 KJLENF = (KJLENF * 8 - ILNIL) / KBITS 01275 C 01276 C CHECK LENGTH OF OUTPUT ARRAY. 01277 C 01278 IF (KJLENF+IREP.GT.KLENF) 01279 C THEN 01280 KERR = -3 01281 WRITE (*,9003) KJLENF,KLENF 01282 9003 FORMAT (1H ,'NUMBER OF VALUES TO BE DECODED IS - ',I7, 01283 C ', ARRAY SIZE - ',I7) 01284 CALL SDL_SRLABORT 01285 ENDIF 01286 C 01287 IF (IMISS.EQ.0.AND.ZSCALE.GT.0.) THEN 01288 CALL GSBYTE_MF (KGRIB(KWORD),PFDATA(IREP+1),IOFF,KBITS,0,KJLENF, 01289 S KNBIT,'D',KLENG,KERR,KWORD,.TRUE.) 01290 IF (KERR.NE.0) THEN 01291 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01292 RETURN 01293 ENDIF 01294 CALL UNPAGB (PFDATA(IREP+1),PFDATA(IREP+1),PMIN,PMAX,KBITS, 01295 S ZSCALE,KJLENF,LDARPE) 01296 ELSE 01297 C 01298 IF (ZSCALE.LE.0.) THEN 01299 C 01300 DO 460 J= IREP+1,IREP+KJLENF 01301 PFDATA(J) = PMIN 01302 460 CONTINUE 01303 C 01304 ELSE 01305 C 01306 DO 470 J= IREP+1,IREP+KJLENF 01307 PFDATA(J) = 0. 01308 470 CONTINUE 01309 C 01310 ENDIF 01311 C 01312 CALL OFFSET_MF (IOFF,KJLENF,KWORD,KBITS,KNBIT,KLENG,KERR) 01313 IF (KERR.NE.0) THEN 01314 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01315 RETURN 01316 ENDIF 01317 ENDIF 01318 C 01319 C 01320 C INCLUDE UNPACKED COEFFICIENT IN COUNT, IF SPHERICAL HARMONIC DATA. 01321 C 01322 KJLENF = IREP + KJLENF 01323 C 01324 C 01325 C 01326 C 01327 C*** 01328 C* SKIP ANY ZERO FILL AT END OF DATA BLOCK. 01329 C*** 01330 C 01331 IL = (KWORD-IPW) * KNBIT + IOFF -IPB 01332 IL = ILBIN * 8 - IL 01333 C 01334 IF (IL.NE.0) THEN 01335 CALL OFFSET_MF (IOFF,1,KWORD,IL,KNBIT,KLENG,KERR) 01336 IF (KERR.NE.0) THEN 01337 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01338 RETURN 01339 ENDIF 01340 ENDIF 01341 C 01342 C 01343 C 01344 C 01345 C******************************************************************** 01346 C* 01347 C* BLOCK 5 - END BLOCK. 01348 C* 01349 C******************************************************************** 01350 C 01351 C CHECK 7 7 7 7 AT END OF CODED DATA. 01352 C 01353 C 01354 INVAL=4 01355 ILBVAL=8 01356 CALL GSBYTE_MF (KGRIB(KWORD),ILBLOCK(1),IOFF,ILBVAL,0,INVAL, 01357 S KNBIT,'D',KLENG,KERR,KWORD,.FALSE.) 01358 IBLOCK=ILBLOCK 01359 IF (KERR.NE.0) THEN 01360 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01361 RETURN 01362 ENDIF 01363 C 01364 C 55 IS THE VALUE OF ASCII CHARACTER '7' 01365 C 01366 DO 600 J=1,INVAL 01367 IF (IBLOCK(J).NE.55) KERR = 1 01368 600 CONTINUE 01369 C 01370 IF (KERR.EQ.1) WRITE (*,*) ' NO 7777 GROUP FOUND ' 01371 C 01372 C 01373 C 01374 C SET NUMBER OF VALUES NEGATIVE, IF MISSING DATA VALUES. 01375 C 01376 IF (IMISS.EQ.1) KJLENF = - KJLENF 01377 C 01378 IF (LHOOK) CALL DR_HOOK('DECOGA',1,ZHOOK_HANDLE) 01379 END
1.8.0
