SURFEX v8.1
General documentation of Surfex
facgrm.F90
Go to the documentation of this file.
1 SUBROUTINE facgrm_fort &
2 & (fa, krep, krang, cdpref, knivau, cdsuff, &
3 & pchamp, ldcosp, kgribh, ldundf, &
4 & pundf, klocsn)
5 USE fa_mod, ONLY : fa_com, jpniil, facadr, fafich, &
6  & ngrib2_glo_sh, ngrib2_glo_gp, ngrib2_lam_gp, &
7  & ngrib2_lam_bf, ngrib2_latlon, ngrib1_latlon, &
8  & lgrib2_lam_ex, nundef
9 USE parkind1, ONLY : jprb
10 USE yomhook , ONLY : lhook, dr_hook
11 USE lfi_precision
12 USE grib_api_interface
13 USE grib_api
14 IMPLICIT NONE
15 !****
16 ! Sous-programme INTERNE du logiciel de Fichiers ARPEGE:
17 ! PREPARATION (codage GRIB_API) d'un CHAMP HORIZONTAL
18 ! destine a etre ecrit sur un fichier ARPEGE/ALADIN.
19 !**
20 ! Arguments : KREP (Sortie) ==> Code-reponse du sous-programme;
21 ! KRANG (Entree) ==> Rang de l'unite logique;
22 ! CDPREF (Entree) ==> Prefixe eventuel du nom d'article;
23 ! KNIVAU (Entree) ==> Niveau vertical eventuel;
24 ! CDSUFF (Entree) ==> Suffixe eventuel du nom d'article;
25 ! ( Tableau ) PCHAMP (Entree) ==> Valeurs REELLES du champ a ecrire;
26 ! LDCOSP (Entree) ==> Vrai si le champ est represente
27 ! par des coefficients spectraux;
28 ! ( Tableau ) KGRIBH (Sortie) ==> Message GRIB
29 !*
30 !
31 TYPE(fa_com) :: FA
32 INTEGER (KIND=JPLIKB) KREP, KRANG, KNIVAU, KLOCSN
33 !
34 INTEGER (KIND=JPLIKM) KGRIBH
35 REAL (KIND=JPDBLR), TARGET :: PCHAMP(*)
36 REAL (KIND=JPDBLR) PUNDF, ZUNDF
37 !
38 LOGICAL LDCOSP, LDUNDF, LLCOSP, LLUNDF
39 !
40 CHARACTER CDPREF*(*), CDSUFF*(*)
41 !
42 REAL (KIND=JPDBLR), PARAMETER :: RPI = 2.0_jpdblr * asin(1.0_jpdblr)
43 !
44 type(facadr), POINTER :: ylcadr
45 type(fafich), POINTER :: ylfich
46 INTEGER (KIND=JPLIKB) :: IRANGC, INIMES, INUMER
47 INTEGER (KIND=JPLIKB) INGRIB, INBITS
48 CHARACTER(LEN=FA%JPLSPX) CLNSPR
49 CHARACTER(LEN=FA%JPXNOM) CLACTI
50 CHARACTER(LEN=FA%JPLMES) CLMESS
51 CHARACTER(LEN=FA%JPXNOM) CLNOMA
52 LOGICAL LLMLAM, LLLTLN, LLFATA, LLMGLO
53 INTEGER (KIND=JPLIKB) :: ILNOMA
54 INTEGER (KIND=JPLIKB) :: INGRIB_GP, INGRIB_SP
55 REAL (KIND=JPDBLR) :: ZMULTI ! Facteur multiplicatif
56 INTEGER :: ISTCUM ! Cumul depuis le debut
57 INTEGER :: ILOCAL
58 INTEGER :: IOUT
59 LOGICAL :: LLGRIB1
60 LOGICAL :: LLDOUBLE
61 
62 REAL (KIND=JPRB) :: ZHOOK_HANDLE
63 
64 IF (lhook) CALL dr_hook('FACGRM_MT',0,zhook_handle)
65 
66 lldouble = jpdblr == jpdbld
67 
68 CALL faigra_fort (fa)
69 
70 krep = 0
71 
72 ylfich => fa%FICHIER(krang)
73 irangc = ylfich%NUCADR
74 ylcadr => fa%CADRE(irangc)
75 !
76 llmlam = ylcadr%LIMLAM
77 llltln = ylcadr%SINLAT(2) < 0 .AND. llmlam
78 llmglo = (.NOT. llmlam) .AND. (.NOT. llltln)
79 !
80 llundf = ldundf
81 llcosp = ldcosp
82 !
83 inumer = ylfich%NULOGI
84 !
85 
86 ingrib = ylfich%NFGRIB
87 ingrib_gp = falgra_gp(ingrib)
88 ingrib_sp = falgra_sp(ingrib)
89 
90 IF (llcosp) THEN
91  ingrib = ingrib_sp
92 ELSE
93  ingrib = ingrib_gp
94 ENDIF
95 
96 
97 llgrib1 = falgra_ed(ingrib) == 1
98 
99 IF (llltln) THEN
100  IF (llgrib1) THEN
101  CALL igrib_clone (ngrib1_latlon, kgribh)
102  ELSE
103  CALL igrib_clone (ngrib2_latlon, kgribh)
104  ENDIF
105 ELSEIF (llmlam) THEN
106  IF (llcosp) THEN
107  CALL igrib_clone (ngrib2_lam_bf, kgribh)
108  ELSE
109  CALL igrib_clone (ngrib2_lam_gp, kgribh)
110  ENDIF
111 ELSEIF (llmglo) THEN
112  IF (llcosp) THEN
113  CALL igrib_clone (ngrib2_glo_sh, kgribh)
114  ELSE
115  CALL igrib_clone (ngrib2_glo_gp, kgribh)
116  ENDIF
117 ENDIF
118 
119 ! Set parameter
120 
121 CALL fagrib_api_set_param
122 
123 ! Horizontal geometry
124 
125 CALL fagrib_api_hgeom
126 
127 ! Vertical geometry
128 
129 CALL fagrib_api_vgeom
130 
131 ! Date
132 
133 CALL fagrib_api_date
134 
135 ! Set values
136 
137 CALL fagrib_api_set_values
138 
139 ! Set local section
140 
141 CALL fagrib_set_local_section
142 
143 1001 CONTINUE
144 !
145 llfata=llmoer(krep,krang)
146 !
147 IF (fa%LFAMOP.OR.llfata) THEN
148  inimes=2
149  clnspr='FACGRM'
150  inumer=jpniil
151 !
152  WRITE (unit=clmess,fmt='(''KREP='',I5,'', KRANG='',I4, &
153 & '', CDPREF='''''',A,'''''', KNIVAU='',I6, &
154 & '', CDSUFF='''''',A,'''''', LLCOSP= '',L1)') &
155 & krep, krang, cdpref(1:len_trim(cdpref)), knivau, &
156 & cdsuff(1:len_trim(cdsuff)), llcosp
157 
158  CALL faipar_fort &
159 & (fa, inumer,inimes,krep,.false.,clmess, &
160 & clnspr,clacti,.false.)
161 ENDIF
162 
163 IF (lhook) CALL dr_hook('FACGRM_MT',1,zhook_handle)
164 !
165 CONTAINS
166 
167 SUBROUTINE stru (CDS, CDU)
168 CHARACTER (LEN=*) :: CDS, CDU
169 INTEGER (KIND=JPLIKB) :: J
170 
171 DO j = 1, len(cdu)
172  cdu(j:j) = ' '
173 ENDDO
174 
175 DO j = 1, len_trim(cds)
176  IF (cds(j:j) == ' ') THEN
177  cdu(j:j) = '_'
178  ELSE
179  cdu(j:j) = cds(j:j)
180  ENDIF
181 ENDDO
182 
183 END SUBROUTINE stru
184 
185 #include "facom2.llmoer.h"
186 #include "falgra.h"
187 
188 SUBROUTINE fagrib_api_set_param
189 
190 CHARACTER(LEN=FA%JPXNOM) CLPREF, CLSUFF, CLNOMU
191 INTEGER(KIND=JPLIKB) INIVAU, IPARAM, IDPROC
192 INTEGER(KIND=JPLIKB) IMULTM, IMULTE
193 REAL (KIND=JPDBLR) ZLBASE, ZLMULT, ZLEVEL
194 
195 
196 CALL igrib_set_value (kgribh, 'centre', ylfich%NIDCEN)
197 
198 IF (llgrib1) THEN
199  CALL igrib_set_value (kgribh, 'setLocalDefinition', 1)
200 ELSE
201  CALL igrib_set_value (kgribh, 'grib2LocalSectionPresent', 1)
202  CALL igrib_set_value (kgribh, 'grib2LocalSectionNumber', klocsn)
203 ENDIF
204 
205 IF (ylfich%CMODEL /= '') THEN
206  CALL igrib_set_value (kgribh, 'faModelName', trim(ylfich%CMODEL))
207  CALL igrib_get_value (kgribh, 'generatingProcessIdentifier', idproc)
208  IF (idproc == 255) THEN
209  WRITE (fa%NULOUT, '(" FACGRM: Model `",A,"'' is not &
210  &declared in `faModelName.def''")') trim(ylfich%CMODEL)
211  ENDIF
212 ENDIF
213 
214 CALL fanfan_fort (fa, krep, inumer, cdpref, knivau, cdsuff, clnoma, ilnoma)
215 CALL faquin_fort (fa, krep, inumer, clpref, inivau, clsuff, clnoma, ilnoma)
216 
217 IF (knivau > 0) THEN
218  CALL stru (clpref, clnomu)
219  CALL igrib_set_value (kgribh, 'faLevelName', trim(clnomu))
220  CALL stru (clsuff, clnomu)
221  CALL igrib_set_value (kgribh, 'faFieldName', trim(clnomu))
222  CALL igrib_get_value (kgribh, 'ZLMULT', zlmult)
223  CALL igrib_get_value (kgribh, 'ZLBASE', zlbase)
224  zlevel = zlmult * inivau + zlbase
225  CALL igrib_set_value (kgribh, 'level', zlevel)
226 ELSE
227  CALL stru (clnoma, clnomu)
228  CALL igrib_set_value (kgribh, 'faFieldName', clnomu(1:ilnoma))
229 ENDIF
230 
231 IF (llgrib1) THEN
232  CALL igrib_get_value (kgribh, 'indicatorOfParameter', iparam)
233 ELSE
234  CALL igrib_get_value (kgribh, 'parameterNumber', iparam)
235 ENDIF
236 
237 IF (iparam == 255) THEN
238  WRITE (fa%NULOUT, '(" FACGRM: Field `",A,"'' is not &
239  &declared in `faFieldName.def''")') trim(clnoma)
240 ENDIF
241 
242 CALL igrib_get_value (kgribh, 'FMULTM', imultm)
243 CALL igrib_get_value (kgribh, 'FMULTE', imulte)
244 zmulti = REAL (IMULTM, JPDBLR) * 10._JPDBLR ** IMULTE
245 CALL igrib_get_value (kgribh, 'LSTCUM', istcum)
246 
247 END SUBROUTINE fagrib_api_set_param
248 
249 SUBROUTINE fagrib_api_hgeom
250 
251 IF (llltln) THEN
252  CALL fagrib_api_hgeom_latlon
253 ELSEIF (llmlam) THEN
254  IF (llcosp) THEN
255  CALL fagrib_api_hgeom_lam_bf
256  ELSE
257  CALL fagrib_api_hgeom_lam_gp
258  ENDIF
259 ELSEIF (llmglo) THEN
260  IF (llcosp) THEN
261  CALL fagrib_api_hgeom_glo_sh
262  ELSE
263  CALL fagrib_api_hgeom_glo_gp
264  ENDIF
265 ENDIF
266 
267 END SUBROUTINE fagrib_api_hgeom
268 
269 SUBROUTINE fagrib_api_hgeom_lam_bf
270 
271 REAL (KIND=JPDBLR) :: ZDELX, ZDELY, ZRPK
272 INTEGER (KIND=JPLIKB) :: ILONS, ILATS
273 
274 ilats = ylcadr%NLATIT
275 ilons = ylcadr%NXLOPA
276 zdelx = ylcadr%SINLAT (7)
277 zdely = ylcadr%SINLAT (8)
278 zrpk = ylcadr%SINLAT (2)
279 
280 IF (0._jpdblr < zrpk .AND. zrpk < 1._jpdblr) THEN
281 
282 ! Lambert
283 
284  CALL igrib_set_value (kgribh, 'gridType', 'lambert_bf')
285 
286 ELSEIF (zrpk == 0._jpdblr) THEN
287 
288 ! Mercator
289 
290  CALL igrib_set_value (kgribh, 'gridType', 'mercator_bf')
291 
292 ELSEIF (zrpk == 1._jpdblr) THEN
293 
294 ! Polar stereographic
295 
296  CALL igrib_set_value (kgribh, 'gridType', 'polar_stereographic_bf')
297 
298 ENDIF
299 
300 CALL igrib_set_value (kgribh, "biFourierResolutionParameterN", ylcadr%NSMAX)
301 CALL igrib_set_value (kgribh, "biFourierResolutionParameterM", ylcadr%NMSMAX)
302 
303 CALL igrib_set_value (kgribh, 'LxInMetres', zdelx * (ilons-1))
304 CALL igrib_set_value (kgribh, 'LyInMetres', zdely * (ilats-1))
305 
306 CALL igrib_set_value (kgribh, 'LuxInMetres', zdelx * (ylcadr%NLOPAR (4)-1))
307 CALL igrib_set_value (kgribh, 'LuyInMetres', zdely * (ylcadr%NLOPAR (6)-1))
308 
309 CALL igrib_set_value (kgribh, 'LcxInMetres', zdelx * max(1, ylcadr%NLOPAR (7)-1))
310 CALL igrib_set_value (kgribh, 'LcyInMetres', zdely * max(1, ylcadr%NLOPAR (8)-1))
311 
312 CALL igrib_set_value (kgribh, "biFourierTruncationType", 99)
313 
314 CALL fagrib_api_hgeom_lam_pr
315 
316 END SUBROUTINE fagrib_api_hgeom_lam_bf
317 
318 SUBROUTINE fagrib_api_hgeom_latlon
319 
320 INTEGER (KIND=JPLIKB) :: ILONS, ILATS
321 REAL (KIND=JPDBLR) :: ZLONW, ZLATS, ZLONE, ZLATN, ZLOND, ZLATD
322 
323 ilats = ylcadr%NLATIT
324 ilons = ylcadr%NXLOPA
325 
326 zlonw = lonrad2deg(ylcadr%SINLAT(13))
327 zlats = latrad2deg(ylcadr%SINLAT(14))
328 zlone = lonrad2deg(ylcadr%SINLAT(15))
329 zlatn = latrad2deg(ylcadr%SINLAT(16))
330 
331 zlond = modulo(zlone-zlonw, 360._jpdblr) / (ilons-1)
332 zlatd = (zlatn-zlats)/(ilats-1)
333 
334 CALL igrib_set_value (kgribh, 'Ni', ilons)
335 CALL igrib_set_value (kgribh, 'Nj', ilats)
336 CALL igrib_set_value (kgribh, 'longitudeOfFirstGridPointInDegrees', zlonw)
337 CALL igrib_set_value (kgribh, 'latitudeOfLastGridPointInDegrees', zlats)
338 CALL igrib_set_value (kgribh, 'longitudeOfLastGridPointInDegrees', zlone)
339 CALL igrib_set_value (kgribh, 'latitudeOfFirstGridPointInDegrees', zlatn)
340 CALL igrib_set_value (kgribh, 'iScansNegatively', 0)
341 CALL igrib_set_value (kgribh, 'jScansPositively', 0)
342 CALL igrib_set_value (kgribh, 'iDirectionIncrementInDegrees', zlond)
343 CALL igrib_set_value (kgribh, 'jDirectionIncrementInDegrees', zlatd)
344 
345 END SUBROUTINE fagrib_api_hgeom_latlon
346 
347 SUBROUTINE fagrib_api_hgeom_lam_gp
348 
349 REAL (KIND=JPDBLR) :: ZRPK, ZDELX, ZDELY
350 INTEGER (KIND=JPLIKB) :: ILONS, ILATS
351 INTEGER :: IRET
352 CHARACTER (LEN=4) :: CLEXT
353 
354 ilats = ylcadr%NLATIT
355 ilons = ylcadr%NXLOPA
356 zrpk = ylcadr%SINLAT (2)
357 zdelx = ylcadr%SINLAT (7)
358 zdely = ylcadr%SINLAT (8)
359 
360 IF (lgrib2_lam_ex) THEN
361  clext = '_lam'
362 ELSE
363  clext = ''
364 ENDIF
365 
366 IF (0._jpdblr < zrpk .AND. zrpk < 1._jpdblr) THEN
367 
368 ! Lambert
369 
370  CALL igrib_set_value (kgribh, 'gridType', trim('lambert'//clext))
371 
372  CALL igrib_set_value (kgribh, 'Nx', ilons)
373  CALL igrib_set_value (kgribh, 'Ny', ilats)
374  CALL igrib_set_value (kgribh, 'DxInMetres', zdelx)
375  CALL igrib_set_value (kgribh, 'DyInMetres', zdely)
376 
377  CALL igrib_set_value (kgribh, 'iScansNegatively', 0)
378  CALL igrib_set_value (kgribh, 'jScansPositively', 1)
379  CALL igrib_set_value (kgribh, 'jPointsAreConsecutive', 0)
380  CALL igrib_set_value (kgribh, 'uvRelativeToGrid', 1)
381 
382 ELSEIF (zrpk == 0._jpdblr) THEN
383 
384 ! Mercator
385 
386  CALL igrib_set_value (kgribh, 'gridType', trim('mercator'//clext))
387 
388  CALL igrib_set_value (kgribh, 'Nx', ilons)
389  CALL igrib_set_value (kgribh, 'Ny', ilats)
390  CALL igrib_set_value (kgribh, 'DiInMetres', zdelx)
391  CALL igrib_set_value (kgribh, 'DjInMetres', zdely)
392 
393  CALL igrib_set_value (kgribh, 'iScansNegatively', 0)
394  CALL igrib_set_value (kgribh, 'jScansPositively', 1)
395  CALL igrib_set_value (kgribh, 'jPointsAreConsecutive', 0)
396  CALL igrib_set_value (kgribh, 'uvRelativeToGrid', 1)
397 
398 ELSEIF (zrpk == 1._jpdblr) THEN
399 
400 ! Polar stereographic
401 
402  CALL igrib_set_value (kgribh, 'gridType', trim('polar_stereographic'//clext))
403 
404  CALL igrib_set_value (kgribh, 'Nx', ilons)
405  CALL igrib_set_value (kgribh, 'Ny', ilats)
406  CALL igrib_set_value (kgribh, 'DxInMetres', zdelx)
407  CALL igrib_set_value (kgribh, 'DyInMetres', zdely)
408 
409  CALL igrib_set_value (kgribh, 'iScansNegatively', 0)
410  CALL igrib_set_value (kgribh, 'jScansPositively', 1)
411  CALL igrib_set_value (kgribh, 'jPointsAreConsecutive', 0)
412 
413 ENDIF
414 
415 IF (lgrib2_lam_ex) THEN
416  CALL igrib_set_value (kgribh, 'Nux', ylcadr%NLOPAR (4))
417  CALL igrib_set_value (kgribh, 'Nuy', ylcadr%NLOPAR (6))
418  CALL igrib_set_value (kgribh, 'Ncx', ylcadr%NLOPAR (7))
419  CALL igrib_set_value (kgribh, 'Ncy', ylcadr%NLOPAR (8))
420 ENDIF
421 
422 CALL fagrib_api_hgeom_lam_pr
423 
424 END SUBROUTINE fagrib_api_hgeom_lam_gp
425 
426 SUBROUTINE fagrib_api_hgeom_lam_pr
427 
428 REAL (KIND=JPDBLR) :: ZRPK
429 
430 zrpk = ylcadr%SINLAT (2)
431 
432 IF (0._jpdblr < zrpk .AND. zrpk < 1._jpdblr) THEN
433 
434 ! Lambert
435 
436  CALL igrib_set_value (kgribh, 'latitudeOfFirstGridPointInDegrees', latrad2deg(ylcadr%SINLAT(14)))
437  CALL igrib_set_value (kgribh, 'longitudeOfFirstGridPointInDegrees', lonrad2deg(ylcadr%SINLAT(13)))
438  CALL igrib_set_value (kgribh, 'latitudeOfSouthernPoleInDegrees', 0._jpdblr)
439  CALL igrib_set_value (kgribh, 'longitudeOfSouthernPoleInDegrees', 0._jpdblr)
440  CALL igrib_set_value (kgribh, 'LaDInDegrees', latrad2deg(ylcadr%SINLAT (4)))
441  CALL igrib_set_value (kgribh, 'LoVInDegrees', lonrad2deg(ylcadr%SINLAT (3)))
442  CALL igrib_set_value (kgribh, 'Latin1InDegrees', latrad2deg(ylcadr%SINLAT (4)))
443  CALL igrib_set_value (kgribh, 'Latin2InDegrees', latrad2deg(ylcadr%SINLAT (4)))
444 
445  IF (ylcadr%SINLAT (4) > 0) THEN
446  CALL igrib_set_value (kgribh, 'projectionCentreFlag', 0)
447  ELSE
448  CALL igrib_set_value (kgribh, 'projectionCentreFlag', 128)
449  ENDIF
450 
451 ELSEIF (zrpk == 0._jpdblr) THEN
452 
453 ! Mercator
454 
455  CALL igrib_set_value (kgribh, 'latitudeOfFirstGridPointInDegrees', latrad2deg(ylcadr%SINLAT(14)))
456  CALL igrib_set_value (kgribh, 'longitudeOfFirstGridPointInDegrees', lonrad2deg(ylcadr%SINLAT(13)))
457  CALL igrib_set_value (kgribh, 'LaDInDegrees', latrad2deg(ylcadr%SINLAT (4)))
458  CALL igrib_set_value (kgribh, 'latitudeOfLastGridPointInDegrees', latrad2deg(ylcadr%SINLAT(16)))
459  CALL igrib_set_value (kgribh, 'longitudeOfLastGridPointInDegrees', lonrad2deg(ylcadr%SINLAT(15)))
460  CALL igrib_set_value (kgribh, 'orientationOfTheGridInDegrees', 0._jpdblr)
461 
462 ELSEIF (zrpk == 1._jpdblr) THEN
463 
464 ! Polar stereographic
465 
466  CALL igrib_set_value (kgribh, 'latitudeOfFirstGridPointInDegrees', latrad2deg(ylcadr%SINLAT(14)))
467  CALL igrib_set_value (kgribh, 'longitudeOfFirstGridPointInDegrees', lonrad2deg(ylcadr%SINLAT(13)))
468 
469  CALL igrib_set_value (kgribh, 'LaDInDegrees', latrad2deg(ylcadr%SINLAT (4)))
470  CALL igrib_set_value (kgribh, 'orientationOfTheGridInDegrees', lonrad2deg(ylcadr%SINLAT (3)))
471 
472  IF (ylcadr%SINLAT (4) > 0) THEN
473  CALL igrib_set_value (kgribh, 'projectionCentreFlag', 0)
474  ELSE
475  CALL igrib_set_value (kgribh, 'projectionCentreFlag', 128)
476  ENDIF
477 
478 ENDIF
479 
480 END SUBROUTINE fagrib_api_hgeom_lam_pr
481 
482 
483 REAL (KIND=JPDBLR) FUNCTION lonrad2deg (PLON)
484 REAL (KIND=JPDBLR), INTENT (IN) :: PLON
485 lonrad2deg = modulo(180._jpdblr/rpi * plon, 360._jpdblr)
486 END FUNCTION lonrad2deg
487 
488 REAL (KIND=JPDBLR) FUNCTION latrad2deg (PLAT)
489 REAL (KIND=JPDBLR), INTENT (IN) :: PLAT
490 latrad2deg = 180._jpdblr/rpi * plat
491 END FUNCTION latrad2deg
492 
493 SUBROUTINE fagrib_api_hgeom_glo_gp
494 
495 INTEGER (KIND=JPLIKB) :: ILATS, IDGNH, ILONS
496 INTEGER (KIND=JPLIKB), ALLOCATABLE :: ILOENG (:)
497 REAL (KIND=JPDBLR) :: ZNLAT, ZSLAT, ZVAL, ZLOCEN, ZMUCEN, ZSTRET
498 CHARACTER (LEN=32), PARAMETER :: CLGGGRIDTYPES (0:1,0:1,0:1) = &
499  & RESHAPE ( &
500  & (/ 'regular_gg ', 'reduced_gg ', &
501  & 'regular_stretched_gg ', 'reduced_stretched_gg ', &
502  & 'regular_rotated_gg ', 'reduced_rotated_gg ', &
503  & 'regular_stretched_rotated_gg ', 'reduced_stretched_rotated_gg ' /), &
504  & (/ 2, 2, 2 /))
505 integer (kind=jplikb) :: istr, irot, ired, i
506 
507 istr = min(ylcadr%NTYPTR, 1)
508 irot = max(ylcadr%NTYPTR-1, 0)
509 
510 zmucen = ylcadr%SSLAPO
511 zlocen = sign(acos(ylcadr%SCLOPO), ylcadr%SSLOPO)
512 zstret = ylcadr%SCODIL
513 
514 CALL igrib_set_value (kgribh, 'interpretationOfNumberOfPoints', 1)
515 CALL igrib_set_value (kgribh, 'global', 1)
516 
517 ilats = ylcadr%NLATIT
518 ilons = ylcadr%NXLOPA
519 idgnh = (ilats+1) / 2
520 znlat = asin(ylcadr%SINLAT (1))
521 zslat = - znlat
522 
523 ALLOCATE (iloeng(ilats))
524 
525 DO i = 1, ilats
526  IF (i <= idgnh) THEN
527  iloeng(i) = ylcadr%NLOPAR (i)
528  ELSE
529  iloeng(i) = ylcadr%NLOPAR (ilats-i+1)
530  ENDIF
531 ENDDO
532 
533 IF (any(iloeng /= iloeng(1))) THEN
534  ired = 1
535 ELSE
536  ired = 0
537 ENDIF
538 
539 CALL igrib_set_value (kgribh, 'gridType', trim(clgggridtypes(ired, istr, irot)))
540 
541 IF (ired == 0) THEN
542  CALL igrib_set_value(kgribh,'numberOfPointsAlongAParallel',ilons)
543  zval = 360.0_jpdblr/real(ilons, jpdblr)
544  CALL igrib_set_value(kgribh,'iDirectionIncrementInDegrees',zval)
545 ELSE
546  CALL igrib_set_value(kgribh,'pl',iloeng(1:ilats))
547 ENDIF
548 
549 DEALLOCATE (iloeng)
550 
551 CALL igrib_set_value(kgribh,'truncateDegrees',1)
552 CALL igrib_set_value(kgribh,'numberOfPointsAlongAMeridian',ilats)
553 zval = latrad2deg(znlat)
554 CALL igrib_set_value(kgribh,'latitudeOfFirstGridPointInDegrees',zval)
555 CALL igrib_set_value(kgribh,'longitudeOfFirstGridPointInDegrees',0)
556 zval = latrad2deg(zslat)
557 CALL igrib_set_value(kgribh,'latitudeOfLastGridPointInDegrees',zval)
558 zval=360._jpdblr-360._jpdblr/REAL(ilons,jpdblr)
559 CALL igrib_set_value(kgribh,'longitudeOfLastGridPointInDegrees',zval)
560 CALL igrib_set_value(kgribh,'numberOfParallelsBetweenAPoleAndTheEquator',idgnh)
561 
562 
563 IF (istr > 0) THEN
564  CALL igrib_set_value(kgribh,'stretchingFactor',zstret)
565 ENDIF
566 
567 IF (irot > 0) THEN
568  CALL igrib_set_value(kgribh,'latitudeOfStretchingPoleInDegrees', latrad2deg(asin(zmucen)))
569  CALL igrib_set_value(kgribh,'longitudeOfStretchingPoleInDegrees', lonrad2deg(zlocen))
570 ENDIF
571 
572 END SUBROUTINE fagrib_api_hgeom_glo_gp
573 
574 SUBROUTINE fagrib_api_hgeom_glo_sh
575 
576 REAL (KIND=JPDBLR) :: ZLOCEN, ZMUCEN, ZSTRET
577 CHARACTER (LEN=32), PARAMETER :: CLSHGRIDTYPES (0:1,0:1) = &
578  & RESHAPE ( &
579  & (/ 'sh ', 'stretched_sh ', &
580  & 'rotated_sh ', 'stretched_rotated_sh ' /), &
581  & (/ 2, 2 /))
582 integer (kind=jplikb) :: istr, irot, ired, ismax
583 
584 istr = min(ylcadr%NTYPTR, 1)
585 irot = max(ylcadr%NTYPTR-1, 0)
586 
587 zmucen = ylcadr%SSLAPO
588 zlocen = sign(acos(ylcadr%SCLOPO), ylcadr%SSLOPO)
589 zstret = ylcadr%SCODIL
590 
591 CALL igrib_set_value (kgribh, 'gridType', trim(clshgridtypes(istr, irot)))
592 
593 ismax = ylcadr%MTRONC
594 CALL igrib_set_value (kgribh, 'pentagonalResolutionParameterJ', ismax)
595 CALL igrib_set_value (kgribh, 'pentagonalResolutionParameterK', ismax)
596 CALL igrib_set_value (kgribh, 'pentagonalResolutionParameterM', ismax)
597 
598 IF (istr > 0) THEN
599  CALL igrib_set_value(kgribh,'stretchingFactor',zstret)
600 ENDIF
601 
602 IF (irot > 0) THEN
603  CALL igrib_set_value(kgribh,'latitudeOfStretchingPoleInDegrees', latrad2deg(asin(zmucen)))
604  CALL igrib_set_value(kgribh,'longitudeOfStretchingPoleInDegrees', lonrad2deg(zlocen))
605 ENDIF
606 
607 END SUBROUTINE fagrib_api_hgeom_glo_sh
608 
609 SUBROUTINE fagrib_api_vgeom
610 
611 REAL (KIND=JPDBLR), ALLOCATABLE :: ZVERT (:)
612 INTEGER (KIND=JPLIKB) :: IFLEVG
613 
614 IF (cdpref == 'S') THEN
615  iflevg = ylcadr%NNIVER
616  ALLOCATE (zvert(2*(iflevg+1)))
617  zvert(1:iflevg+1) = ylcadr%SFOHYB (1,0:iflevg) * ylcadr%SPREFE
618  zvert(iflevg+2:2*(iflevg+1)) = ylcadr%SFOHYB (2,0:iflevg)
619  CALL igrib_set_value (kgribh, 'pv', zvert)
620  DEALLOCATE (zvert)
621 ELSE
622  CALL igrib_set_value (kgribh, 'NV', 0)
623 ENDIF
624 
625 END SUBROUTINE fagrib_api_vgeom
626 
627 SUBROUTINE fagrib_api_date
628 
629 INTEGER (KIND=JPLIKB) :: IDATEF (22)
630 INTEGER (KIND=JPLIKB) :: ITRI
631 
632 
633 idatef(1:fa%JPLDAT) = ylfich%MADATE(:)
634 idatef(fa%JPLDAT+1:fa%JPLDAT*2) = ylfich%MADATX(:)
635 
636 IF (llgrib1) THEN
637  CALL igrib_set_value (kgribh, 'yearOfCentury', idatef( 1)-2000)
638 ELSE
639  CALL igrib_set_value (kgribh, 'year', idatef( 1))
640 ENDIF
641 
642 CALL igrib_set_value (kgribh, 'month', idatef( 2))
643 CALL igrib_set_value (kgribh, 'day', idatef( 3))
644 CALL igrib_set_value (kgribh, 'hour', idatef( 4))
645 CALL igrib_set_value (kgribh, 'minute',idatef( 5))
646 CALL igrib_set_value (kgribh, 'second',idatef(14)-60*(idatef(5)+60*idatef(4)))
647 
648 CALL igrib_get_value (kgribh, 'timeRangeIndicator', itri)
649 
650 CALL igrib_set_value (kgribh, 'indicatorOfUnitOfTimeRange', 's')
651 CALL igrib_set_value (kgribh, 'stepUnits', 's')
652 
653 IF (itri /= 0 .AND. istcum == 0) THEN
654  CALL igrib_set_value (kgribh, 'startStep', idatef(16))
655  CALL igrib_set_value (kgribh, 'endStep', idatef(15))
656 ELSEIF (itri /= 0 .AND. istcum == 1) THEN
657  CALL igrib_set_value (kgribh, 'startStep', 0)
658  CALL igrib_set_value (kgribh, 'endStep', idatef(15))
659 ELSEIF (itri == 0) THEN
660  CALL igrib_set_value (kgribh, 'endStep', idatef(15))
661 ELSE
662  krep = -82
663  RETURN
664 ENDIF
665 
666 
667 END SUBROUTINE fagrib_api_date
668 
669 SUBROUTINE fagrib_api_set_values
670 
671 REAL (KIND=JPDBLR), TARGET, ALLOCATABLE :: ZCHAMT (:) ! Temporary array for swapping directions of lat/lon fields
672 REAL (KIND=JPDBLR), TARGET, ALLOCATABLE :: ZCHAMS (:) ! PCHAMP * FMULTI
673 REAL (KIND=JPDBLR), POINTER :: ZCHAMP (:) ! Point either to PCHAMP or ZCHAMS
674 
675 
676 INTEGER (KIND=JPLIKB) :: ISMAX, IISMAX
677 INTEGER (KIND=JPLIKB) :: JN, IDX, JLON, JLAT, ILCHAM, ISTRF, ICUNDF
678 INTEGER (KIND=JPLIKB) :: IDECOPT
679 INTEGER (KIND=JPLIKB) :: INBITSMAX, IMAXIPREC
680 REAL (KIND=JPDBLR) :: ZUNDF, ZRNG, ZMIN, ZMAX
681 LOGICAL :: LLHSDF
682 
683 IF (lldouble) THEN
684  inbitsmax = 64
685  imaxiprec = 2
686 ELSE
687  inbitsmax = 32
688  imaxiprec = 1
689 ENDIF
690 
691 IF (llcosp) THEN
692  IF (llmlam) THEN
693  ilcham = ylcadr%NSFLAM
694  ELSE
695  ilcham=(1+ylcadr%MTRONC)*(2+ylcadr%MTRONC)
696  ENDIF
697 ELSE
698  ilcham = ylcadr%NVAPDG
699 ENDIF
700 
701 ! Changement d'echelle pour certains champs
702 
703 zundf = pundf
704 IF (zmulti /= real(1._4, jpdblr)) THEN
705  ALLOCATE (zchams(ilcham))
706  zchams = pchamp(1:ilcham) * zmulti
707  zundf = zundf * zmulti
708  zchamp => zchams(1:ilcham)
709 ELSE
710  zchamp => pchamp(1:ilcham)
711 ENDIF
712 
713 !
714 ! Traitement des valeurs indefinies; on verifie d'abord que le champ
715 ! contient de telles valeurs afin d'eviter de polluer le resultat
716 ! final avec un bitmap inutile
717 !
718 llhsdf = .true.
719 IF (llundf) THEN
720  icundf = count(zchamp == zundf)
721  llundf = icundf > 0
722  llhsdf = icundf < ilcham
723 ELSE
724  icundf = 0
725 ENDIF
726 
727 
728 IF (llcosp) THEN
729 
730  inbits = min(ylfich%NBFCSP, inbitsmax)
731 
732  IF (llmglo) THEN
733 
734  IF (inbits == inbitsmax) THEN
735  istrf = ylcadr%MTRONC
736  ELSE
737  istrf = ylfich%NSTROF
738  ENDIF
739 
740  CALL igrib_set_value (kgribh, 'bitsPerValue', inbits)
741  CALL igrib_set_value (kgribh, 'packingType', 'spectral_complex')
742  CALL igrib_set_value (kgribh, 'optimizeScaleFactor', 1)
743 
744  CALL igrib_set_value (kgribh, 'subSetJ', istrf)
745  CALL igrib_set_value (kgribh, 'subSetK', istrf)
746  CALL igrib_set_value (kgribh, 'subSetM', istrf)
747 
748  CALL igrib_set_value (kgribh, 'unpackedSubsetPrecision', imaxiprec)
749 
750  CALL igrib_set_value (kgribh, 'values', zchamp(1:ilcham))
751 
752  ELSEIF (llmlam) THEN
753 
754  istrf = ylfich%NSTROF
755 
756  CALL igrib_set_value (kgribh, "bitsPerValue", inbits)
757  CALL igrib_set_value (kgribh, "packingType", "bifourier_complex")
758  CALL igrib_set_value (kgribh, 'optimizeScaleFactor', 1)
759 
760  IF (inbits == inbitsmax) THEN
761  ismax = ylcadr%NSMAX
762  iismax = ylcadr%MTRONC
763  CALL igrib_set_value (kgribh, "biFourierResolutionSubSetParameterN", ismax)
764  CALL igrib_set_value (kgribh, "biFourierResolutionSubSetParameterM", iismax)
765  CALL igrib_set_value (kgribh, "biFourierSubTruncationType", 99)
766  ELSE
767  CALL igrib_set_value (kgribh, "biFourierResolutionSubSetParameterN", istrf)
768  CALL igrib_set_value (kgribh, "biFourierResolutionSubSetParameterM", istrf)
769  CALL igrib_set_value (kgribh, "biFourierSubTruncationType", 77)
770  ENDIF
771 
772  CALL igrib_set_value (kgribh, "biFourierDoNotPackAxes", 1)
773 
774  CALL igrib_set_value (kgribh, "unpackedSubsetPrecision", imaxiprec)
775 
776  CALL igrib_set_value (kgribh, 'values', zchamp(1:ilcham))
777 
778  ENDIF
779 
780 ELSE
781 
782  inbits = min(ylfich%NBFPDG, inbitsmax)
783 
784  IF (inbits == inbitsmax) THEN
785  IF (llgrib1) THEN
786  IF (lldouble) THEN
787  inbits = 63 ! 64bit simple packing does not work with grib_api
788  ENDIF
789  CALL igrib_set_value (kgribh, 'packingType', 'grid_simple')
790  CALL igrib_set_value (kgribh, 'optimizeScaleFactor', 1)
791  ELSE
792  CALL igrib_set_value (kgribh, 'packingType', 'grid_ieee')
793  CALL igrib_set_value (kgribh, 'precision', imaxiprec)
794  ENDIF
795  ELSE
796  CALL igrib_set_value (kgribh, 'bitsPerValue', inbits)
797  SELECT CASE (ingrib)
798  CASE (120, 160)
799  CALL igrib_set_value (kgribh, 'packingType', 'grid_simple')
800  CASE (140, 180)
801  IF (inbits > 30) THEN ! grib_api does appear to support 2nd order packing with more than 30 bits
802  CALL igrib_set_value (kgribh, 'packingType', 'grid_simple')
803  ELSE
804  CALL igrib_set_value (kgribh, 'packingType', 'grid_second_order')
805  ENDIF
806  CASE (200)
807  CALL igrib_set_value (kgribh, 'packingType', 'grid_complex_spatial_differencing')
808  CALL igrib_set_value (kgribh, 'orderOfSpatialDifferencing', 2)
809  CASE DEFAULT
810  krep = -96
811  RETURN
812  END SELECT
813  CALL igrib_set_value (kgribh, 'optimizeScaleFactor', 1)
814  ENDIF
815 
816  IF (llundf) THEN
817  CALL igrib_set_value (kgribh, 'bitmapPresent', 1)
818  CALL igrib_set_value (kgribh, 'missingValue', zundf)
819  ENDIF
820 
821  IF (.NOT. llgrib1) THEN
822 ! This line should not be necessary, but sometimes grib_api fails to update numberOfDataPoints
823  CALL igrib_set_value (kgribh, 'numberOfDataPoints', ilcham-icundf)
824  ENDIF
825 
826  IF (llltln) THEN
827 
828  ALLOCATE (zchamt(ilcham))
829 
830  DO jlat = 1, ylcadr%NLATIT
831  DO jlon = 1, ylcadr%NXLOPA
832  jn = jlon+ylcadr%NXLOPA*(jlat-1)
833  idx = jlon+ylcadr%NXLOPA*(ylcadr%NLATIT-jlat)
834  zchamt(idx) = zchamp(jn)
835  ENDDO
836  ENDDO
837 
838 
839  CALL igrib_set_value (kgribh, 'values', zchamt)
840 
841  DEALLOCATE (zchamt)
842 
843  ELSE
844  CALL igrib_set_value (kgribh, 'values', zchamp(1:ilcham))
845  ENDIF
846 
847 ENDIF
848 
849 IF (ALLOCATED (zchams)) DEALLOCATE (zchams)
850 
851 END SUBROUTINE fagrib_api_set_values
852 
853 SUBROUTINE fagrib_set_local_section
854 
855 CALL igrib_set_value (kgribh, 'CLNOMA', trim(clnoma(1:ilnoma)))
856 CALL igrib_set_value (kgribh, 'INGRIB', ingrib)
857 IF (llcosp) THEN
858  CALL igrib_set_value (kgribh, 'LLCOSP', 1)
859 ELSE
860  CALL igrib_set_value (kgribh, 'LLCOSP', 0)
861 ENDIF
862 CALL igrib_set_value (kgribh, 'INBITS', inbits)
863 
864 END SUBROUTINE fagrib_set_local_section
865 
866 END SUBROUTINE
867 
trim
static const char * trim(const char *name, int *n)
Definition: drhook.c:2383
lfi_precision::jplikb
integer, parameter jplikb
Definition: lfi_precision.F90:25
fa_mod::ngrib2_glo_sh
integer, save ngrib2_glo_sh
Definition: fa_mod.F90:466
facgrm_fort
subroutine facgrm_fort(FA, KREP, KRANG, CDPREF, KNIVAU, CDSUFF, PCHAMP, LDCOSP, KGRIBH, LDUNDF, PUNDF, KLOCSN)
Definition: facgrm.F90:5
fagrib_api_hgeom_latlon
subroutine fagrib_api_hgeom_latlon
Definition: facgrm.F90:319
fa_mod::ngrib2_lam_bf
integer, save ngrib2_lam_bf
Definition: fa_mod.F90:469
fa_mod::ngrib1_latlon
integer, save ngrib1_latlon
Definition: fa_mod.F90:470
fagrib_api_hgeom
subroutine fagrib_api_hgeom
Definition: facgrm.F90:250
latrad2deg
real(kind=jpdblr) function latrad2deg(PLAT)
Definition: facgrm.F90:489
fagrib_api_set_values
subroutine fagrib_api_set_values
Definition: facgrm.F90:670
fanfan_fort
subroutine fanfan_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, CDNOMA, KLNOMA)
Definition: fanfan.F90:6
yomhook::dr_hook
Definition: yomhook.F90:20
fa_mod::nundef
integer(kind=jplikb), parameter nundef
Definition: fa_mod.F90:36
fagrib_api_vgeom
subroutine fagrib_api_vgeom
Definition: facgrm.F90:610
fagrib_api_hgeom_glo_sh
subroutine fagrib_api_hgeom_glo_sh
Definition: facgrm.F90:575
fa_mod::ngrib2_lam_gp
integer, save ngrib2_lam_gp
Definition: fa_mod.F90:468
fagrib_api_hgeom_lam_gp
subroutine fagrib_api_hgeom_lam_gp
Definition: facgrm.F90:348
grib_api_interface::igrib_clone
subroutine, public igrib_clone(KHANDLE1, KHANDLE2)
Definition: grib_api_interface.F90:908
grib_api_interface::igrib_set_value
Definition: grib_api_interface.F90:36
integer
integer4 integer
Definition: privpub.h:351
faigra_fort
subroutine faigra_fort(FA)
Definition: faigra.F90:2
lfi_precision::jpdbld
integer, parameter jpdbld
Definition: lfi_precision.F90:23
fagrib_api_hgeom_lam_bf
subroutine fagrib_api_hgeom_lam_bf
Definition: facgrm.F90:270
fa_mod
Definition: fa_mod.F90:1
parkind1::jprb
integer, parameter jprb
Definition: parkind1.F90:32
fagrib_api_set_param
subroutine fagrib_api_set_param
Definition: facgrm.F90:189
fagrib_api_date
subroutine fagrib_api_date
Definition: facgrm.F90:628
lfi_precision::jpdblr
integer, parameter jpdblr
Definition: lfi_precision.F90:23
fa_mod::fafich
Definition: fa_mod.F90:204
fa_mod::ngrib2_glo_gp
integer, save ngrib2_glo_gp
Definition: fa_mod.F90:467
fagrib_set_local_section
subroutine fagrib_set_local_section
Definition: facgrm.F90:854
faquin_fort
subroutine faquin_fort(FA, KREP, KNUMER, CDPREF, KNIVAU, CDSUFF, CDNOMA, KLNOMA)
Definition: faquin.F90:6
fa_mod::facadr
Definition: fa_mod.F90:158
fagrib_api_hgeom_glo_gp
subroutine fagrib_api_hgeom_glo_gp
Definition: facgrm.F90:494
yomhook::lhook
logical lhook
Definition: yomhook.F90:15
fa_mod::ngrib2_latlon
integer, save ngrib2_latlon
Definition: fa_mod.F90:471
lonrad2deg
real(kind=jpdblr) function lonrad2deg(PLON)
Definition: facgrm.F90:484
fa_mod::lgrib2_lam_ex
logical, save lgrib2_lam_ex
Definition: fa_mod.F90:472
grib_api_interface
Definition: grib_api_interface.F90:1
stru
subroutine stru(CDS, CDU)
Definition: facgrm.F90:168
faipar_fort
subroutine faipar_fort(FA, KNUMER, KNIMES, KCODE, LDFATA, CDMESS, CDNSPR, CDACTI, LDRLFI)
Definition: faipar.F90:6
grib_api_interface::igrib_get_value
Definition: grib_api_interface.F90:30
fa_mod::fa_com
Definition: fa_mod.F90:252
count
static int count
Definition: memory_hook.c:21
lfi_precision
Definition: lfi_precision.F90:1
fa_mod::jpniil
integer(kind=jplikb), parameter jpniil
Definition: fa_mod.F90:31
real
real8 real
Definition: privpub.h:396
fagrib_api_hgeom_lam_pr
subroutine fagrib_api_hgeom_lam_pr
Definition: facgrm.F90:427
Generated on Tue Jan 16 2018 16:23:21 for SURFEX v8.1 by   doxygen 1.8.13