SURFEX v8.1
General documentation of Surfex
decoga.F
Go to the documentation of this file.
1  SUBROUTINE decoga (PFDATA,KLENF,KBITS,KNBIT,KB1PAR, &
2  & KB2PAR,PVERT,KLENV,KGRIB,KLENG,KWORD, &
3  & KJLENV,KJLENF,KCPACK,KSCALP,KERR, &
4  & PMIN,PMAX,LDARPE)
5  USE parkind1, ONLY : jprb
6  USE yomhook , ONLY : lhook, dr_hook
7  USE lfi_precision
8 
9 !
10 !
11 !
12 !
13 !
14 !
15 !********************************************************************
16 !*
17 !* NAME : DECOGA
18 !*
19 !* FUNCTION : DECODE WMO GRIB CODED DATA.
20 !*
21 !* INPUT : KNBIT - NUMBER OF BITS IN COMPUTER WORD
22 !*
23 !* KGRIB - INTEGER ARRAY CONTAINING DATA IN GRIB CODE.
24 !* KLENG - LENGTH OF ARRAY KGRIB.
25 !*
26 !* PVERT - REAL ARRAY TO RECEIVE VERTICAL COORDINATE
27 !* PARAMETERS.
28 !* KLENV - LENGTH OF ARRAY PVERT.
29 !*
30 !* PFDATA - REAL ARRAY TO RECEIVE DECODED DATA VALUES.
31 !* KLENF - LENGTH OF ARRAY PFDATA.
32 !*
33 !* ***** IF THIS IS 1 ONLY
34 !* THE PRODUCT AND GRID DEFINITION BLOCKS
35 !* ARE DECODED. *****
36 !*
37 !* KB1PAR - INTEGER ARRAY (DIMENSION 19) TO RECEIVE
38 !* PRODUCT DEFINITION INFORMATION.
39 !*
40 !* KB2PAR - INTEGER ARRAY (DIMENSION 11) TO RECEIVE GRID
41 !* DEFINITION INFORMATION.
42 !*
43 !* PMIN - MINIMUM VALUE OF THE FIELD DATA.
44 !*
45 !* PMAX - MAXIMUM VALUE OF THE FIELD DATA.
46 !*
47 !* ***** These 2 last values have only to be supplied
48 !* if next argument is .TRUE. . *****
49 !*
50 !* LDARPE - .TRUE., modifications for ARPEGE coding
51 !* have been included when coding data;
52 !* .FALSE., no such modifications.
53 !*
54 !* OUTPUT : PARAMETERS FROM BLOCK 1 , PRODUCT DEFINITION BLOCK.
55 !* --------------------------------------------------
56 !* KB1PAR - INTEGER ARRAY (DIMENSION 19) OF PRODUCT
57 !* DEFINITION INFORMATION.
58 !*
59 !* WORD CONTENTS
60 !* ---- --------
61 !* 1 ORIGINATING CENTRE IDENTIFIER.
62 !* 2 MODEL IDENTIFICATION.
63 !* 3 GRID DEFINITION.
64 !* 4 FLAG ( CODE TABLE 1)
65 !* 5 PARAMETER IDENTIFIER ( CODE TABLE 2 ).
66 !* 6 TYPE OF LEVEL (CODE TABLE 3).
67 !* 7-8 VALUE(S) OF LEVELS (CODE TABLE 3).
68 !* 9 YEAR OF DATA
69 !* 10 MONTH OF DATA
70 !* 11 DAY OF DATA
71 !* 12 HOUR OF DATA
72 !* 13 MINUTE OF DATA
73 !* 14 TIME UNIT (CODE TABLE 4).
74 !* 15 TIME RANGE ONE
75 !* 16 TIME RANGE TWO
76 !* 17 TIME RANGE FLAG (CODE TABLE 5).
77 !* 18 NUMBER AVERAGED OR ACCUMULATED.
78 !* 19 NUMBER MISSING FROM AVERAGES/ACCUMULATIONS.
79 !*
80 !* VALUE(S) OF LEVEL CAN OCCUPY 2 WORDS..
81 !* FOR A LAYER THE FIRST WORD DEFINES THE TOP
82 !* AND THE SECOND THE BOTTOM OF THE LAYER.
83 !* FOR A SINGLE LEVEL, ONLY THE FIRST WORD IS
84 !* USED.
85 !*
86 !* PARAMETERS FROM BLOCK 2 , GRID DEFINITION BLOCK.
87 !* -----------------------------------------------
88 !* KB2PAR - INTEGER ARRAY (DIMENSION 17) CONTAINING GRID
89 !* DEFINITION INFORMATION.
90 !* USE VARIES WITH DATA REPRESENTATION TYPE.
91 !*
92 !* WORD LAT/LONG GRID
93 !* ---- -------------
94 !* 1 DATA REPRESENTATION TYPE (CODE TABLE 6).
95 !* 2 NO. OF POINTS ALONG A LATITUDE
96 !* 3 NO. OF POINTS ALONG A MERIDIAN.
97 !* 4 LATITUDE OF ORIGIN (SOUTH - IVE).
98 !* 5 LONGITUDE OF ORIGIN (WEST - IVE).
99 !* 6 RESOLUTION FLAG. (CODE TABLE 7)
100 !* 7 LATITUDE OF EXTREME POINT (SOUTH - IVE).
101 !* 8 LONGITUDE OF EXTREME POINT (WEST - IVE).
102 !* 9 LATITUDE INCREMENT
103 !* 10 LONGITUDE INCREMENT
104 !* 11 SCANNING MODE FLAGS (CODE TABLE 8)
105 !*
106 !* WORD GAUSSIAN GRID
107 !* ---- -------------
108 !* 1-9 AS FOR LAT/LONGITUDE GRID.
109 !* 10 THE NUMBER OF LATITUDE LINES BETWEEN A POLE
110 !* AND THE EQUATOR.
111 !* 11 SCANNING MODE FLAGS (CODE TABLE 8)
112 !*
113 !* WORD SPHERICAL HARMONICS
114 !* ---- -------------------
115 !* 1 DATA REPRESENTATION TYPE (CODE TABLE 6)
116 !* 2 J - PENTAGONAL RESOLUTION PARAMETER
117 !* 3 K - PENTAGONAL RESOLUTION PARAMETER
118 !* 4 M - PENTAGONAL RESOLUTION PARAMETER
119 !* 5 REPRESENTATION TYPE (CODE TABLE 9)
120 !* 6 REPRESENTATION MODE (CODE TABLE 10)
121 !* 7-11 NOT USED
122 !*
123 !*
124 !* USE FOR OTHER DATA REPRESENTATION TYPES IS
125 !*
126 !* PVERT - REAL ARRAY OF VERTICAL COORDINATE PARAMETERS
127 !* KJLENV - NUMBER OF VALUES IN THIS ARRAY.
128 !*
129 !* USED FOR HYBRID LEVELS ONLY.
130 !*
131 !* PARAMETERS FROM BLOCK 3 , BIT-MAP DEFINITION BLOCK.
132 !* --------------------------------------------------
133 !*
134 !* TO BE DEFINED LATER.
135 !*
136 !* PARAMETERS FROM BLOCK 4 , BINARY DATA BLOCK.
137 !* -------------------------------------------
138 !* PFDATA - ARRAY OF FLOATING POINT VALUES.
139 !* KJLENF - NUMBER OF VALUES IN THIS ARRAY.
140 !* KJLENF IS NEGATIVE IF MISSING DATA CODED
141 !*
142 !* KBITS - NUMBER OF BITS FOR CODED DATA VALUES.
143 !*
144 !* KWORD - NUMBER OF WORDS DECODED.
145 !*
146 !* KCPACK - KCPACK GREATER THAN ZERO INDICATES COMPLEX
147 !* PACKING, WITH A *TRIANGULAR* SUB-TRUNCATION
148 !* "UNPACKED" OF ORDER KCPACK.
149 !
150 !* KSCALP - FOR COMPLEX PACKING OF SPECTRAL COEFFICIENTS
151 !* ONLY, LAPLACIAN SCALING FACTOR.
152 !*
153 !* ***** THE 2 NEXT VALUES ARE SUPPLIED BY THE ROUTINE
154 !* ONLY IF ARGUMENT "LDARPE" IS .FALSE. . *****
155 !*
156 !* PMIN - MINIMUM VALUE OF THE FIELD DATA, OR A SLIGHT
157 !* UNDER-APPROXIMATION OF THE "TRUE" MINIMUM OF
158 !* DECODED FIELD DATA.
159 !*
160 !* PMAX - OVER-ESTIMATION OF THE MAXIMUM VALUE OF THE
161 !* FIELD DATA (COMPUTED WITH PMIN, THE SCALE
162 !* FACTOR "ISCALE" OF GRIB, AND KBITS).
163 !*
164 !*
165 !* KERR - ERROR INDICATOR.
166 !*
167 !* 0, NO ERROR.
168 !*
169 !* -1, NUMBER OF BITS PER DATA VALUE EXCEEDS
170 !* WORD LENGTH, OR MAXIMUM ALLOWED.
171 !* -2, INPUT ARRAY HOLDS FEWER CODED VALUES
172 !* THAN EXPECTED.
173 !* -3, OUTPUT ARRAY TOO SMALL TO HOLD DECODED
174 !* DATA VALUES.
175 !* -4, CURRENTLY UNDEFINED OPTION SELECTED.
176 !*
177 !* 1, NO BLOCK 5 FOUND.
178 ! 2, ERROR IN CONVERTING OLD TO NEW FORM OF
179 ! BLOCK 1 OR 2.
180 !* 3, NO BLOCK 0 FOUND.
181 !*
182 !* GENERAL : DECOGA CALLS GBYTE
183 !* GSBYTE
184 !* OFFSET
185 !* DECFP
186 !*
187 !*
188 !* MODIFIED : J. HENNESSY 17.06.87
189 !* CONVERT OLD FORMAT BLOCK 1 AND 2 TO NEW FORMAT.
190 !* ( DISTINCTION BETWEEN ANALYSIS AND INITIALISED
191 !* NOT POSSIBLE ).
192 !*
193 !* Modifications by Mats HAMRUD, ECMWF, to handle complex unpacking
194 !* of spectral harmonics data, 1988.
195 !*
196 !* Modifications by Jean CLOCHARD, French DMN, February 1990:
197 !*
198 !* - to remove automatic arrays introduced by the last modification;
199 !* - to comply with the "DOCTOR" norm;
200 !* - to allow modifications of the unpacking for ARPEGE files use,
201 !* in an optional way.
202 !*
203 !********************************************************************
204 !
205 !
206 !
207 !
208 !
209 !
210 !
211 !
212 !
213 
214  USE sdl_mod , ONLY : sdl_srlabort
215 
216  IMPLICIT NONE
217 !
218  INTEGER (KIND=JPLIKM) :: KLENF
219  INTEGER (KIND=JPLIKM) :: KBITS
220  INTEGER (KIND=JPLIKM) :: KNBIT
221  INTEGER (KIND=JPLIKM) :: KLENV
222  INTEGER (KIND=JPLIKM) :: KLENG
223  INTEGER (KIND=JPLIKM) :: KWORD
224  INTEGER (KIND=JPLIKM) :: KJLENV
225  INTEGER (KIND=JPLIKM) :: KJLENF
226  INTEGER (KIND=JPLIKM) :: KCPACK
227  INTEGER (KIND=JPLIKM) :: KSCALP
228  INTEGER (KIND=JPLIKM) :: KERR
229 !
230  INTEGER (KIND=JPLIKM) :: KB1PAR(19)
231  INTEGER (KIND=JPLIKM) :: KB2PAR(17)
232  INTEGER (KIND=JPLIKB) :: KGRIB(kleng)
233 !
234  REAL (KIND=JPDBLD) :: PMIN
235  REAL (KIND=JPDBLD) :: PMAX
236 !
237  REAL (KIND=JPDBLD) :: PFDATA(klenf)
238  REAL (KIND=JPDBLD) :: PVERT(klenv)
239 !
240  LOGICAL :: LDARPE
241 !
242  INTEGER (KIND=JPLIKM) :: IMAX, IOFF, IBYTE, INVAL, ISNEW
243  INTEGER (KIND=JPLIKM) :: J, ITEMP, INC, ILBLK
244  INTEGER (KIND=JPLIKM) :: ILNIL, IEXP, IMANT, ILEN
245  INTEGER (KIND=JPLIKM) :: IPW, IPB, ILBIN, IFLAG, IREP
246  INTEGER (KIND=JPLIKM) :: ISCALX, ISCALE, IMISS, ISPDA
247  INTEGER (KIND=JPLIKM) :: IPREMC, ISSUIV, IL, ILBVAL
248  INTEGER (KIND=JPLIKB) :: ILEXP, ILMANT, ILFLAG, ILSCALX, ILLNIL
249  INTEGER (KIND=JPLIKB) :: ILLBLK, ILLBIN, ILBITS, ILSPDA, ILSCALP
250  INTEGER (KIND=JPLIKB) :: ILCPACK
251 !
252 !
253  INTEGER (KIND=JPLIKM) :: IBLOCK(24), ILAT(2)
254  INTEGER (KIND=JPLIKB) :: ILBLOCK(24), ILB2PAR(17), ILLAT(2)
255 !
256  REAL (KIND=JPDBLD) :: ZSCALE
257 !
258 !
259 ! SET MAXIMUM NUMBER OF BITS PER DATA FIELD.
260 !
261  SAVE imax
262  DATA imax /60/
263 !
264 ! CLEAR ERROR INDICATOR.
265 !
266  REAL(KIND=JPRB) :: ZHOOK_HANDLE
267  IF (lhook) CALL dr_hook('DECOGA',0,zhook_handle)
268  kerr = 0
269 !
270 !
271 !
272 !
273 !
274 !
275 !
276 !
277 !
278 !
279 !
280 !
281 !
282 !
283 !
284 !
285 !
286 !********************************************************************
287 !*
288 !* BLOCK 0 - INDICATOR BLOCK.
289 !*
290 !********************************************************************
291 !
292 !
293 ! EXTRACT 4 OCTETS CONTAINING ASCII G R I B .
294 !
295  kword = 1
296  ioff = 0
297  ibyte = 8
298  inval = 4
299 !
300  CALL gsbyte_mf (kgrib(1),ilblock(1),ioff,ibyte,0,inval, &
301  & knbit,'D',kleng,kerr,kword,.true.)
302  iblock=ilblock
303 !
304  IF (kerr.NE.0) THEN
305  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
306  RETURN
307  ELSEIF (iblock(1).NE.71.AND.iblock(2).NE.82.AND. &
308  & iblock(3).NE.73.AND.iblock(4).NE.66) THEN
309  kerr=3
310  WRITE (unit=*,fmt=*) 'NO ''GRIB'' GROUP (BLOCK 0) FOUND'
311  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
312  RETURN
313  ENDIF
314 !
315 !
316 !
317 !
318 !
319 !
320 !
321 !********************************************************************
322 !*
323 !* BLOCK 1 - PRODUCT DEFINITION BLOCK.
324 !*
325 !********************************************************************
326 !
327 !
328 ! EXTRACT FIRST 4 OCTETS OF BLOCK 1.
329 !
330  inval = 4
331 !
332  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,ibyte,0,inval, &
333  & knbit,'D',kleng,kerr,kword,.true.)
334  iblock=ilblock
335  IF (kerr.NE.0) THEN
336  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
337  RETURN
338  ENDIF
339 !
340 ! IF THESE OCTETS DO NOT CONTAIN 0, 0, 24 AND 0 RESPECTIVELY
341 ! THEN THE DATA IS IN THE OLD VERSION OF THE CODE.
342 !
343  IF (iblock(1).EQ.0.AND.iblock(2).EQ.0.AND.iblock(3).EQ.24 &
344  & .AND.iblock(4).EQ.0) &
345  & THEN
346  isnew = 1
347  inval = 20
348  ELSE
349  isnew = 0
350  inval = 16
351  ENDIF
352 !
353 ! EXTRACT NEXT 16 OR 20 OCTETS OF BLOCK 1 - NUMBER DEPENDS
354 ! ON VERSION OF CODE.
355 !
356  CALL gsbyte_mf (kgrib(kword),ilblock(5),ioff,ibyte,0,inval, &
357  & knbit,'D',kleng,kerr,kword,.true.)
358  iblock=ilblock
359  IF (kerr.NE.0) THEN
360  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
361  RETURN
362  ENDIF
363 !
364 ! TRANSFER PRODUCT DEFINITION INFORMATION TO OUTPUT ARRAY.
365 ! EXCEPT FOR NUMBER AVERAGED/ACCUMULATED AND MISSING FROM AVER/ACCUM
366 !
367  DO 100 j=1,17
368  kb1par(j) = iblock(j+4*isnew)
369  100 CONTINUE
370 !
371 !
372 !
373 !
374 ! NUMBER AVERAGED OCCUPIES 2 OCTETS.
375 !
376  kb1par(18) = iblock(18+4*isnew) * 256 + iblock(19+4*isnew)
377 !
378 ! NUMBER MISSING FROM AVERAGES/ACCUMULATIONS.
379 !
380  kb1par(19)=iblock(20+4*isnew)
381 !
382 !
383 !***
384 !* DESCRIPTION OF LEVEL OR LAYER ( CODE TABLE 3 ).
385 !***
386 !
387 ! CERTAIN LEVEL TYPES REQUIRE THAT THE DESCRIPTION OCCUPY
388 ! BOTH 8 BIT FIELDS. PUT SINGLE VALUE IN FIRST LEVEL WORD.
389 !
390  itemp = 32 + (isnew*224)
391 !
392  IF( (kb1par(6).EQ. 20).OR. &
393  & (kb1par(6).EQ.100).OR. &
394  & (kb1par(6).EQ.103).OR. &
395  & (kb1par(6).EQ.105).OR. &
396  & (kb1par(6).EQ.107).OR. &
397  & (kb1par(6).EQ.109).OR. &
398  & (kb1par(6).EQ.111).OR. &
399  & (kb1par(6).EQ.113).OR. &
400  & (kb1par(6).EQ.115).OR. &
401  & (kb1par(6).EQ.117).OR. &
402  & (kb1par(6).EQ.125).OR. &
403  & (kb1par(6).EQ.127).OR. &
404  & (kb1par(6).EQ.160).OR. &
405  & (kb1par(6).EQ.210) ) THEN
406 !
407  kb1par(7) = kb1par(7) * itemp + kb1par(8)
408  kb1par(8) = 0
409  ENDIF
410 !
411 !
412 !
413 !
414 !
415 !
416 !
417 !
418 !
419 !***
420 !* TIME RANGE.
421 !***
422 !
423 ! ONE TIME RANGE CAN OCCUPY TWO OCTETS.
424 !
425  IF (kb1par(17).EQ.10) &
426  & THEN
427  kb1par(15) = kb1par(15) * itemp + kb1par(16)
428  kb1par(16) = 0
429  ENDIF
430 !
431 !
432 !
433 !
434 !
435 !
436 !
437 !
438 !
439 !
440 !
441 !********************************************************************
442 !*
443 !* BLOCK 2 - GRID DESCRIPTION BLOCK.
444 !*
445 !********************************************************************
446 !
447 !***
448 !* CHECK FLAG INDICATING IF BLOCK 2 IS INCLUDED IN CODE.
449 !***
450 !
451 ! INC IS SET TO 1 , IF BLOCK 2 IS INCLUDED.
452 !
453  inc = 0
454 !
455 !
456  IF (isnew.EQ.0) &
457  & THEN
458 ! OLD VERSION OF CODE
459 !
460 ! BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE
461 !
462 ! NONE 00000000 0
463 ! 2 00000001 1
464 ! 3 00000010 2
465 ! 2 AND 3 00000011 3
466 !
467  IF (kb1par(4).EQ.1.OR.kb1par(4).EQ.3) inc = 1
468  ELSE
469 ! NEW VERSION
470 !
471 ! BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE
472 !
473 ! NONE 00000000 0
474 ! 2 10000000 128
475 ! 3 01000000 64
476 ! 2 AND 3 11000000 192
477 !
478  IF (kb1par(4).EQ.128.OR.kb1par(4).EQ.192) inc = 1
479  ENDIF
480 !
481  IF (inc.EQ.1) &
482  & THEN
483 !
484 !
485 !***
486 !* LENGTH OF GRID DESCRIPTION BLOCK.
487 !***
488 !
489  CALL gbyte_mf (kgrib(kword),illblk,ioff,24)
490  ilblk=illblk
491  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
492  IF (kerr.NE.0) THEN
493  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
494  RETURN
495  ENDIF
496 !
497 !
498 !
499 !***
500 !* NUMBER OF UNUSED BITS AT END OF BLOCK.
501 !***
502 !
503  CALL gbyte_mf (kgrib(kword),illnil,ioff,8)
504  ilnil=illnil
505  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
506  IF (kerr.NE.0) THEN
507  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
508  RETURN
509  ENDIF
510 !
511 !
512 !
513 !
514 !***
515 !* NEXT OCTET IS RESERVED.
516 !***
517 !
518  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
519  IF (kerr.NE.0) THEN
520  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
521  RETURN
522  ENDIF
523 !
524 !
525 !
526 !
527 !
528 !
529 !
530 !***
531 !* DATA REPRESENTATION TYPE.
532 !***
533 !
534  CALL gbyte_mf (kgrib(kword),ilb2par(1),ioff,8)
535  kb2par=ilb2par
536  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
537  IF (kerr.NE.0) THEN
538  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
539  RETURN
540  ENDIF
541 !
542 ! LAT/LONGITUDE GRID, GAUSSIAN GRID AND SPHERICAL HARMONICS
543 ! ARE THE ONLY DATA REPRESENTATIONS HANDLED.
544 !
545  IF (kb2par(1).NE.0.AND.kb2par(1).NE.4.AND.kb2par(1).NE.50 &
546  & .AND.kb2par(1).NE.80) &
547  & THEN
548  WRITE (*,*)'GRID DESCRIPTION BLOCK NOT YET DEFINED'
549  kerr = -4
550  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
551  RETURN
552  ENDIF
553 !
554 !
555 !
556 !
557 !***
558 !* LAT/LONG OR GAUSSIAN GRID.
559 !***
560 !
561  IF (kb2par(1).EQ.0.OR.kb2par(1).EQ.4) &
562  & THEN
563 !
564 ! NUMBER OF LAT/LONG POINTS.
565 !
566  CALL gsbyte_mf (kgrib(kword),ilb2par(2),ioff,16,0,2, &
567  & knbit,'D',kleng,kerr,kword,.true.)
568  kb2par=ilb2par
569  IF (kerr.NE.0) THEN
570  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
571  RETURN
572  ENDIF
573 !
574 ! LAT/LONG OF ORIGIN.
575 !
576  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
577  & knbit,'D',kleng,kerr,kword,.true.)
578  ilat=illat
579  IF (kerr.NE.0) THEN
580  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
581  RETURN
582  ENDIF
583 !
584 ! IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE.
585 !
586  DO 200 j=1,2
587 !
588  IF (ilat(j).LE.2**23) THEN
589  kb2par(j+3) = ilat(j)
590  ELSE
591  kb2par(j+3) = 2**23 - ilat(j)
592  ENDIF
593 !
594  200 CONTINUE
595 !
596 !
597 ! RESOLUTION FLAG.
598 !
599  CALL gbyte_mf (kgrib(kword),ilb2par(6),ioff,8)
600  kb2par=ilb2par
601  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
602  IF (kerr.NE.0) THEN
603  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
604  RETURN
605  ENDIF
606 !
607 !
608 ! LAT/LONG OF EXTREME POINTS.
609 !
610  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
611  & knbit,'D',kleng,kerr,kword,.true.)
612  ilat=illat
613  IF (kerr.NE.0) THEN
614  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
615  RETURN
616  ENDIF
617 !
618 ! IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE.
619 !
620  DO 300 j=1,2
621 !
622  IF (ilat(j).LE.2**23) THEN
623  kb2par(j+6) = ilat(j)
624  ELSE
625  kb2par(j+6) = 2**23 - ilat(j)
626  ENDIF
627 !
628  300 CONTINUE
629 !
630 ! DIRECTION INCREMENTS / NUMBER OF LATITUDE LINES.
631 !
632  CALL gsbyte_mf (kgrib(kword),ilb2par(9),ioff,16,0,2, &
633  & knbit,'D',kleng,kerr,kword,.true.)
634  kb2par=ilb2par
635  IF (kerr.NE.0) THEN
636  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
637  RETURN
638  ENDIF
639 !
640 ! SCANNING MODE FLAGS.
641 !
642  CALL gbyte_mf (kgrib(kword),ilb2par(11),ioff,8)
643  kb2par=ilb2par
644  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
645  IF (kerr.NE.0) THEN
646  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
647  RETURN
648  ENDIF
649 !
650 ! 4 RESERVED OCTETS.
651 !
652  CALL offset_mf (ioff,4,kword,8,knbit,kleng,kerr)
653  IF (kerr.NE.0) THEN
654  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
655  RETURN
656  ENDIF
657 !
658  ENDIF
659 !
660 !
661 !
662 !
663 !
664 !
665 !
666 !
667 !
668 !
669 !
670 !
671 !
672 !
673 !***
674 !* SPHERICAL HARMONIC DATA.
675 !***
676 !
677  IF (kb2par(1).EQ.50.OR.kb2par(1).EQ.80) &
678  & THEN
679 !
680 ! PENTAGONAL RESOLUTION PARAMETERS.
681 !
682  CALL gsbyte_mf (kgrib(kword),ilb2par(2),ioff,16,0, &
683  & 3,knbit,'D',kleng,kerr,kword,.true.)
684  kb2par=ilb2par
685  IF (kerr.NE.0) THEN
686  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
687  RETURN
688  ENDIF
689 !
690 ! REPRESENTATION TYPE AND MODE.
691 !
692  CALL gsbyte_mf (kgrib(kword),ilb2par(5),ioff,8,0,2,&
693  & knbit,'D',kleng,kerr,kword,.true.)
694  kb2par=ilb2par
695  IF (kerr.NE.0) THEN
696  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
697  RETURN
698  ENDIF
699 !
700 ! 18 RESERVED OCTETS.
701 !
702  CALL offset_mf (ioff,18,kword,8,knbit,kleng,kerr)
703  IF (kerr.NE.0) THEN
704  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
705  RETURN
706  ENDIF
707 !
708  ENDIF
709 !
710 !**
711 !* STRETCHED AND ROTATED SHPERICAL HARMONICS.
712 !**
713  IF(kb2par(1).EQ.80) THEN
714 !
715 !* SOUTHERN POLE OF ROTATED GRID
716 !
717  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
718  & knbit,'D',kleng,kerr,kword,.true.)
719  ilat=illat
720  IF (kerr.NE.0) THEN
721  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
722  RETURN
723  ENDIF
724 !
725 ! IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE.
726 !
727  DO 410 j=1,2
728 !
729  IF (ilat(j).LE.2**23) THEN
730  kb2par(j+11) = ilat(j)
731  ELSE
732  kb2par(j+11) = 2**23 - ilat(j)
733  ENDIF
734 !
735  410 CONTINUE
736 !
737 !* ANGLE OF ROTATION
738 !
739  CALL gbyte_mf (kgrib(kword),ilexp,ioff,8)
740  iexp=ilexp
741  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
742  IF (kerr.NE.0) THEN
743  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
744  RETURN
745  ENDIF
746  CALL gbyte_mf (kgrib(kword),ilmant,ioff,24)
747  imant=ilmant
748  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
749  IF (kerr.NE.0) THEN
750  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
751  RETURN
752  ENDIF
753 !
754  CALL decfp_mf (kb2par(14),iexp,imant)
755 !
756 !* POLE OF STRETCHING
757 !
758  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
759  & knbit,'D',kleng,kerr,kword,.true.)
760  ilat=illat
761  IF (kerr.NE.0) THEN
762  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
763  RETURN
764  ENDIF
765 !
766 ! IF SIGN BIT SET TO 1 , VALUES ARE NEGATIVE.
767 !
768  DO 420 j=1,2
769 !
770  IF (ilat(j).LE.2**23) THEN
771  kb2par(j+14) = ilat(j)
772  ELSE
773  kb2par(j+14) = 2**23 - ilat(j)
774  ENDIF
775 !
776  420 CONTINUE
777 !
778 !* STRETCHING FACTOR
779 !
780  CALL gbyte_mf (kgrib(kword),ilexp,ioff,8)
781  iexp=ilexp
782  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
783  IF (kerr.NE.0) THEN
784  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
785  RETURN
786  ENDIF
787  CALL gbyte_mf (kgrib(kword),ilmant,ioff,24)
788  imant=ilmant
789  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
790  IF (kerr.NE.0) THEN
791  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
792  RETURN
793  ENDIF
794 !
795  CALL decfp_mf (kb2par(17),iexp,imant)
796 !
797  ENDIF
798 !
799 !
800 !
801 ! LENGTH IS 32 OCTETS FOR LAT/LONG, GAUSSIAN AND SPHERICAL
802 ! HARMONICS, 52 OCTETS FOR STRETCHED AND ROTATED SPHERICAL
803 ! HARMONICS.FOR ANY DATA ON HYBRID LEVELS THE
804 ! VERTICAL COORDINATES ARE ADDED.
805 ! GET NUMBER OF VERTICAL COORDINATE PARAMETERS, IF ANY.
806 !
807  IF(kb2par(1).EQ.80) THEN
808  ilen=52
809  ELSE
810  ilen=32
811  ENDIF
812 !
813  kjlenv = (ilblk - ilen) / 4
814 !
815  IF(klenv.LT.kjlenv) THEN
816  kerr = -3
817  WRITE (*,9001) kjlenv,klenv
818  9001 FORMAT (1h ,'NUMBER OF VERTICAL COORDINATES - ',i4, &
819  & ', ARRAY SIZE IS - ',i4)
820  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
821  RETURN
822  ENDIF
823 !
824 !
825 !
826 !***
827 !* VERTICAL COORDINATE PARAMETERS FOR HYBRID LEVELS.
828 !***
829 !
830  IF (kjlenv.NE.0) THEN
831 !
832  DO 400 j=1,kjlenv
833  CALL gbyte_mf (kgrib(kword),ilexp,ioff,8)
834  iexp=ilexp
835  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
836  IF (kerr.NE.0) THEN
837  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
838  RETURN
839  ENDIF
840  CALL gbyte_mf (kgrib(kword),ilmant,ioff,24)
841  imant=ilmant
842  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
843  IF (kerr.NE.0) THEN
844  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
845  RETURN
846  ENDIF
847  CALL decfp_mf (pvert(j),iexp,imant)
848  400 CONTINUE
849 !
850  ENDIF
851 !
852  ENDIF
853 !
854 !
855 !
856 ! RETURN IF ONLY PRODUCT AND GRID DEFINITION BLOCKS REQUIRED.
857 !
858  IF (klenf.EQ.1) THEN
859  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
860  RETURN
861  ENDIF
862 !
863 !
864 !
865 !
866 !
867 !
868 !
869 !
870 !********************************************************************
871 !*
872 !* BLOCK 3 - BIT MAP BLOCK.
873 !*
874 !********************************************************************
875 !
876 ! INC IS SET TO 1 , IF BLOCK 3 IS INCLUDED.
877 !
878  inc = 0
879 !
880 !
881  IF (isnew.EQ.0) &
882  & THEN
883 ! OLD VERSION OF CODE
884 !
885 ! BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE
886 !
887 ! NONE 00000000 0
888 ! 2 00000001 1
889 ! 3 00000010 2
890 ! 2 AND 3 00000011 3
891 !
892  IF (kb1par(4).EQ.2.OR.kb1par(4).EQ.3) inc = 1
893  ELSE
894 ! NEW VERSION
895 !
896 ! BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE
897 !
898 ! NONE 00000000 0
899 ! 2 10000000 128
900 ! 3 01000000 64
901 ! 2 AND 3 11000000 192
902 !
903  IF (kb1par(4).EQ.64.OR.kb1par(4).EQ.192) inc = 1
904  ENDIF
905 !
906  IF (inc.EQ.1) &
907  & THEN
908  WRITE (*,*)'BIT MAP BLOCK NOT YET DEFINED'
909  kerr = -4
910  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
911  RETURN
912  ENDIF
913 !
914 !
915 !
916 !
917 !**********************************************************************
918 !*
919 !* CONVERT VALUES IN BLOCKS 1 AND 2 TO NEW CODE VALUES.
920 !*
921 !**********************************************************************
922 !
923 !
924  IF (isnew.EQ.0) &
925  & THEN
926 !
927 ! CHANGE CODE FOR FLAG INDICATING INCLUSION OR OMISSION
928 ! OF BLOCKS 2 AND 3.
929 !
930 ! BINARY VALUE OLD CODE = 00000001
931 ! BINARY VALUE NEW CODE = 10000000 (128 DECIMAL)
932 !
933  IF (kb1par(4).EQ.1) &
934  & THEN
935  kb1par(4) = 128
936  ELSE
937  WRITE (*,*) 'DECOGA : BLOCK FLAG ERROR.'
938  kerr = 2
939  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
940  RETURN
941  ENDIF
942 !
943 ! CHANGE CODE FOR TIME UNIT.
944 !
945  IF (kb1par(14).EQ.40) &
946  & THEN
947  kb1par(14) = 1
948  ELSE
949  WRITE (*,*) 'DECOGA : TIME UNIT ERROR.'
950  kerr = 2
951  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
952  RETURN
953  ENDIF
954 !
955 ! CONVERT FLAGS FOR LAT/LONG AND GAUSSIAN GRID DATA.
956 !
957  IF (kb2par(1).EQ.0.OR.kb2par(1).EQ.4) &
958  & THEN
959 !
960 ! CONVERT SCANNING MODE FLAG.
961 !
962  IF (kb2par(11).EQ.1) &
963  & THEN
964  kb2par(11) = 0
965  ELSE
966  WRITE (*,*) 'DECOGA : SCAN MODE FLAG ERROR.'
967  kerr = 2
968  IF (lhook) &
969  & CALL dr_hook('DECOGA',1,zhook_handle)
970  RETURN
971  ENDIF
972 !
973 ! CONVERT RESOLUTION FLAG.
974 !
975  IF (kb2par(6).EQ.3) &
976  & THEN
977  kb2par(6) = 128
978  ELSE
979  WRITE (*,*) 'DECOGA : RESOLUTION FLAG ERROR.'
980  kerr = 2
981  IF (lhook) &
982  & CALL dr_hook('DECOGA',1,zhook_handle)
983  RETURN
984  ENDIF
985  ENDIF
986  ENDIF
987 !
988 !
989 !
990 !
991 !
992 !
993 !********************************************************************
994 !*
995 !* BLOCK 4 - BINARY DATA BLOCK.
996 !*
997 !********************************************************************
998 !
999 !
1000 !
1001 !***
1002 !* GET LENGTH OF BINARY DATA BLOCK.
1003 !***
1004 !
1005 !
1006  ipw = kword
1007  ipb = ioff
1008 !
1009  CALL gbyte_mf (kgrib(kword),illbin,ioff,24)
1010  ilbin=illbin
1011  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1012  IF (kerr.NE.0) THEN
1013  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1014  RETURN
1015  ENDIF
1016 !
1017 !
1018 !
1019 !
1020 !***
1021 !* 4 BIT FLAG / 4 BIT COUNT OF UNUSED BITS AT END OF BLOCK OCTET.
1022 !***
1023 !
1024  CALL gbyte_mf (kgrib(kword),ilflag,ioff,8)
1025  iflag=ilflag
1026  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1027  IF (kerr.NE.0) THEN
1028  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1029  RETURN
1030  ENDIF
1031 !
1032  IF (isnew.EQ.0) &
1033  & THEN
1034 ! OLD VERSION OF CODE
1035 !
1036 ! 0000---- GRID POINT
1037 ! 0001---- SPHERICAL HARMONICS
1038 !
1039  irep = iflag / 16
1040  ilnil = iflag - irep * 16
1041 !
1042  ELSE
1043 ! NEW VERSION OF CODE
1044 !
1045 ! 0000---- GRID POINT
1046 ! 1000---- SPHERICAL HARMONICS
1047 ! 1100---- -''- COMPLEX PACKING
1048 !
1049  irep = iflag / 128
1050  ilnil = mod(iflag,16)
1051 !
1052  ENDIF
1053 !
1054 !
1055 !
1056 !
1057 !
1058 !
1059 !
1060 !
1061 !***
1062 !* GET SCALE FACTOR
1063 !***
1064 !
1065  CALL gbyte_mf (kgrib(kword),ilscalx,ioff,16)
1066  iscalx=ilscalx
1067  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1068  IF (kerr.NE.0) THEN
1069  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1070  RETURN
1071  ENDIF
1072 !
1073  IF (iscalx.LE.2**15) THEN
1074  iscale = iscalx
1075  ELSE
1076  iscale = 2**15 - iscalx
1077  ENDIF
1078 !
1079 !
1080 !
1081 !
1082 !***
1083 !* GET REFERENCE VALUE (PMIN) IN GRIB FORMAT (IEXP,IMANT)
1084 !***
1085 !
1086 !
1087  CALL gbyte_mf (kgrib(kword),ilexp,ioff,8)
1088  iexp=ilexp
1089  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1090  IF (kerr.NE.0) THEN
1091  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1092  RETURN
1093  ENDIF
1094  CALL gbyte_mf (kgrib(kword),ilmant,ioff,24)
1095  imant=ilmant
1096  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1097  IF (kerr.NE.0) THEN
1098  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1099  RETURN
1100  ENDIF
1101 !
1102 !
1103 ! CHECK FOR MISSING DATA INDICATORS.
1104 !
1105  imiss = 0
1106  IF (iscalx.EQ.65535.AND.iexp.EQ.255.AND.imant.EQ.16777215) &
1107  & imiss = 1
1108 !
1109 !
1110 !
1111 !***
1112 !* GET NUMBER OF BITS IN EACH DATA VALUE.
1113 !***
1114 !
1115  CALL gbyte_mf (kgrib(kword),ilbits,ioff,8)
1116  kbits=ilbits
1117  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1118  IF (kerr.NE.0) THEN
1119  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1120  RETURN
1121  ENDIF
1122 !
1123 !
1124 ! CHECK NUMBER OF BITS PER DATA FIELD.
1125 !
1126  IF (kbits.GT.knbit.OR.kbits.GT.imax) &
1127  & THEN
1128  kerr = -1
1129  WRITE (*,9002) kbits,knbit,imax
1130  9002 FORMAT (1h ,'NUMBER OF BITS PER DATA VALUE, ',i3, &
1131  & 'EXCEEDS WORD LENGTH, ',i3,' OR MAXIMUM ', &
1132  & ' PERMITTED VALUE, ',i3)
1133  CALL sdl_srlabort
1134 !
1135  ELSEIF (ldarpe) THEN
1136 !
1137 ! Minimum value given as input argument... it has not been decoded
1138 ! before as stored in GRIB field (should be zero).
1139 ! But the scale factor may be computed, now.
1140 !
1141  zscale= ( pmax - pmin ) / REAL(2**kbits-1,kind=jpdbld)
1142 !
1143  ELSEIF (imiss.EQ.0) THEN
1144 !
1145 !
1146 ! CONVERT REFERENCE VALUE AND SCALE FACTOR.
1147 !
1148 !
1149  CALL decfp_mf (pmin,iexp,imant)
1150  zscale = 2.0_jpdbld**iscale
1151  pmax=pmin+REAL(2**(KBITS+1)-3,KIND=JPDBLD) * &
1152  & 2.0_JPDBLD ** (ISCALE-1)
1153 !
1154  ENDIF
1155 !
1156 !**
1157 !* IF COMPLEX PACKING GET ADDITIONAL PARAMETERS
1158 !**
1159  IF(iflag.GE.192) THEN
1160 !
1161 ! GET START OCTET OF PACKED DATA
1162 !
1163  CALL gbyte_mf (kgrib(kword),ilspda,ioff,16)
1164  ispda=ilspda
1165  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1166  IF (kerr.NE.0) THEN
1167  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1168  RETURN
1169  ENDIF
1170  ipremc=1+(8*ispda-1)/knbit
1171 !
1172  IF (ipremc.GT.klenf) THEN
1173  kerr=-3
1174  WRITE (*,9004) klenf,ispda
1175  9004 FORMAT (' OUTPUT ARRAY LENGTH (',i7, &
1176  & ' WORDS) TOO SHORT, START OCTET OF PACKED DATA =',&
1177  & i9)
1178  CALL sdl_srlabort
1179  ENDIF
1180 !
1181 ! GET LAPLACIAN SCALING FACTOR
1182 !
1183  CALL gbyte_mf (kgrib(kword),ilscalp,ioff,16)
1184  kscalp=ilscalp
1185  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1186 !
1187  IF (kerr.NE.0) THEN
1188  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1189  RETURN
1190  ELSEIF (kscalp.GT.2**15) THEN
1191  kscalp=2**15-kscalp
1192  ENDIF
1193 !
1194 ! GET TRUNCATION OF UNPACKED COEFFS.
1195 !
1196  DO 430 j=1,3
1197  CALL gbyte_mf (kgrib(kword),ilcpack,ioff,8)
1198  kcpack=ilcpack
1199  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1200  IF (kerr.NE.0) THEN
1201  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1202  RETURN
1203  ENDIF
1204  430 CONTINUE
1205 !
1206 ! COMPUTE NUMBER OF UNPACKED DATA ITEMS
1207 !
1208  irep=(kcpack+1)**2
1209  ENDIF
1210 !
1211 !***
1212 !* IF DATA IS IN SPHERICAL HARMONIC FORM, NEXT OCTETS
1213 !* CONTAIN UNPACKED COEFFICIENT(S).
1214 !***
1215 !
1216  IF (irep.NE.0) &
1217  & THEN
1218 !
1219 ! EVENTUALLY,
1220 ! GET UNPACKED COEFFICIENTS IN GRIB FORMAT AND
1221 ! CONVERT TO FLOATING POINT.
1222 !
1223  IF (imiss.EQ.1) THEN
1224 !
1225  DO 440 j=1,irep
1226  pfdata(j)=0.0_jpdbld
1227  440 CONTINUE
1228 !
1229  ELSEIF (ldarpe) THEN
1230 !
1231 ! The "unpacked" values should then contain zeroes,
1232 ! and are skipped: the corresponding values of PFDATA array
1233 ! are then not provided. A positioning in KGRIB is made.
1234 !
1235  CALL offset_mf (ioff,irep,kword,32,knbit,kleng,kerr)
1236  IF (kerr.NE.0) THEN
1237  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1238  RETURN
1239  ENDIF
1240 !
1241  ELSE
1242 !
1243  DO 450 j=1,irep
1244  CALL gbyte_mf (kgrib(kword),ilexp,ioff,8)
1245  iexp=ilexp
1246  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1247  IF (kerr.NE.0) THEN
1248  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1249  RETURN
1250  ENDIF
1251  CALL gbyte_mf (kgrib(kword),ilmant,ioff,24)
1252  imant=ilmant
1253  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1254  IF (kerr.NE.0) THEN
1255  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1256  RETURN
1257  ENDIF
1258  CALL decfp_mf (pfdata(j),iexp,imant)
1259  450 CONTINUE
1260 !
1261  ENDIF
1262 !
1263  IF (iflag.GE.192) THEN
1264 !
1265 ! Proper positioning on start octet of packed data, because
1266 ! it may be not the first octet following the "unpacked" data.
1267 !
1268  issuiv=19+irep*4
1269 !
1270  IF (issuiv.LT.ispda) THEN
1271  CALL offset_mf (ioff,ispda-issuiv,kword,8,knbit,kleng,kerr)
1272  IF (kerr.NE.0) THEN
1273  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1274  RETURN
1275  ENDIF
1276  ENDIF
1277 !
1278  ENDIF
1279 !
1280  ENDIF
1281 !
1282 !
1283 !
1284 !
1285 !*****
1286 !* DECODE DATA VALUES TO FLOATING POINT AND STORE IN PFDATA.
1287 !*****
1288 !
1289 ! FIRST CALCULATE THE NUMBER OF DATA VALUES.
1290 !
1291  kjlenf = ilbin - 11 - irep * 4
1292  IF(iflag.GE.192) kjlenf=kjlenf-7-(ispda-issuiv)
1293  kjlenf = (kjlenf * 8 - ilnil) / kbits
1294 !
1295 ! CHECK LENGTH OF OUTPUT ARRAY.
1296 !
1297  IF (kjlenf+irep.GT.klenf) &
1298  & THEN
1299  kerr = -3
1300  WRITE (*,9003) kjlenf,klenf
1301  9003 FORMAT (1h ,'NUMBER OF VALUES TO BE DECODED IS - ',i7, &
1302  & ', ARRAY SIZE - ',i7)
1303  CALL sdl_srlabort
1304  ENDIF
1305 !
1306  IF (imiss.EQ.0.AND.zscale.GT.0.0_jpdbld) THEN
1307  CALL gsbyte_mf (kgrib(kword),pfdata(irep+1),ioff,kbits,0,kjlenf,&
1308  & knbit,'D',kleng,kerr,kword,.true.)
1309  IF (kerr.NE.0) THEN
1310  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1311  RETURN
1312  ENDIF
1313  CALL unpagb (pfdata(irep+1),pfdata(irep+1),pmin,pmax,kbits, &
1314  & zscale,kjlenf,ldarpe)
1315  ELSE
1316 !
1317  IF (zscale.LE.0.) THEN
1318 !
1319  DO 460 j= irep+1,irep+kjlenf
1320  pfdata(j) = pmin
1321  460 CONTINUE
1322 !
1323  ELSE
1324 !
1325  DO 470 j= irep+1,irep+kjlenf
1326  pfdata(j) = 0.0_jpdbld
1327  470 CONTINUE
1328 !
1329  ENDIF
1330 !
1331  CALL offset_mf (ioff,kjlenf,kword,kbits,knbit,kleng,kerr)
1332  IF (kerr.NE.0) THEN
1333  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1334  RETURN
1335  ENDIF
1336  ENDIF
1337 !
1338 !
1339 ! INCLUDE UNPACKED COEFFICIENT IN COUNT, IF SPHERICAL HARMONIC DATA.
1340 !
1341  kjlenf = irep + kjlenf
1342 !
1343 !
1344 !
1345 !
1346 !***
1347 !* SKIP ANY ZERO FILL AT END OF DATA BLOCK.
1348 !***
1349 !
1350  il = (kword-ipw) * knbit + ioff -ipb
1351  il = ilbin * 8 - il
1352 !
1353  IF (il.NE.0) THEN
1354  CALL offset_mf (ioff,1,kword,il,knbit,kleng,kerr)
1355  IF (kerr.NE.0) THEN
1356  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1357  RETURN
1358  ENDIF
1359  ENDIF
1360 !
1361 !
1362 !
1363 !
1364 !********************************************************************
1365 !*
1366 !* BLOCK 5 - END BLOCK.
1367 !*
1368 !********************************************************************
1369 !
1370 ! CHECK 7 7 7 7 AT END OF CODED DATA.
1371 !
1372 !
1373  inval=4
1374  ilbval=8
1375  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,ilbval,0,inval, &
1376  & knbit,'D',kleng,kerr,kword,.false.)
1377  iblock=ilblock
1378  IF (kerr.NE.0) THEN
1379  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1380  RETURN
1381  ENDIF
1382 !
1383 ! 55 IS THE VALUE OF ASCII CHARACTER '7'
1384 !
1385  DO 600 j=1,inval
1386  IF (iblock(j).NE.55) kerr = 1
1387  600 CONTINUE
1388 !
1389  IF (kerr.EQ.1) WRITE (*,*) ' NO 7777 GROUP FOUND '
1390 !
1391 !
1392 !
1393 ! SET NUMBER OF VALUES NEGATIVE, IF MISSING DATA VALUES.
1394 !
1395  IF (imiss.EQ.1) kjlenf = - kjlenf
1396 !
1397  IF (lhook) CALL dr_hook('DECOGA',1,zhook_handle)
1398  ENDSUBROUTINE decoga
gbyte_mf
subroutine gbyte_mf(KSOURC, KDEST, KOFSET, KBYTSZ)
Definition: gbyte_mf.F:2
gsbyte_mf
subroutine gsbyte_mf(KS, KD, KOFF, KSIZE, KSKBTW, K, KBPW,
Definition: gsbyte_mf.F:2
yomhook::dr_hook
Definition: yomhook.F90:20
lfi_precision::jpdbld
integer, parameter jpdbld
Definition: lfi_precision.F90:23
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
sdl_mod
Definition: sdl_mod.F90:1
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
decfp_mf
subroutine decfp_mf(PFVAL, KEXP, KMANT)
Definition: decfp_mf.F:2
decoga
subroutine decoga(PFDATA, KLENF, KBITS, KNBIT, KB1PAR,
Definition: decoga.F:2
offset_mf
subroutine offset_mf(KOFF, KVAL, KWORD, KBYTE, KNBIT, KLEN, KERR)
Definition: offset_mf.F:2
unpagb
subroutine unpagb(KPDATA, PFDATA, PMIN, PMAX, KBITS, PSCALE,
Definition: unpagb.F:2
lfi_precision
Definition: lfi_precision.F90:1
sdl_srlabort
subroutine sdl_srlabort
Definition: sdl_srlabort.F90:2
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13