SURFEX v8.1
General documentation of Surfex
codega.F
Go to the documentation of this file.
1  SUBROUTINE codega (PFDATA,KLENF,KBITS,KNBIT,KB1PAR, &
2  & KB2PAR,PVERT,KLENV,KGRIB,KLENG,KWORD, &
3  & KROUND,KCPACK,KSCALP,KERR,PMIN,PMAX,LDARPE)
4  USE parkind1, ONLY : jprb
5  USE yomhook , ONLY : lhook, dr_hook
6  USE lfi_precision
7 !
8 !
9 !********************************************************************
10 !*
11 !* NAME : CODEGA
12 !*
13 !* FUNCTION : CODE ARRAY OF FLOATING POINT VALUES
14 !* IN WMO GRIB CODE.
15 !*
16 !* INPUT : PARAMETERS FOR BLOCK 1 , PRODUCT DEFINITION BLOCK.
17 !* --------------------------------------------------
18 !* KB1PAR - INTEGER ARRAY (DIMENSION 19) OF PRODUCT
19 !* DEFINITION INFORMATION.
20 !*
21 !* WORD CONTENTS
22 !* ---- --------
23 !* 1 ORIGINATING CENTRE IDENTIFIER.
24 !* 2 MODEL IDENTIFICATION.
25 !* 3 GRID DEFINITION.
26 !* 4 FLAG ( CODE TABLE 1 ).
27 !* 5 PARAMETER IDENTIFIER (CODE TABLE 2).
28 !* 6 TYPE OF LEVEL (CODE TABLE 3).
29 !* 7-8 VALUE(S) OF LEVEL (CODE TABLE 3).
30 !* 9 YEAR OF DATA
31 !* 10 MONTH OF DATA
32 !* 11 DAY OF DATA
33 !* 12 HOUR OF DATA
34 !* 13 MINUTE OF DATA
35 !* 14 TIME UNIT (CODE TABLE 4).
36 !* 15 TIME RANGE ONE
37 !* 16 TIME RANGE TWO
38 !* 17 TIME RANGE FLAG (CODE TABLE 5).
39 !* 18 NUMBER AVERAGED OR ACCUMULATED.
40 !* 19 NUMBER MISSING FROM AVERAGES/ACCUMULATIONS.
41 !*
42 !* VALUE(S) OF LEVEL CAN OCCUPY 2 WORDS.
43 !* FOR A LAYER THE FIRST WORD DEFINES THE TOP
44 !* AND THE SECOND THE BOTTOM OF THE LAYER.
45 !* FOR A SINGLE LEVEL, ONLY THE FIRST WORD IS
46 !* USED.
47 !*
48 !* PARAMETERS FOR BLOCK 2 , GRID DEFINITION BLOCK.
49 !* -----------------------------------------------
50 !* KB2PAR - INTEGER ARRAY (DIMENSION 17) CONTAINING GRID
51 !* DEFINITION INFORMATION.
52 !* USE VARIES WITH REPRESENTATION TYPE.
53 !*
54 !* WORD LAT/LONG GRID
55 !* ---- -------------
56 !* 1 DATA REPRESENTATION TYPE (CODE TABLE 6)
57 !* 2 NO. OF POINTS ALONG A LATITUDE
58 !* 3 NO. OF POINTS ALONG A MERIDIAN
59 !* 4 LATITUDE OF ORIGIN (SOUTH - IVE).
60 !* 5 LONGITUDE OF ORIGIN (WEST - IVE).
61 !* 6 RESOLUTION FLAG. (CODE TABLE 7)
62 !* 7 LATITUDE OF EXTREME POINT (SOUTH - IVE).
63 !* 8 LONGITUDE OF EXTREME POINT (WEST - IVE).
64 !* 9 LATITUDE INCREMENT
65 !* 10 LONGITUDE INCREMENT
66 !* 11 SCANNING MODE FLAGS (CODE TABLE 8)
67 !*
68 !* WORD GAUSSIAN GRID
69 !* ---- -------------
70 !* 1-9 AS FOR LAT/LONGITUDE GRID.
71 !* 10 THE NUMBER OF LATITUDE LINES BETWEEN A POLE
72 !* AND THE EQUATOR.
73 !* 11 SCANNING MODE FLAGS (CODE TABLE 8)
74 !*
75 !* WORD SPHERICAL HARMONICS
76 !* ---- -------------------
77 !* 1 DATA REPRESENTATION TYPE (CODE TABLE 6)
78 !* 2 J - PENTAGONAL RESOLUTION PARAMETER
79 !* 3 K - PENTAGONAL RESOLUTION PARAMETER
80 !* 4 M - PENTAGONAL RESOLUTION PARAMETER
81 !* 5 REPRESENTATION TYPE (CODE TABLE 9)
82 !* 6 REPRESENTATION MODE (CODE TABLE 10)
83 !* 7-11 NOT USED
84 !*
85 !*
86 !* USE FOR OTHER DATA REPRESENTATION TYPES IS
87 !* TO BE DEFINED LATER.
88 !*
89 !* PVERT - REAL ARRAY OF VERTICAL COORDINATE PARAMETERS
90 !* KLENV - LENGTH OF THIS ARRAY (NUMBER OF COORDINATE
91 !* PARAMETERS).
92 !*
93 !* USED FOR HYBRID LEVELS ONLY.
94 !*
95 !*
96 !* PARAMETERS FOR BLOCK 3 , BIT-MAP DEFINITION BLOCK.
97 !* --------------------------------------------------
98 !*
99 !* TO BE DEFINED LATER.
100 !*
101 !* PARAMETERS FOR BLOCK 4 , BINARY DATA BLOCK.
102 !* -------------------------------------------
103 !* PFDATA - ARRAY OF FLOATING POINT VALUES.
104 !*
105 !* ****
106 !* VALUES IN THIS ARRAY ARE OVERWRITTEN
107 !* BY THE SUBROUTINE.
108 !* ****
109 !*
110 !* KLENF - LENGTH OF THIS ARRAY (NUMBER OF DATA
111 !* VALUES TO BE CODED)
112 !* KBITS - NUMBER OF BITS FOR CODED DATA VALUES.
113 !*
114 !* KCPACK - KCPACK GREATER THAN ZERO INDICATES COMPLEX
115 !* PACKING, WITH A *TRIANGULAR* SUB-TRUNCATION
116 !* "UNPACKED" OF ORDER KCPACK.
117 !
118 !* KSCALP - FOR COMPLEX PACKING OF SPECTRAL COEFFICIENTS
119 !* ONLY, LAPLACIAN SCALING FACTOR.
120 !*
121 !* TO INDICATE MISSING DATA VALUES, KLENF IS
122 !* MADE NEGATIVE AND ALL DATA VALUES SET TO 0.
123 !*
124 !* OTHER PARAMETERS
125 !* ----------------
126 !*
127 !* KNBIT - NUMBER OF BITS IN COMPUTER WORD.
128 !*
129 !* KGRIB - ARRAY TO RECEIVE DATA IN GRIB CODE.
130 !* KLENG - LENGTH OF THIS ARRAY.
131 !*
132 !* KROUND - 0 , NO ROUNDING.
133 !* 1 , ROUND TO NEAREST 120 OCTETS.
134 !*
135 !* LDARPE - .TRUE., modifications for ARPEGE coding.
136 !* .FALSE., no such modifications.
137 !*
138 !* OUTPUT : KGRIB - DATA CODED IN GRIB CODE.
139 !* KWORD - NUMBER OF WORDS OCCUPIED BY CODED DATA.
140 !*
141 !* KERR - ERROR INDICATOR.
142 !*
143 !* 0, NO ERROR.
144 !*
145 !* -1, NUMBER OF BITS PER DATA VALUE EXCEEDS
146 !* WORD LENGTH, OR MAXIMUM ALLOWED.
147 !* -2, OUTPUT ARRAY TOO SMALL TO HOLD CODED
148 !* DATA VALUES.
149 !* -3, CURRENTLY UNDEFINED OPTION SELECTED.
150 !* -4, MISSING DATA FIELD CONTAINS NON-ZERO.
151 !* -5, INVALID COMPLEX PACKING MODE.
152 !* -6, INVALID LAPLACIAN SCALING FACTOR.
153 !*
154 !* 1, INVALID ORIGINATING CENTRE.
155 !* 2, INVALID MODEL IDENTIFICATION.
156 !* 3, INVALID GRID DEFINITION.
157 !* 4, INVALID BLOCK INDICATOR FLAG
158 !* 5, INVALID PARAMETER IDENTIFIER.
159 !* 6, INVALID LEVEL TYPE INDICATOR.
160 !* 7, ERROR IN DESCRIPTION OF LEVELS.
161 !* 8, DATE/TIME ERROR.
162 !* 9, INVALID TIME UNIT OR RANGE.
163 !* 10, INVALID DATA REPRESENTATION TYPE.
164 !* 11, INVALID EXTREME POINT/INCREMENT FLAG.
165 !* 12, INVALID SCANNING MODE FLAGS.
166 !* 13, INVALID COMPLEX PACKING MODE.
167 !*
168 !* PMIN - MINIMUM VALUE OF THE FIELD DATA.
169 !*
170 !* PMAX - MAXIMUM VALUE OF THE FIELD DATA.
171 !*
172 !* JOHN HENNESSY , ECMWF , NOVEMBER 1985
173 !*
174 !* Modifications by Mats HAMRUD, ECMWF, to handle complex packing of
175 !* spectral harmonics data, 1988.
176 !*
177 !* Modifications by Jean CLOCHARD, French DMN, January 1990:
178 !*
179 !* - to remove automatic arrays introduced by the last modification
180 !* ( *** BUT INPUT ARRAY PFDATA IS OVERWRITTEN AGAIN *** );
181 !* - to comply with the "DOCTOR" norm;
182 !* - to use (standard case) as reference value the highest 32-bit
183 !* value not exceeding the minimum of the field, this reference
184 !* value being used to compute departures from this value;
185 !* - to allow modifications of the packing for ARPEGE files use,
186 !* in an optional way.
187 !*
188 !********************************************************************
189 !
190 !
191 !
192 !
193 !
194 !
195  IMPLICIT NONE
196 !
197  INTEGER (KIND=JPLIKM) :: KLENF
198  INTEGER (KIND=JPLIKM) :: KBITS
199  INTEGER (KIND=JPLIKM) :: KNBIT
200  INTEGER (KIND=JPLIKM) :: KLENG
201  INTEGER (KIND=JPLIKM) :: KWORD
202  INTEGER (KIND=JPLIKM) :: KROUND
203  INTEGER (KIND=JPLIKM) :: KCPACK
204  INTEGER (KIND=JPLIKM) :: KSCALP
205  INTEGER (KIND=JPLIKM) :: KERR
206  INTEGER (KIND=JPLIKM) :: KLENV
207 !
208  REAL (KIND=JPDBLD) :: PFDATA(*)
209  REAL (KIND=JPDBLD) :: PVERT(klenv)
210 !
211  REAL (KIND=JPDBLD) :: PMIN
212  REAL (KIND=JPDBLD) :: PMAX
213 !
214  LOGICAL :: LDARPE
215 !
216  INTEGER (KIND=JPLIKB) :: KGRIB(kleng)
217  INTEGER (KIND=JPLIKM) :: KB1PAR(19)
218  INTEGER (KIND=JPLIKM) :: KB2PAR(17)
219 !
220  INTEGER (KIND=JPLIKM) :: IMAX, ILENF, IMISS
221  INTEGER (KIND=JPLIKM) :: J, IBYTE, INVAL, IOFF, ITEMP, IERR
222  INTEGER (KIND=JPLIKM) :: IERY, IERD, IERM, IERH, IERN
223  INTEGER (KIND=JPLIKM) :: I, IEXP, IMANT, IPW, IPB
224  INTEGER (KIND=JPLIKM) :: IREP, IFLAG, ICPACK, ILEN
225  INTEGER (KIND=JPLIKM) :: ISCALE, ISCALX, ISTPA, IRESTE
226  INTEGER (KIND=JPLIKM) :: ISCALP, IAUXIL, ILENFM, ILBIN
227  INTEGER (KIND=JPLIKM) :: IL, ILNIL, IBITS, INUMBI
228  INTEGER (KIND=JPLIKB) :: IL8, ILEXP, ILMANT, ILFLAG, ILSCALX
229  INTEGER (KIND=JPLIKB) :: ILAUXIL, ILLBIN, ILBITS, ILSTPA, ILSCALP
230 !
231  INTEGER (KIND=JPLIKM) :: IBLOCK(24)
232  INTEGER (KIND=JPLIKM) :: ILAT(2)
233  INTEGER (KIND=JPLIKB) :: ILBLOCK(24), ILB2PAR(17), ILLAT(2)
234 !
235  REAL (KIND=JPDBLD) :: ZCOEFF, ZEPSIL, ZAUXIL, ZSCALE, ZS, ZREFER
236  REAL (KIND=JPDBLD) :: ZAUXI2
237 !
238 ! SET MAXIMUM NUMBER OF BITS PER DATA FIELD.
239 !
240  SAVE imax
241  DATA imax /60/
242 !
243 ! CLEAR ERROR INDICATOR.
244 !
245  REAL(KIND=JPRB) :: ZHOOK_HANDLE
246  IF (lhook) CALL dr_hook('CODEGA',0,zhook_handle)
247  kerr = 0
248 !
249 !
250 !
251 !
252 !
253 !********************************************************************
254 !*
255 !* CHECK FOR MISSING DATA INDICATORS.
256 !*
257 !********************************************************************
258 !
259 !
260  IF (klenf.LT.0) &
261  & THEN
262  ilenf = - klenf
263  imiss = 1
264 !
265  DO 50 j=1,ilenf
266 !
267  IF (pfdata(j).NE.0.0_jpdbld) THEN
268  kerr = -4
269  WRITE (*,9012)
270  9012 FORMAT (tr1,'NON-ZERO VALUE IN MISSING DATA', &
271  & ' FIELD.')
272  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
273  RETURN
274  ENDIF
275  50 CONTINUE
276 !
277  ELSE
278  ilenf = klenf
279  imiss = 0
280  ENDIF
281 !
282 !
283 !
284 !
285 !********************************************************************
286 !*
287 !* CHECK NUMBER OF BITS PER DATA FIELD.
288 !*
289 !********************************************************************
290 !
291 !
292  IF (kbits.GT.knbit.OR.kbits.GT.imax) &
293  & THEN
294  kerr = -1
295  WRITE (*,9000) kbits,knbit,imax
296  9000 FORMAT (tr1,'NUMBER OF BITS PER DATA VALUE, ',i3, &
297  & 'EXCEEDS WORD LENGTH, ',i3,' OR MAXIMUM ', &
298  & ' PERMITTED VALUE, ',i3)
299  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
300  RETURN
301  ENDIF
302 !
303 !
304 !
305 !
306 !
307 !
308 !
309 !
310 !
311 !
312 !
313 !********************************************************************
314 !*
315 !* BLOCK 0 - INDICATOR BLOCK.
316 !*
317 !********************************************************************
318 !
319 !
320 !
321 !***
322 !* THE LETTERS G R I B ARE INSERTED IN THE
323 !* FIRST 4 ELEMENTS OF 'IBLOCK'.
324 !***
325 !
326  iblock(1) = 71
327  iblock(2) = 82
328  iblock(3) = 73
329  iblock(4) = 66
330 !
331  kword = 1
332  ibyte = 8
333  inval = 4
334  ioff = 0
335 !
336 ! PACK 4 8-BIT FIELDS IN BLOCK 0 OF CODED ARRAY.
337 !
338  ilblock=iblock
339  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,ibyte,0,inval, &
340  & knbit,'C',kleng,kerr,kword,.true.)
341  IF (kerr.NE.0) THEN
342  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
343  RETURN
344  ENDIF
345 !
346 !
347 !
348 !
349 !
350 !
351 !
352 !
353 !********************************************************************
354 !*
355 !* BLOCK 1 - PRODUCT DEFINITION BLOCK.
356 !*
357 !********************************************************************
358 !
359 !
360 !
361 !***
362 !* LENGTH OF BLOCK 1 (IN OCTETS) IN FIRST 3 OCTETS.
363 !***
364 !
365  iblock(1) = 0
366  iblock(2) = 0
367  iblock(3) = 24
368 !
369 !
370 !
371 !
372 !***
373 !* FOURTH OCTET RESERVED AND SET TO 0.
374 !***
375 !
376  iblock(4) = 0
377 !
378 !
379 !
380 !
381 !
382 !
383 !***
384 !* IDENTIFICATION OF CENTRE
385 !***
386  iblock(5) = kb1par(1)
387  IF (kb1par(1).LT.1.OR.kb1par(1).GT.98) &
388  & THEN
389  kerr = 1
390  WRITE (*,9001) kb1par(1)
391  9001 FORMAT (tr1,'INVALID ORIGINATING CENTRE ',i3)
392  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
393  RETURN
394  ENDIF
395 !
396 !
397 !
398 !
399 !
400 !
401 !
402 !***
403 !* MODEL IDENTIFICATION
404 !***
405 !
406  iblock(6) = kb1par(2)
407  IF (kb1par(2).LT.1.OR.kb1par(2).GT.255) &
408  & THEN
409  kerr = 2
410  WRITE (*,9002) kb1par(2)
411  9002 FORMAT (tr1,'INVALID MODEL IDENTIFICATION ',i4)
412  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
413  RETURN
414  ENDIF
415 !
416 !
417 !
418 !
419 !
420 !
421 !
422 !
423 !***
424 !* GRID DEFINITION
425 !***
426 !
427  iblock(7) = kb1par(3)
428  IF (kb1par(3).LT.1.OR.kb1par(3).GT.255) &
429  & THEN
430  kerr = 3
431  WRITE (*,9003) kb1par(3)
432  9003 FORMAT (tr1,'INVALID GRID IDENTIFICATION ',i4)
433  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
434  RETURN
435  ENDIF
436 !
437 !
438 !
439 !
440 !
441 !
442 !
443 !
444 !***
445 !* OPTIONAL BLOCK INDICATOR FLAGS ( CODE TABLE 1 ).
446 !***
447 !
448 ! BLOCKS INCLUDED BINARY VALUE DECIMAL VALUE
449 !
450 ! NONE 00000000 0
451 ! 2 10000000 128
452 ! 3 01000000 64
453 ! 2 AND 3 11000000 192
454 !
455  iblock(8) = kb1par(4)
456 !
457 ! SHIFT 2-BIT FLAG FIELD RIGHT BY 6 BITS TO FACILITATE CHECKING
458 !
459  itemp = kb1par(4) / 64
460 !
461  IF (itemp.LT.0.OR.itemp.GT.3) kerr = 4
462 !
463 ! CHECK IF GRID SPECIFIED IS UNCATALOGUED.
464 !
465  IF (kb1par(3).EQ.255.AND.kb1par(4).EQ.0) kerr = 4
466  IF (kb1par(3).EQ.255.AND.kb1par(4).EQ.64) kerr = 4
467 !
468  IF (kerr.NE.0) THEN
469  CALL prtbin_mf (kb1par(4),8,itemp,ierr)
470  WRITE (*,9004) itemp
471  9004 FORMAT (tr1,'INVALID BLOCK INDICATOR FLAG ',i8.8)
472  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
473  RETURN
474  ENDIF
475 !
476 !
477 !
478 !
479 !***
480 !* PARAMETER IDENTIFIER ( CODE TABLE 2 ).
481 !***
482 !
483  iblock(9) = kb1par(5)
484  IF (kb1par(5).LT.0.OR.kb1par(5).GT.255) &
485  & THEN
486  kerr = 5
487  WRITE (*,9005) kb1par(5)
488  9005 FORMAT (tr1,'INVALID PARAMETER ',i4)
489  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
490  RETURN
491  ENDIF
492 !
493 !
494 !
495 !
496 !***
497 !* INDICATOR OF LEVEL TYPE ( CODE TABLE 3 ).
498 !***
499 !
500  iblock(10) = kb1par(6)
501 !
502 !* CODE FIGURES FOR LEVEL TYPE RANGE FROM 0 - 210, WITH 200
503 ! BEING USED FOR PSEUDO-LEVELS.
504 !
505  IF (kb1par(6).LT.0.OR.kb1par(6).GT.210) kerr = 6
506  IF (kerr.EQ.6) &
507  & THEN
508  WRITE (*,9006) kb1par(6)
509  9006 FORMAT (tr1,'INVALID LEVEL TYPE ',i4)
510  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
511  RETURN
512  ENDIF
513 !
514 !
515 !
516 !
517 !
518 !
519 !
520 !
521 !
522 !
523 !
524 !
525 !
526 !
527 !
528 !
529 !
530 !***
531 !* DESCRIPTION OF LEVEL OR LAYER ( CODE TABLE 3 ).
532 !***
533 !
534 !
535 !
536 ! FOR CERTAIN SPECIAL LEVELS NO FURTHER DESCRIPTION IS
537 ! NECESSARY, AND THE FIELDS ARE SET TO 0.
538 !
539  IF (kb1par(6).LT.100.OR.kb1par(6).EQ.102) &
540  & THEN
541  kb1par(7) = 0
542  kb1par(8) = 0
543  ENDIF
544 !
545  iblock(11) = kb1par(7)
546  iblock(12) = kb1par(8)
547 !
548 ! CERTAIN LEVEL TYPES REQUIRE THAT THE DESCRIPTION OCCUPY
549 ! BOTH 8 BIT FIELDS.
550 !
551  IF( (kb1par(6).NE. 20).AND. &
552  & (kb1par(6).NE.100).AND. &
553  & (kb1par(6).NE.103).AND. &
554  & (kb1par(6).NE.105).AND. &
555  & (kb1par(6).NE.107).AND. &
556  & (kb1par(6).NE.109).AND. &
557  & (kb1par(6).NE.111).AND. &
558  & (kb1par(6).NE.113).AND. &
559  & (kb1par(6).NE.115).AND. &
560  & (kb1par(6).NE.117).AND. &
561  & (kb1par(6).NE.125).AND. &
562  & (kb1par(6).NE.127).AND. &
563  & (kb1par(6).NE.160).AND. &
564  & (kb1par(6).NE.210) ) THEN
565 !
566  IF (kb1par(7).GT.255.OR.kb1par(8).GT.255) kerr = 7
567  ELSE
568 !
569 ! 8 LOW ORDER BITS IN IBLOCK(12)
570 ! HIGH ORDER BITS IN IBLOCK(11)
571 !
572  iblock(12) = iblock(11)
573  iblock(11) = iblock(11) / 256
574  iblock(12) = iblock(12) - iblock(11) * 256
575 !
576 ! CHECK MAXIMUM POSSIBLE IN 16 BITS.
577 !
578  IF (kb1par(7).GT.65535) kerr = 7
579  ENDIF
580 !
581  IF (kerr.NE.0) &
582  & THEN
583  WRITE (*,9007) kb1par(7),kb1par(8)
584  9007 FORMAT (tr1,'LEVEL DESCRIPTION ERROR ',i8,3x,i8)
585  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
586  RETURN
587  ENDIF
588 !
589 !
590 !
591 !
592 !
593 !
594 !
595 !
596 !
597 !
598 !
599 !
600 !
601 !
602 !
603 !
604 !
605 !
606 !
607 !
608 !
609 !
610 !***
611 !* DATE AND TIME. CHECK VALID RANGES AND MISSING DATA VALUES.
612 !***
613 !
614  iblock(13) = kb1par(9)
615  iery = 0
616  IF (kb1par(9).LT.0.OR.kb1par(9).GT.99) iery = 1
617  IF (kb1par(9).EQ.255) iery = 0
618  iblock(14) = kb1par(10)
619  ierm = 0
620  IF (kb1par(10).LT.1.OR.kb1par(10).GT.12) ierm = 1
621  IF (kb1par(10).EQ.255) ierm = 0
622  iblock(15) = kb1par(11)
623  ierd = 0
624  IF (kb1par(11).LT.1.OR.kb1par(11).GT.31) ierd = 1
625  IF (kb1par(11).EQ.255) ierd = 0
626  iblock(16) = kb1par(12)
627  ierh = 0
628  IF (kb1par(12).LT.0.OR.kb1par(12).GT.23) ierh = 1
629  IF (kb1par(12).EQ.255) ierh = 0
630  iblock(17) = kb1par(13)
631  iern = 0
632  IF (kb1par(13).LT.0.OR.kb1par(13).GT.59) iern = 1
633  IF (kb1par(13).EQ.255) iern = 0
634 !
635  kerr = iery + ierm + ierd + ierh + iern
636 !
637  IF (kerr.NE.0) &
638  & THEN
639  kerr = 8
640  WRITE (*,9008) kb1par(9),kb1par(10),kb1par(11),kb1par(12),&
641  & kb1par(13)
642  9008 FORMAT (tr1,'INVALID DATE/TIME ',3i2,' / ',2i2)
643  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
644  RETURN
645  ENDIF
646 !
647 !
648 !
649 !
650 !
651 !
652 !
653 !
654 !
655 !
656 !
657 !
658 !
659 !
660 !
661 !
662 !
663 !
664 !
665 !
666 !
667 !
668 !
669 !***
670 !* UNIT OF TIME - ( CODE TABLE 4 ).
671 !* TIME RANGE(S) AND TIME RANGE INDICATOR ( CODE TABLE 5 ).
672 !***
673 !
674 ! TIME UNIT.
675 !
676  iblock(18) = kb1par(14)
677  IF (kb1par(14).LT.0.OR.kb1par(14).GT.7) kerr = 9
678 !
679 !* TIME UNIT CODES ARE IN THE RANGE 0 - 7, WITH 254 USED FOR SECONDS.
680 !
681  IF (kb1par(14).EQ.254) kerr = 0
682 !
683 ! THERE CAN BE ONE OR TWO TIME RANGES, EACH IN 1 OCTECT OR
684 ! ONE TIME RANGE IN 2 OCTECTS.
685 !
686  IF (kb1par(17).EQ.0.OR.kb1par(17).EQ.1 &
687  & .OR.kb1par(17).EQ.10) kb1par(16) = 0
688 !
689 ! CROSS CHECK RANGE VALUES AND FLAG VALUES.
690 !
691  IF (kb1par(15).GT.65535.OR.kb1par(15).LT.0) kerr = 9
692  IF (kb1par(15).GT.255.AND.kb1par(17).NE.10) kerr = 9
693  IF (kb1par(16).GT.255.OR.kb1par(16).LT.0) kerr = 9
694  IF (kb1par(17).LT.0.OR.kb1par(17).GT.10) kerr = 9
695  IF (kerr.NE.0) &
696  & THEN
697  WRITE (*,9009) kb1par(14),kb1par(15),kb1par(16),kb1par(17)
698  9009 FORMAT (tr1,'TIME UNIT/TIME 1/TIME 2/INDICATOR ERROR - ', &
699  & i8,2x,'/',i8,2x,'/',i8,2x,'/',i8)
700  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
701  RETURN
702  ENDIF
703 !
704  iblock(19) = kb1par(15)
705  iblock(20) = kb1par(16)
706 !
707 ! ONE TIME RANGE OCCUPYING BOTH OCTETS.
708 !
709  IF (kb1par(17).EQ.10) &
710  & THEN
711 ! 8 LOW ORDER BITS IN IBLOCK(20)
712 ! HIGH ORDER BITS IN IBLOCK(19)
713 !
714  iblock(20) = iblock(19)
715  iblock(19) = iblock(19) / 256
716  iblock(20) = iblock(20) - iblock(19) * 256
717  ENDIF
718 !
719 ! TIME RANGE INDICATOR
720 !
721  iblock(21) = kb1par(17)
722 !
723 !
724 !
725 !
726 !
727 !
728 !
729 !***
730 !* NUMBER AVERAGED OR ACCUMULATED.
731 !***
732 !
733  iblock(22) = 0
734  iblock(23) = 0
735 !
736 !
737 ! CHECK CONSISTENCY INDICATOR AND NUMBER FIELD.
738 !
739  IF (kb1par(17).EQ.3.AND.kb1par(18).EQ.0) &
740  & THEN
741  kerr = 12
742  WRITE (*,9013) kb1par(17),kb1par(18)
743  9013 FORMAT (tr1,'INDICATOR/NUMBER AVERAGED ERROR - ', &
744  & i8,2x,'/',i8)
745  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
746  RETURN
747  ENDIF
748 !
749 ! VALUE IN TWO OCTETS.
750 !
751  iblock(22) = kb1par(18)
752 !
753 ! 8 LOW ORDER BITS IN IBLOCK(23)
754 ! HIGH ORDER BITS IN IBLOCK(22)
755 !
756  iblock(23) = iblock(22)
757  iblock(22) = iblock(22) / 256
758  iblock(23) = iblock(23) - iblock(22) * 256
759 !
760 !
761 !
762 !
763 !
764 !
765 !***
766 !* NUMBER MISSING FROM AVERAGES/ACCUMULATIONS.
767 !***
768 !
769  iblock(24) = kb1par(19)
770 !
771 !
772 !
773 !
774 !
775 !
776 !
777 !***
778 !*
779 !* PACK 24 8-BIT FIELDS OF BLOCK 1 IN CODED ARRAY.
780 !*
781 !***
782 !
783  ibyte = 8
784  inval = 24
785 !
786  ilblock=iblock
787  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,ibyte,0,inval, &
788  & knbit,'C',kleng,kerr,kword,.true.)
789  IF (kerr.NE.0) THEN
790  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
791  RETURN
792  ENDIF
793 !
794 !
795 !
796 !
797 !
798 !
799 !
800 !
801 !
802 !
803 !
804 !
805 !
806 !
807 !
808 !
809 !
810 !
811 !
812 !
813 !
814 !
815 !
816 !
817 !
818 !
819 !
820 !
821 !
822 !
823 !
824 !********************************************************************
825 !*
826 !* BLOCK 2 - GRID DESCRIPTION BLOCK.
827 !*
828 !********************************************************************
829 !
830 !
831  IF (kb1par(4).LT.128) GOTO 333
832 !
833 !
834 !***
835 !* SET ARRAY IBLOCK TO 0 . IT IS USED TO ZERO FILL RESERVED OCTETS.
836 !***
837 !
838  DO 100 j=1,24
839  iblock(j) = 0
840  100 CONTINUE
841 !
842 !
843 !
844 !
845 !***
846 !* LAT/LONGITUDE GRID, GAUSSIAN GRID AND SPHERICAL HARMONICS
847 !* ARE THE ONLY DATA REPRESENTATIONS HANDLED.
848 !***
849 !
850  IF (kb1par(4).EQ.128.OR.kb1par(4).EQ.192) &
851  & THEN
852  IF (kb2par(1).NE.0.AND.kb2par(1).NE.4.AND.kb2par(1).NE.50 &
853  & .AND.kb2par(1).NE.80) &
854  & THEN
855  WRITE (*,*)'GRID DESCRIPTION BLOCK NOT YET DEFINED'
856  kerr = -3
857  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
858  RETURN
859  ENDIF
860 !
861 !
862 !
863 !
864 !***
865 !* LENGTH OF GRID DESCRIPTION BLOCK.
866 !***
867 !
868 ! LENGTH IS 32 OCTETS FOR LAT/LONG, GAUSSIAN AND SPHERICAL
869 ! HARMONICS . FOR ANY DATA ON HYBRID LEVELS THE
870 ! VERTICAL COORDINATES ARE ADDED.
871 !
872  IF(kb2par(1).EQ.80) THEN
873  i=52
874  ELSE
875  i = 32
876  ENDIF
877  IF (kb1par(6).GT.108) i = i + klenv * 4
878 !
879  il8=i
880  CALL sbyte_mf (kgrib(kword),il8,ioff,24)
881  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
882  IF (kerr.NE.0) THEN
883  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
884  RETURN
885  ENDIF
886 !
887 !
888 !
889 !
890 !***
891 !* NUMBER OF UNUSED BITS AT END OF BLOCK.
892 !* CURRENT DEFINITION IMPLIES 0.
893 !***
894 !
895  ilblock=iblock
896  CALL sbyte_mf (kgrib(kword),ilblock(1),ioff,8)
897  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
898  IF (kerr.NE.0) THEN
899  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
900  RETURN
901  ENDIF
902 !
903 !
904 !
905 !
906 !
907 !***
908 !* NEXT OCTET IS RESERVED.
909 !***
910 !
911  ilblock=iblock
912  CALL sbyte_mf (kgrib(kword),ilblock(1),ioff,8)
913  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
914  IF (kerr.NE.0) THEN
915  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
916  RETURN
917  ENDIF
918 !
919 !
920 !
921 !
922 !
923 !
924 !***
925 !* DATA REPRESENTATION TYPE.
926 !***
927 !
928  ilb2par=kb2par
929  CALL sbyte_mf (kgrib(kword),ilb2par(1),ioff,8)
930  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
931  IF (kerr.NE.0) THEN
932  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
933  RETURN
934  ENDIF
935 !
936 !
937 !
938 !
939 !
940 !
941 !
942 !
943 !
944 !
945 !
946 !
947 !
948 !
949 !
950 !
951 !
952 !
953 !***
954 !* LAT/LONG OR GAUSSIAN GRID.
955 !***
956 !
957  IF (kb2par(1).EQ.0.OR.kb2par(1).EQ.4) &
958  & THEN
959 !
960 ! NUMBER OF LAT/LONG POINTS.
961 !
962  ilb2par=kb2par
963  CALL gsbyte_mf (kgrib(kword),ilb2par(2),ioff,16,0,2, &
964  & knbit,'C',kleng,kerr,kword,.true.)
965  IF (kerr.NE.0) THEN
966  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
967  RETURN
968  ENDIF
969 !
970 ! LAT/LONG OF ORIGIN.
971 ! SIGN BIT SET TO 1 IF VALUES ARE NEGATIVE.
972 !
973  DO 200 j=1,2
974 !
975  IF (kb2par(j+3).GE.0) THEN
976  ilat(j) = kb2par(j+3)
977  ELSE
978  ilat(j) = 2**23 - kb2par(j+3)
979  ENDIF
980 !
981  200 CONTINUE
982 !
983  ilblock=iblock
984  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,24,0,2, &
985  & knbit,'C',kleng,kerr,kword,.true.)
986  IF (kerr.NE.0) THEN
987  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
988  RETURN
989  ENDIF
990 !
991 ! RESOLUTION FLAG.
992 !
993 ! INCREMENTS BINARY CODE DECIMAL VALUE
994 !
995 ! NOT GIVEN 00000000 0
996 ! GIVEN 10000000 128
997 !
998 !
999 ! SHIFT 1 BIT FLAG FIELD TO LOW ORDER BIT
1000 !
1001  itemp = kb2par(6) / 128
1002 !
1003  IF (itemp.LE.0.OR.itemp.GT.1) &
1004  & THEN
1005  CALL prtbin_mf (kb2par(6),8,itemp,ierr)
1006  WRITE (*,9011) itemp
1007  9011 FORMAT (tr1,'INVALID RESOLUTION FLAG ',i8.8)
1008  kerr = 11
1009  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1010  RETURN
1011  ENDIF
1012 !
1013 ! SET TO ALL 1-BITS UNUSED INCREMENT FIELDS.
1014 !
1015  IF (kb2par(6).EQ.0) &
1016  & THEN
1017 ! 1111111111111111 BINARY = 65535 DECIMAL
1018  kb2par(9) = 65535
1019  kb2par(10) = 65535
1020  ENDIF
1021 !
1022  ilb2par=kb2par
1023  CALL sbyte_mf (kgrib(kword),ilb2par(6),ioff,8)
1024  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1025  IF (kerr.NE.0) THEN
1026  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1027  RETURN
1028  ENDIF
1029 !
1030 ! LAT/LONG OF EXTREME POINT.
1031 !
1032 ! SIGN BIT SET TO 1 IF VALUES ARE NEGATIVE.
1033 !
1034  DO 300 j=1,2
1035 !
1036  IF (kb2par(j+6).GE.0) THEN
1037  ilat(j) = kb2par(j+6)
1038  ELSE
1039  ilat(j) = 2**23 - kb2par(j+6)
1040  ENDIF
1041 !
1042  300 CONTINUE
1043 !
1044  illat=ilat
1045  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
1046  & knbit,'C',kleng,kerr,kword,.true.)
1047  IF (kerr.NE.0) THEN
1048  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1049  RETURN
1050  ENDIF
1051 !
1052 !
1053 !
1054 ! DIRECTION INCREMENTS / NUMBER OF LATITUDE LINES.
1055 !
1056  ilb2par=kb2par
1057  CALL gsbyte_mf (kgrib(kword),ilb2par(9),ioff,16,0,2, &
1058  & knbit,'C',kleng,kerr,kword,.true.)
1059  IF (kerr.NE.0) THEN
1060  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1061  RETURN
1062  ENDIF
1063 !
1064 ! SCANNING MODE FLAGS.
1065 !
1066 ! VALID VALUES VALUE / 32
1067 ! BINARY DECIMAL
1068 !
1069 ! 00000000 0
1070 ! 10000000 4
1071 ! 01000000 2
1072 ! 11000000 6
1073 ! 00100000 1
1074 ! 10100000 5
1075 ! 01100000 3
1076 ! 11100000 7
1077 !
1078 ! SHIFT 3 BIT FLAG FIELD TO LOW ORDER BITS.
1079 !
1080  itemp = kb2par(11) / 32
1081 !
1082  IF (itemp.LT.0.OR.itemp.GT.7) &
1083  & THEN
1084  CALL prtbin_mf (kb2par(11),8,itemp,ierr)
1085  WRITE (*,9014) itemp
1086  9014 FORMAT (tr1,'INVALID SCANNING MODE FLAGS ',i8.8)
1087  kerr = 12
1088  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1089  RETURN
1090  ENDIF
1091 !
1092  ilb2par=kb2par
1093  CALL sbyte_mf (kgrib(kword),ilb2par(11),ioff,8)
1094  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1095  IF (kerr.NE.0) THEN
1096  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1097  RETURN
1098  ENDIF
1099 !
1100 ! 4 RESERVED OCTETS.
1101 !
1102  ilblock=iblock
1103  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,8,0,4, &
1104  & knbit,'C',kleng,kerr,kword,.true.)
1105  IF (kerr.NE.0) THEN
1106  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1107  RETURN
1108  ENDIF
1109 !
1110  ENDIF
1111 !
1112 !
1113 !
1114 !
1115 !
1116 !
1117 !
1118 !
1119 !
1120 !
1121 !
1122 !***
1123 !* SPHERICAL HARMONIC DATA.
1124 !***
1125 !
1126  IF (kb2par(1).EQ.50.OR.kb2par(1).EQ.80) &
1127  & THEN
1128 !
1129 ! PENTAGONAL RESOLUTION PARAMETERS.
1130 !
1131  ilb2par=kb2par
1132  CALL gsbyte_mf (kgrib(kword),ilb2par(2),ioff,16,0,3, &
1133  & knbit,'C',kleng,kerr,kword,.true.)
1134  IF (kerr.NE.0) THEN
1135  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1136  RETURN
1137  ENDIF
1138 !
1139 ! REPRESENTATION TYPE AND MODE.
1140 !
1141  ilb2par=kb2par
1142  CALL gsbyte_mf (kgrib(kword),ilb2par(5),ioff,8,0,2, &
1143  & knbit,'C',kleng,kerr,kword,.true.)
1144  IF (kerr.NE.0) THEN
1145  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1146  RETURN
1147  ENDIF
1148 !
1149 ! 18 RESERVED OCTETS.
1150 !
1151  ilblock=iblock
1152  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,8,0,18, &
1153  & knbit,'C',kleng,kerr,kword,.true.)
1154  IF (kerr.NE.0) THEN
1155  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1156  RETURN
1157  ENDIF
1158 !
1159  ENDIF
1160 !
1161 !
1162 !***
1163 !* ADD PARAMETERS NEEDED TO DESCRIBE STRETCHED AND ROTATED
1164 !* SPHERICAL HARMONICS DATA
1165 !***
1166 !
1167  IF(kb2par(1).EQ.80) THEN
1168 !
1169 !* POLE OF ROTATION
1170 !
1171  DO 310 j=1,2
1172 !
1173  IF (kb2par(j+11).GE.0) THEN
1174  ilat(j) = kb2par(j+11)
1175  ELSE
1176  ilat(j) = 2**23 - kb2par(j+11)
1177  ENDIF
1178 !
1179  310 CONTINUE
1180 !
1181  illat=ilat
1182  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
1183  & knbit,'C',kleng,kerr,kword,.true.)
1184  IF (kerr.NE.0) THEN
1185  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1186  RETURN
1187  ENDIF
1188 !
1189 !* ANGLE OF ROTATION
1190  ilb2par=kb2par
1191  CALL confp_mf (ilb2par(14),iexp,imant)
1192  ilexp=iexp
1193  CALL sbyte_mf (kgrib(kword),ilexp,ioff,8)
1194  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1195  IF (kerr.NE.0) THEN
1196  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1197  RETURN
1198  ENDIF
1199  ilmant=imant
1200  CALL sbyte_mf (kgrib(kword),ilmant,ioff,24)
1201  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1202  IF (kerr.NE.0) THEN
1203  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1204  RETURN
1205  ENDIF
1206 !
1207 !* POLE OF STRETCHING
1208 !
1209  DO 320 j=1,2
1210 !
1211  IF (kb2par(j+14).GE.0) THEN
1212  ilat(j) = kb2par(j+14)
1213  ELSE
1214  ilat(j) = 2**23 - kb2par(j+14)
1215  ENDIF
1216 !
1217  320 CONTINUE
1218  illat=ilat
1219  CALL gsbyte_mf (kgrib(kword),illat(1),ioff,24,0,2, &
1220  & knbit,'C',kleng,kerr,kword,.true.)
1221  IF (kerr.NE.0) THEN
1222  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1223  RETURN
1224  ENDIF
1225 !
1226 !* STRETCHING FACTOR
1227  ilb2par=kb2par
1228  CALL confp_mf (ilb2par(17),iexp,imant)
1229  ilexp=iexp
1230  CALL sbyte_mf (kgrib(kword),iexp,ioff,8)
1231  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1232  IF (kerr.NE.0) THEN
1233  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1234  RETURN
1235  ENDIF
1236  ilmant=imant
1237  CALL sbyte_mf (kgrib(kword),ilmant,ioff,24)
1238  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1239  IF (kerr.NE.0) THEN
1240  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1241  RETURN
1242  ENDIF
1243  ENDIF
1244 !
1245 !
1246 !
1247 !***
1248 !* ADD VERTICAL COORDINATE PARAMETERS FOR HYBRID LEVELS.
1249 !***
1250 !
1251  IF (kb1par(6).GT.108) THEN
1252 !
1253  DO 400 j=1,klenv
1254  CALL confp_mf (pvert(j),iexp,imant)
1255  ilexp=iexp
1256  CALL sbyte_mf (kgrib(kword),ilexp,ioff,8)
1257  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1258  IF (kerr.NE.0) THEN
1259  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1260  RETURN
1261  ENDIF
1262  ilmant=imant
1263  CALL sbyte_mf (kgrib(kword),ilmant,ioff,24)
1264  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1265  IF (kerr.NE.0) THEN
1266  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1267  RETURN
1268  ENDIF
1269  400 CONTINUE
1270 !
1271  ENDIF
1272 !
1273  ENDIF
1274 !
1275 !
1276 !
1277 !
1278 !
1279 !
1280 !
1281  333 CONTINUE
1282 !
1283 !
1284 !********************************************************************
1285 !*
1286 !* BLOCK 3 (IF REQUIRED) - BIT MAP BLOCK.
1287 !*
1288 !********************************************************************
1289 !
1290  IF (kb1par(4).EQ.64.OR.kb1par(4).EQ.192) &
1291  & THEN
1292  WRITE (*,*)'BIT MAP BLOCK NOT YET DEFINED'
1293  kerr = -3
1294  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1295  RETURN
1296  ENDIF
1297 !
1298 !
1299 !
1300 !
1301 !
1302 !
1303 !
1304 !
1305 !
1306 !
1307 !
1308 !
1309 !
1310 !
1311 !
1312 !
1313 !
1314 !
1315 !
1316 !
1317 !
1318 !
1319 !
1320 !
1321 !********************************************************************
1322 !*
1323 !* BLOCK 4 - BINARY DATA BLOCK.
1324 !*
1325 !********************************************************************
1326 !
1327 !
1328 !***
1329 !* RETAIN POINTERS TO WORD AND BIT POSITION OF BINARY DATA
1330 !* BLOCK LENGTH FIELD. ENTER LENGTH AS 0.
1331 !***
1332 !
1333  ipw = kword
1334  ipb = ioff
1335 !
1336  ilblock=iblock
1337  CALL sbyte_mf (kgrib(kword),ilblock(1),ioff,24)
1338  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1339  IF (kerr.NE.0) THEN
1340  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1341  RETURN
1342  ENDIF
1343 !
1344 !
1345 !
1346 !
1347 !
1348 !
1349 !
1350 !
1351 !
1352 !
1353 !
1354 !***
1355 !* 4 BIT FLAG / 4 BIT COUNT OF UNUSED BITS AT END OF BLOCK OCTET.
1356 !***
1357 !
1358 ! FLAG IS 1000 FOR SPHERICAL HARMONICS, 0000 FOR LAT/LONG
1359 ! OR GAUSSIAN GRID, 1100 FOR SPHERICAL HARM. COMPLEX PACKING
1360 !
1361  irep = 0
1362  iflag=0
1363  icpack=kcpack
1364 !
1365  IF (kb2par(1).EQ.50.OR.kb2par(1).EQ.80) THEN
1366  iflag=128
1367  irep=1
1368 !
1369  IF (icpack.LT.0) THEN
1370  WRITE (*,*) 'CODEGA : COMPLEX PACKING CODE ERROR'
1371  kerr = -5
1372  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1373  RETURN
1374  ELSEIF (iabs(kscalp).GE.2**15) THEN
1375  WRITE (*,*) 'CODEGA : LAPLACIAN SCALING FACTOR ERROR'
1376  kerr = -6
1377  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1378  RETURN
1379  ENDIF
1380 !
1381  IF(icpack.NE.0.AND.kb2par(6).EQ.2) THEN
1382  iflag=iflag+64
1383  irep=(icpack+1)**2
1384  ELSE
1385  icpack=0
1386  ENDIF
1387 !
1388  ENDIF
1389 !
1390  ilflag=iflag
1391  CALL sbyte_mf (kgrib(kword),ilflag,ioff,8)
1392  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1393  IF (kerr.NE.0) THEN
1394  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1395  RETURN
1396  ENDIF
1397 !
1398 !
1399 !
1400 !
1401 !
1402 !
1403 !
1404 !
1405 !
1406 !
1407 !
1408 !***
1409 !* FIND MAXIMUM AND MINIMUM VALUES IN DATA ARRAY. FOR
1410 !* DATA IN SPHERICAL HARMONIC FORM THE FIRST WORD CONTAINS
1411 !* THE REAL (0,0)COEFFICIENT, WHICH IS TREATED SEPARATELY.
1412 !* FOR COMPLEX PACKING AND SPECTRAL DATA REPRESENTATION MODE=2
1413 !* THE FIRST (ICPACK+1)**2 COEFFICENTS ARE NOT PACKED
1414 !***
1415 !
1416 !
1417  ilen = ilenf - irep
1418  CALL mxmn_mf (pfdata(irep+1),ilen,pmax,pmin)
1419 !
1420 !
1421 !
1422 !
1423 !
1424 !
1425 !
1426 !
1427 !
1428 !
1429 !
1430 !
1431 !
1432 !
1433 !
1434 !
1435 !***
1436 !* COMPUTE REFERENCE VALUE AND SCALE FACTOR.
1437 !***
1438 !
1439  IF (ldarpe) THEN
1440 !
1441  zcoeff = pmax - pmin
1442 !RJ: unsafe and can underflow
1443  zepsil=1.e-290_jpdbld
1444 !RJ ZEPSIL=EPSILON(ZEPSIL)*2**N
1445 !
1446  IF ( zcoeff .LE. zepsil ) THEN
1447  zauxil=min( abs(pmin), abs(pmax) )
1448  IF ( zauxil .LE. zepsil ) zauxil=0.0_jpdbld
1449 !
1450  pmax=sign(zauxil,pmax)
1451  pmin=pmax
1452  zscale=0.0_jpdbld
1453  ELSE
1454  zscale=REAL(2**KBITS-1,KIND=JPDBLD) / ZCOEFF
1455  ENDIF
1456 !
1457 ! Scale factor and reference value forced to zero.
1458 !
1459  iscale=0
1460  zrefer=pmin
1461  iexp=0
1462  imant=0
1463 !
1464  ELSEIF (imiss.EQ.1) THEN
1465 !
1466 ! Scaling factor,
1467 ! EXPONENT AND MANTISSA SET TO ALL 1-BITS FOR MISSING DATA.
1468 !
1469  iscale = 65535
1470  iexp = 255
1471  imant = 16777215
1472  zrefer = pmin
1473 !
1474  ELSE
1475 !
1476 ! CONVERT MINIMUM VALUE (PMIN) TO GRIB FORMAT (IEXP,IMANT).
1477 !
1478 ! Its image decoded back is being used as reference value to compute
1479 ! (in PACKGB) normalized integer field values that will be
1480 ! chained into the binary string.
1481 !
1482  CALL confi (pmin,iexp,imant,zrefer)
1483 !
1484  zs = (pmax-zrefer)/REAL(2**(kbits+1)-1,kind=jpdbld)
1485  zauxil=1.0_jpdbld
1486  zauxi2=2.0_jpdbld
1487 !
1488 ! CONFI may return ZREFER > PMAX if the range
1489 ! of PMAX-PMIN is smaller than the GRIB accuracy
1490 !
1491  IF (zs.GT.0.0_jpdbld) THEN
1492  zs = log(zs)/log(zauxi2) + zauxi2
1493  ELSE
1494  zs=0.0_jpdbld
1495  ENDIF
1496  iscale = min(int(zs),int(zs+sign(zauxil,zs)))
1497 !
1498 ! Absolute value of ISCALE is limited, to avoid problems due to
1499 ! fields constant except on a few points.
1500 !
1501  iscale = max(-99,min(99,iscale))
1502  zscale = zauxi2** (-iscale)
1503 !
1504  ENDIF
1505 !
1506 !
1507 !
1508 !
1509 ! SET SIGN BIT (BIT 16) AND PUT SCALE FACTOR INTO REMAINING
1510 ! 15 BITS OF CODED 16 BIT FIELD.
1511 !
1512  IF (iscale.GE.0) THEN
1513  iscalx = iscale
1514  ELSE
1515  iscalx= 2**15 - iscale
1516  ENDIF
1517 !
1518  ilscalx=iscalx
1519  CALL sbyte_mf (kgrib(kword),ilscalx,ioff,16)
1520  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1521  IF (kerr.NE.0) THEN
1522  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1523  RETURN
1524  ENDIF
1525 !
1526 !
1527 !
1528 !
1529 !
1530  IF (iexp.EQ.0.AND.imant.EQ.0) THEN
1531  ilmant=imant
1532  CALL sbyte_mf (kgrib(kword),ilmant,ioff,32)
1533  CALL offset_mf (ioff,1,kword,32,knbit,kleng,kerr)
1534  ELSE
1535  ilexp=iexp
1536  CALL sbyte_mf (kgrib(kword),ilexp,ioff,8)
1537  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1538  IF (kerr.NE.0) THEN
1539  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1540  RETURN
1541  ENDIF
1542  ilmant=imant
1543  CALL sbyte_mf (kgrib(kword),ilmant,ioff,24)
1544  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1545  ENDIF
1546 !
1547  IF (kerr.NE.0) THEN
1548  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1549  RETURN
1550  ENDIF
1551 !
1552 !
1553 !
1554 !
1555 !***
1556 !* NUMBER OF BITS IN EACH DATA VALUE.
1557 !***
1558 !
1559  ilbits=kbits
1560  CALL sbyte_mf (kgrib(kword),ilbits,ioff,8)
1561  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1562  IF (kerr.NE.0) THEN
1563  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1564  RETURN
1565  ENDIF
1566 !
1567 !
1568 !
1569 !
1570 !***
1571 !* IF COMPLEX PACKING DESCRIBE PACKING
1572 !***
1573 !
1574  IF (irep.NE.0.AND.icpack.NE.0) THEN
1575 !
1576 ! START OF PACKED DATA
1577 !
1578  istpa=19+irep*4
1579 !
1580 ! Removing of the padding (06 sept 2000, not correct and useless)
1581 !
1582 ! IRESTE=MOD (IOFF+40+IREP*32,KNBIT)
1583 !C
1584 ! IF (IRESTE.NE.0) THEN
1585 !C
1586 ! IF ( MOD (KNBIT,KBITS).EQ.0 .AND. MOD (IRESTE,8).EQ.0 .AND.
1587 ! S MOD (KBITS,IRESTE).NE.0 ) THEN
1588 !C
1589 !C Packed data will start on a word boundary,
1590 !C and each packed data will be into a single word.
1591 !C
1592 ! ISTPA=ISTPA+IRESTE/8
1593 ! ENDIF
1594 !C
1595 ! ENDIF
1596 !
1597  ilstpa=istpa
1598  CALL sbyte_mf (kgrib(kword),ilstpa,ioff,16)
1599  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1600  IF (kerr.NE.0) THEN
1601  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1602  RETURN
1603  ENDIF
1604 !
1605 ! SCALING FACTOR.
1606 !
1607  IF (kscalp.GE.0) THEN
1608  iscalp=kscalp
1609  ELSE
1610  iscalp=2**15-kscalp
1611  ENDIF
1612 !
1613  ilscalp=iscalp
1614  CALL sbyte_mf (kgrib(kword),ilscalp,ioff,16)
1615  CALL offset_mf (ioff,1,kword,16,knbit,kleng,kerr)
1616  IF (kerr.NE.0) THEN
1617  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1618  RETURN
1619  ENDIF
1620 !
1621 ! TRUNCATION FOR UNPACKED PART OF SPECTRAL DATA, CURRENTLY
1622 ! ONLY TRIANGULAR TRUNCATION SUPPORTED
1623 !
1624  iauxil=icpack*(1+2**8*(1+2**8))
1625  ilauxil=iauxil
1626  CALL sbyte_mf (kgrib(kword),ilauxil,ioff,24)
1627  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1628  IF (kerr.NE.0) THEN
1629  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1630  RETURN
1631  ENDIF
1632 !
1633  ENDIF
1634 !***
1635 !* IF SPHERICAL HARMONICS DATA, NEXT 4 OCTETS ARE DIFFERENT FORMAT.
1636 !***
1637 !
1638  IF (irep.NE.0) &
1639  & THEN
1640 !
1641 ! STORE IREP COEFFICIENTS IN FLOATING
1642 ! POINT FORM.
1643 !
1644  IF (ldarpe) THEN
1645 !
1646 ! THE "UNPACKED" PART IS FILLED WITH ZEROES.
1647 !
1648  iexp=0
1649  imant=0
1650 !
1651  DO 510 j=1,irep
1652  ilmant=imant
1653  CALL sbyte_mf (kgrib(kword),ilmant,ioff,32)
1654  CALL offset_mf (ioff,1,kword,32,knbit,kleng,kerr)
1655  IF (kerr.NE.0) THEN
1656  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1657  RETURN
1658  ENDIF
1659  510 CONTINUE
1660 !
1661  ELSE
1662 !
1663 ! STANDARD CASE.
1664 !
1665  DO 520 j=1,irep
1666  CALL confp_mf (pfdata(j),iexp,imant)
1667 !
1668  ilexp=iexp
1669  CALL sbyte_mf (kgrib(kword),ilexp,ioff,8)
1670  CALL offset_mf (ioff,1,kword,8,knbit,kleng,kerr)
1671  IF (kerr.NE.0) THEN
1672  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1673  RETURN
1674  ENDIF
1675  ilmant=imant
1676  CALL sbyte_mf (kgrib(kword),ilmant,ioff,24)
1677  CALL offset_mf (ioff,1,kword,24,knbit,kleng,kerr)
1678  IF (kerr.NE.0) THEN
1679  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1680  RETURN
1681  ENDIF
1682  520 CONTINUE
1683 !
1684  ENDIF
1685 !
1686  ENDIF
1687 !
1688 !
1689 !
1690 !
1691 !***
1692 !* SCALE AND STORE DATA VALUES.
1693 !***
1694 !
1695 ! DO 600 J = IREP+1 , ILENF
1696 ! IPDATA = NINT ( (PFDATA(J)-ZREFER) * ZSCALE )
1697 ! PFDATA(J)=OR (IPDATA,0)
1698 ! 600 CONTINUE
1699 !
1700  ilenfm = ilenf - irep
1701  CALL packgb (pfdata(irep+1),pfdata(irep+1),zrefer,zscale,ilenfm)
1702  CALL gsbyte_mf (kgrib(kword),pfdata(irep+1),ioff,kbits,0,ilenfm, &
1703  & knbit,'C',kleng,kerr,kword,.true.)
1704  IF (kerr.NE.0) THEN
1705  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1706  RETURN
1707  ENDIF
1708 !
1709 !
1710 !
1711 !
1712 !
1713 !
1714 !
1715 !
1716 !
1717 !
1718 !
1719 !***
1720 !* ENTER LENGTH OF BINARY DATA BLOCK, HAVING ENSURED THAT
1721 !* THE LENGTH IS AN EVEN NUMBER OF OCTETS.
1722 !***
1723 !
1724 ! LENGTH OF BINARY DATA BLOCK IN BITS.
1725 !
1726  ilbin = (kword-ipw) * knbit + ioff - ipb
1727 !
1728  il = mod(ilbin,16)
1729 !
1730 ! FILL UNUSED PORTION OF LAST 2 OCTETS WITH BINARY ZEROES.
1731 !
1732  ilnil = 0
1733 !
1734  IF (il.NE.0) THEN
1735  ilnil = 16 - il
1736  ilblock=iblock
1737  CALL sbyte_mf (kgrib(kword),ilblock(1),ioff,ilnil)
1738  CALL offset_mf (ioff,1,kword,ilnil,knbit,kleng,kerr)
1739  IF (kerr.NE.0) THEN
1740  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1741  RETURN
1742  ENDIF
1743  ENDIF
1744 !
1745  ilbin = (kword-ipw) * knbit + ioff - ipb
1746 !
1747 ! ENTER LENGTH - IN OCTETS - OF DATA BLOCK.
1748 !
1749  ilbin = ilbin / 8
1750  illbin=ilbin
1751  CALL sbyte_mf (kgrib(ipw),illbin,ipb,24)
1752  CALL offset_mf (ipb,1,ipw,24,knbit,kleng,kerr)
1753 !
1754 ! ENTER NUMBER OF UNUSED BITS IN FLAG/BIT COUNT FIELD.
1755 !
1756  iflag = iflag + ilnil
1757  ilflag=iflag
1758  CALL sbyte_mf (kgrib(ipw),ilflag,ipb,8)
1759 !
1760 !
1761 !
1762 !
1763 !
1764 !
1765 !
1766 !
1767 !
1768 !
1769 !
1770 !
1771 !
1772 !
1773 !
1774 !
1775 !
1776 !
1777 !
1778 !
1779 !********************************************************************
1780 !*
1781 !* BLOCK 5 - END BLOCK.
1782 !*
1783 !********************************************************************
1784 !
1785 !
1786 !***
1787 !* ADD 7 7 7 7 TO CODED DATA.
1788 !***
1789 !
1790  iblock(1) = 55
1791  iblock(2) = 55
1792  iblock(3) = 55
1793  iblock(4) = 55
1794 !
1795  ilblock=iblock
1796  CALL gsbyte_mf (kgrib(kword),ilblock(1),ioff,8,0,4, &
1797  & knbit,'C',kleng,kerr,kword,.false.)
1798  IF (kerr.NE.0) THEN
1799  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1800  RETURN
1801  ENDIF
1802 !
1803 !
1804 !***
1805 !* SET ANY UNUSED PART OF LAST WORD TO BINARY ZEROES.
1806 !***
1807 !
1808  IF (ioff.NE.knbit) &
1809  & THEN
1810  ibits = knbit - ioff
1811  ilblock=iblock
1812  CALL sbyte_mf (kgrib(kword),ilblock(5),ioff,ibits)
1813  ENDIF
1814 !
1815 !
1816 !
1817 !***
1818 !* ROUND TO 120 OCTETS, IF REQUIRED.
1819 !***
1820 !
1821  IF (kround.EQ.1) &
1822  & THEN
1823  inumbi = kword * knbit
1824  i = inumbi / 960
1825  i = i * 960
1826  i = inumbi - i
1827  IF (i.NE.0) i = (960 - i) / knbit
1828 !
1829  DO 700 j=kword+1,kword+i
1830  kgrib(j) = 0
1831  700 CONTINUE
1832 !
1833  kword = kword + i
1834  ENDIF
1835 !
1836  IF (lhook) CALL dr_hook('CODEGA',1,zhook_handle)
1837  ENDSUBROUTINE codega
gsbyte_mf
subroutine gsbyte_mf(KS, KD, KOFF, KSIZE, KSKBTW, K, KBPW,
Definition: gsbyte_mf.F:2
yomhook::dr_hook
Definition: yomhook.F90:20
codega
subroutine codega(PFDATA, KLENF, KBITS, KNBIT, KB1PAR,
Definition: codega.F:2
packgb
subroutine packgb(PFDATA, KPACKD, PREFER, PSCALE, KLENG)
Definition: packgb.F:2
confi
subroutine confi(PFVAL, KEXP, KMANT, PNFVAL)
Definition: confi.F:2
lfi_precision::jpdbld
integer, parameter jpdbld
Definition: lfi_precision.F90:23
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
prtbin_mf
subroutine prtbin_mf(KIN, KNBIT, KOUT, KERR)
Definition: prtbin_mf.F:2
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
mxmn_mf
subroutine mxmn_mf(PARRAY, KLEN, PMAX, PMIN)
Definition: mxmn_mf.F:2
sbyte_mf
subroutine sbyte_mf(KDEST, KSOURC, KOFSET, KBYTSZ)
Definition: sbyte_mf.F:2
offset_mf
subroutine offset_mf(KOFF, KVAL, KWORD, KBYTE, KNBIT, KLEN, KERR)
Definition: offset_mf.F:2
lfi_precision
Definition: lfi_precision.F90:1
confp_mf
subroutine confp_mf(PFVAL, KEXP, KMANT)
Definition: confp_mf.F:2
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13