libsim  Versione8.0.0
gridinfo_class.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 
54 MODULE gridinfo_class
55 
56 USE grid_class
61 #ifdef HAVE_LIBGRIBAPI
62 USE grib_api
63 #endif
64 #ifdef HAVE_LIBGDAL
65 USE gdal
66 #endif
67 USE grid_id_class
68 use log4fortran
70 
71 
72 IMPLICIT NONE
73 
74 character (len=255),parameter:: subcategory="gridinfo_class"
75 
76 
78 TYPE gridinfo_def
79  TYPE(griddim_def) :: griddim
80  TYPE(datetime) :: time
81  TYPE(vol7d_timerange) :: timerange
82  TYPE(vol7d_level) :: level
83  TYPE(volgrid6d_var) :: var
84  TYPE(grid_id) :: gaid
85  TYPE(l4f_handle) :: category
86 END TYPE gridinfo_def
87 
88 INTEGER, PARAMETER :: &
89  cosmo_centre(3) = (/78,80,200/), & ! emission centres using COSMO coding
90  ecmwf_centre(1) = (/98/) ! emission centres using ECMWF coding
91 
93 INTERFACE init
94  MODULE PROCEDURE gridinfo_init
95 END INTERFACE
96 
98 INTERFACE delete
99  MODULE PROCEDURE gridinfo_delete
100 END INTERFACE
101 
104 INTERFACE clone
105  MODULE PROCEDURE gridinfo_clone
106 END INTERFACE
107 
110 INTERFACE import
111  MODULE PROCEDURE gridinfo_import, gridinfo_import_from_file
112 ! MODULE PROCEDURE import_time,import_timerange,import_level,import_gridinfo, &
113 ! import_volgrid6d_var,gridinfo_import_from_file
114 END INTERFACE
115 
117 INTERFACE export
118  MODULE PROCEDURE gridinfo_export, gridinfo_export_to_file
119 ! MODULE PROCEDURE export_time,export_timerange,export_level,export_gridinfo, &
120 ! export_volgrid6d_var
121 END INTERFACE
122 
125 INTERFACE display
126  MODULE PROCEDURE gridinfo_display, gridinfov_display
127 END INTERFACE
128 
131 INTERFACE decode_gridinfo
132  MODULE PROCEDURE gridinfo_decode_data
133 END INTERFACE
134 
136 INTERFACE encode_gridinfo
137  MODULE PROCEDURE gridinfo_encode_data
138 END INTERFACE
139 
140 #define ARRAYOF_ORIGTYPE TYPE(gridinfo_def)
141 #define ARRAYOF_TYPE arrayof_gridinfo
142 #define ARRAYOF_ORIGDESTRUCTOR(x) CALL delete(x)
143 #include "arrayof_pre.F90"
144 ! from arrayof
145 PUBLIC insert, append, remove, packarray
146 
147 PRIVATE
150 
151 CONTAINS
152 
153 #include "arrayof_post.F90"
154 
158 SUBROUTINE gridinfo_init(this, gaid, griddim, time, timerange, level, var, &
159  clone, categoryappend)
160 TYPE(gridinfo_def),intent(out) :: this
161 TYPE(grid_id),intent(in),optional :: gaid
162 type(griddim_def),intent(in),optional :: griddim
163 TYPE(datetime),intent(in),optional :: time
164 TYPE(vol7d_timerange),intent(in),optional :: timerange
165 TYPE(vol7d_level),intent(in),optional :: level
166 TYPE(volgrid6d_var),intent(in),optional :: var
167 logical , intent(in),optional :: clone
168 character(len=*),INTENT(in),OPTIONAL :: categoryappend
169 
170 character(len=512) :: a_name
171 
172 if (present(categoryappend))then
173  call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
174 else
175  call l4f_launcher(a_name,a_name_append=trim(subcategory))
176 end if
177 this%category=l4f_category_get_handle(a_name)
178 
179 #ifdef DEBUG
180 call l4f_category_log(this%category,l4f_debug,"start init gridinfo")
181 #endif
182 
183 if (present(gaid))then
184  if (optio_log(clone))then
185  CALL copy(gaid,this%gaid)
186  else
187  this%gaid = gaid
188  endif
189 else
190  this%gaid = grid_id_new()
191 end if
192 
193 !#ifdef DEBUG
194 !call l4f_category_log(this%category,L4F_DEBUG,"gaid present: "&
195 ! //to_char(c_e(this%gaid))//" value: "//to_char(this%gaid))
196 !#endif
197 
198 if (present(griddim))then
199  call copy(griddim,this%griddim)
200 else
201  call init(this%griddim,categoryappend=categoryappend)
202 end if
203 
204 if (present(time))then
205  this%time=time
206 else
207  call init(this%time)
208 end if
209 
210 if (present(timerange))then
211  this%timerange=timerange
212 else
213  call init(this%timerange)
214 end if
215 
216 if (present(level))then
217  this%level=level
218 else
219  call init(this%level)
220 end if
221 
222 if (present(var))then
223  this%var=var
224 else
225  call init(this%var)
226 end if
227 
228 END SUBROUTINE gridinfo_init
229 
230 
233 SUBROUTINE gridinfo_delete(this)
234 TYPE(gridinfo_def),intent(inout) :: this
235 
236 #ifdef DEBUG
237 call l4f_category_log(this%category,l4f_debug,"start delete_gridinfo" )
238 #endif
239 
240 call delete(this%griddim)
241 call delete(this%time)
242 call delete(this%timerange)
243 call delete(this%level)
244 call delete(this%var)
245 
246 #ifdef DEBUG
247 call l4f_category_log(this%category,l4f_debug,"delete gaid" )
248 #endif
249 CALL delete(this%gaid)
250 
251 !chiudo il logger
252 call l4f_category_delete(this%category)
253 
254 END SUBROUTINE gridinfo_delete
255 
256 
263 SUBROUTINE gridinfo_display(this, namespace)
264 TYPE(gridinfo_def),intent(in) :: this
265 CHARACTER (len=*),OPTIONAL :: namespace
266 
267 #ifdef DEBUG
268 call l4f_category_log(this%category,l4f_debug,"displaying gridinfo " )
269 #endif
270 
271 print*,"----------------------- gridinfo display ---------------------"
272 call display(this%griddim)
273 call display(this%time)
274 call display(this%timerange)
275 call display(this%level)
276 call display(this%var)
277 call display(this%gaid, namespace=namespace)
278 print*,"--------------------------------------------------------------"
280 END SUBROUTINE gridinfo_display
284 SUBROUTINE gridinfov_display(this, namespace)
285 TYPE(arrayof_gridinfo),INTENT(in) :: this
286 CHARACTER (len=*),OPTIONAL :: namespace
287 
288 INTEGER :: i
289 
290 print*,"----------------------- gridinfo array -----------------------"
292 DO i = 1, this%arraysize
293 
294 #ifdef DEBUG
295  CALL l4f_category_log(this%array(i)%category,l4f_debug, &
296  "displaying gridinfo array, element "//t2c(i))
297 #endif
298  CALL display(this%array(i), namespace)
299 
300 ENDDO
301 print*,"--------------------------------------------------------------"
303 END SUBROUTINE gridinfov_display
304 
305 
308 SUBROUTINE gridinfo_clone(this, that, categoryappend)
309 TYPE(gridinfo_def),INTENT(in) :: this
310 TYPE(gridinfo_def),INTENT(out) :: that
311 CHARACTER(len=*),INTENT(in),OPTIONAL :: categoryappend
312 
313 CALL init(that, gaid=this%gaid, griddim=this%griddim, time=this%time, &
314  timerange=this%timerange, level=this%level, var=this%var, clone=.true., &
315  categoryappend=categoryappend)
316 
317 END SUBROUTINE gridinfo_clone
318 
319 
327 SUBROUTINE gridinfo_import(this)
328 TYPE(gridinfo_def),INTENT(inout) :: this
330 #ifdef HAVE_LIBGRIBAPI
331 INTEGER :: gaid
332 #endif
333 #ifdef HAVE_LIBGDAL
334 TYPE(gdalrasterbandh) :: gdalid
335 #endif
336 
337 #ifdef DEBUG
338 call l4f_category_log(this%category,l4f_debug,"import from gaid")
339 #endif
340 
341 ! griddim is imported separately in grid_class
342 CALL import(this%griddim, this%gaid)
343 
344 #ifdef HAVE_LIBGRIBAPI
345 gaid = grid_id_get_gaid(this%gaid)
346 IF (c_e(gaid)) CALL gridinfo_import_gribapi(this, gaid)
347 #endif
348 #ifdef HAVE_LIBGDAL
349 gdalid = grid_id_get_gdalid(this%gaid)
350 IF (gdalassociated(gdalid)) CALL gridinfo_import_gdal(this, gdalid)
351 #endif
352 
353 END SUBROUTINE gridinfo_import
354 
355 
362 SUBROUTINE gridinfo_import_from_file(this, filename, categoryappend)
363 TYPE(arrayof_gridinfo) :: this
364 CHARACTER(len=*),INTENT(in) :: filename
365 CHARACTER(len=*),INTENT(in),OPTIONAL :: categoryappend
366 
367 type(gridinfo_def) :: gridinfol
368 INTEGER :: ngrid
369 TYPE(l4f_handle) :: category
370 CHARACTER(len=512) :: a_name
371 TYPE(grid_file_id) :: input_file
372 TYPE(grid_id) :: input_grid
374 IF (PRESENT(categoryappend)) THEN
375  CALL l4f_launcher(a_name,a_name_append= &
376  trim(subcategory)//"."//trim(categoryappend))
377 ELSE
378  CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
379 ENDIF
380 category=l4f_category_get_handle(a_name)
382 #ifdef DEBUG
383 CALL l4f_category_log(category,l4f_debug,"import from file")
384 #endif
385 
386 input_file = grid_file_id_new(filename, 'r')
387 
388 ngrid = 0
389 !$OMP PARALLEL DEFAULT(SHARED)
390 !$OMP MASTER
391 DO WHILE(.true.)
392  input_grid = grid_id_new(input_file)
393  IF (.NOT. c_e(input_grid)) EXIT
394 
395  CALL l4f_category_log(category,l4f_info,"import gridinfo")
396  ngrid = ngrid + 1
397 !$OMP TASK FIRSTPRIVATE(input_grid, ngrid), PRIVATE(gridinfol)
398  IF (PRESENT(categoryappend)) THEN
399  CALL init(gridinfol, gaid=input_grid, &
400  categoryappend=trim(categoryappend)//"-msg"//trim(to_char(ngrid)))
401  ELSE
402  CALL init(gridinfol, gaid=input_grid, &
403  categoryappend="msg"//trim(to_char(ngrid)))
404  ENDIF
405  CALL import(gridinfol)
406 !$OMP CRITICAL
407  CALL insert(this, gridinfol)
408 ! gridinfol is intentionally not destroyed, since now it lives into this
409 !$OMP END CRITICAL
410 !$OMP END TASK
411 ENDDO
412 !$OMP END MASTER
413 !$OMP END PARALLEL
414 
415 CALL packarray(this)
416 
417 CALL l4f_category_log(category,l4f_info, &
418  "gridinfo_import, "//t2c(ngrid)//" messages/bands imported from file "// &
419  trim(filename))
420 
421 ! close file
422 CALL delete(input_file)
423 ! close logger
424 CALL l4f_category_delete(category)
425 
426 END SUBROUTINE gridinfo_import_from_file
427 
428 
435 SUBROUTINE gridinfo_export(this)
436 TYPE(gridinfo_def),INTENT(inout) :: this
437 
438 #ifdef HAVE_LIBGRIBAPI
439 INTEGER :: gaid
440 #endif
441 #ifdef HAVE_LIBGDAL
442 !TYPE(gdalrasterbandh) :: gdalid
443 #endif
444 
445 #ifdef DEBUG
446 call l4f_category_log(this%category,l4f_debug,"export to gaid" )
447 #endif
448 
449 ! griddim is exported separately in grid_class
450 CALL export(this%griddim, this%gaid)
452 #ifdef HAVE_LIBGRIBAPI
453 IF (grid_id_get_driver(this%gaid) == 'grib_api') THEN
454  gaid = grid_id_get_gaid(this%gaid)
455  IF (c_e(gaid)) CALL gridinfo_export_gribapi(this, gaid)
456 ENDIF
457 #endif
458 #ifdef HAVE_LIBGDAL
459 IF (grid_id_get_driver(this%gaid) == 'gdal') THEN
460 !gdalid = grid_id_get_gdalid(this%gaid)
461  CALL l4f_category_log(this%category,l4f_warn,"export to gdal not implemented" )
462 ENDIF
463 #endif
464 
465 END SUBROUTINE gridinfo_export
466 
467 
473 SUBROUTINE gridinfo_export_to_file(this, filename, categoryappend)
474 TYPE(arrayof_gridinfo) :: this
475 CHARACTER(len=*),INTENT(in) :: filename
476 CHARACTER(len=*),INTENT(in),OPTIONAL :: categoryappend
477 
478 INTEGER :: i
479 TYPE(l4f_handle) :: category
480 CHARACTER(len=512) :: a_name
481 TYPE(grid_file_id) :: output_file
482 TYPE(grid_id) :: valid_grid_id
483 
484 IF (PRESENT(categoryappend)) THEN
485  CALL l4f_launcher(a_name,a_name_append= &
486  trim(subcategory)//"."//trim(categoryappend))
487 ELSE
488  CALL l4f_launcher(a_name,a_name_append=trim(subcategory))
489 ENDIF
490 category=l4f_category_get_handle(a_name)
492 #ifdef DEBUG
493 CALL l4f_category_log(category,l4f_debug, &
494  "exporting to file "//trim(filename)//" "//t2c(this%arraysize)//" fields")
495 #endif
496 
497 valid_grid_id = grid_id_new()
498 DO i = 1, this%arraysize ! find a valid grid_id in this
499  IF (c_e(this%array(i)%gaid)) THEN
500  valid_grid_id = this%array(i)%gaid
501  EXIT
502  ENDIF
503 ENDDO
505 IF (c_e(valid_grid_id)) THEN ! a valid grid_id has been found
506 ! open file
507  output_file = grid_file_id_new(filename, 'w', from_grid_id=valid_grid_id)
508  IF (c_e(output_file)) THEN
509 !$OMP PARALLEL DEFAULT(SHARED)
510 !$OMP MASTER
511  DO i = 1, this%arraysize
512 !$OMP TASK FIRSTPRIVATE(i)
513  CALL export(this%array(i)) ! export information to gaid
514 !$OMP CRITICAL
515  CALL export(this%array(i)%gaid, output_file) ! export gaid to file
516 !$OMP END CRITICAL
517 !$OMP END TASK
518  ENDDO
519 !$OMP END MASTER
520 !$OMP END PARALLEL
521 ! close file
522  CALL delete(output_file)
523  ELSE
524  CALL l4f_category_log(category,l4f_error,"opening file "//trim(filename))
525  CALL raise_error()
526  ENDIF
527 ELSE ! no valid grid_id has been found
528  CALL l4f_category_log(category,l4f_error, &
529  "gridinfo object of size "//t2c(this%arraysize))
530  CALL l4f_category_log(category,l4f_error, &
531  "no valid grid id found when exporting to file "//trim(filename))
532  CALL raise_error()
533 ENDIF
534 
535 !chiudo il logger
536 CALL l4f_category_delete(category)
537 
538 END SUBROUTINE gridinfo_export_to_file
539 
540 
549 FUNCTION gridinfo_decode_data(this) RESULT(field)
550 TYPE(gridinfo_def),INTENT(in) :: this
551 REAL :: field(this%griddim%dim%nx, this%griddim%dim%ny) ! array of decoded values
552 
553 CALL grid_id_decode_data(this%gaid, field)
554 
555 END FUNCTION gridinfo_decode_data
556 
557 
565 SUBROUTINE gridinfo_encode_data(this, field)
566 TYPE(gridinfo_def),INTENT(inout) :: this
567 REAL,intent(in) :: field(:,:)
568 
569 IF (SIZE(field,1) /= this%griddim%dim%nx &
570  .OR. SIZE(field,2) /= this%griddim%dim%ny) THEN
571  CALL l4f_category_log(this%category,l4f_error, &
572  'gridinfo_encode: field and gridinfo object non conformal, field: ' &
573  //trim(to_char(SIZE(field,1)))//'X'//trim(to_char(SIZE(field,2)))//', nx,ny:' &
574  //trim(to_char(this%griddim%dim%nx))//'X'//trim(to_char(this%griddim%dim%ny)))
575  CALL raise_error()
576  RETURN
577 ENDIF
578 
579 CALL grid_id_encode_data(this%gaid, field)
580 
581 END SUBROUTINE gridinfo_encode_data
582 
583 
584 ! =========================================
585 ! grib_api driver specific code
586 ! could this be moved to a separate module?
587 ! =========================================
588 #ifdef HAVE_LIBGRIBAPI
589 SUBROUTINE gridinfo_import_gribapi(this, gaid)
590 TYPE(gridinfo_def),INTENT(inout) :: this ! gridinfo object
591 INTEGER, INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to import
592 
593 call time_import_gribapi(this%time, gaid)
594 call timerange_import_gribapi(this%timerange,gaid)
595 call level_import_gribapi(this%level, gaid)
596 call var_import_gribapi(this%var, gaid)
597 
598 call normalize_gridinfo(this)
599 
600 END SUBROUTINE gridinfo_import_gribapi
601 
602 
603 ! grib_api driver
604 SUBROUTINE gridinfo_export_gribapi(this, gaid)
605 TYPE(gridinfo_def),INTENT(inout) :: this ! gridinfo object
606 INTEGER, INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to export
607 
608 TYPE(conv_func) :: c_func
609 REAL,ALLOCATABLE :: tmparr(:,:)
610 
611 ! convert variable and values to the correct edition if required
612 CALL volgrid6d_var_normalize(this%var, c_func, grid_id_new(grib_api_id=gaid))
613 IF (this%var == volgrid6d_var_miss) THEN
614  CALL l4f_log(l4f_error, &
615  'A suitable variable has not been found in table when converting template')
616  CALL raise_error()
617 ENDIF
618 IF (c_func /= conv_func_miss) THEN ! convert values as well
619  tmparr = decode_gridinfo(this) ! f2003 implicit allocation
620  CALL compute(c_func, tmparr)
621  CALL encode_gridinfo(this, tmparr)
622 ENDIF
623 
624 CALL unnormalize_gridinfo(this)
625 
626 CALL time_export_gribapi(this%time, gaid, this%timerange)
627 CALL timerange_export_gribapi(this%timerange, gaid, this%time)
628 CALL level_export_gribapi(this%level, gaid)
629 CALL var_export_gribapi(this%var, gaid)
630 
631 END SUBROUTINE gridinfo_export_gribapi
632 
633 
634 SUBROUTINE time_import_gribapi(this,gaid)
635 TYPE(datetime),INTENT(out) :: this ! datetime object
636 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to import
637 
638 INTEGER :: editionnumber, ttimeincr, tprocdata, centre, p2g, p2, unit, status
639 CHARACTER(len=9) :: date
640 CHARACTER(len=10) :: time
641 
642 CALL grib_get(gaid,'GRIBEditionNumber',editionnumber)
643 
644 IF (editionnumber == 1 .OR. editionnumber == 2) THEN
645 
646  CALL grib_get(gaid,'dataDate',date )
647  CALL grib_get(gaid,'dataTime',time(:5) )
648 
649  CALL init(this,simpledate=date(:8)//time(:4))
650 
651  IF (editionnumber == 2) THEN
652 
653  CALL grib_get(gaid,'typeOfProcessedData',tprocdata,status)
654  CALL grib_get(gaid,'typeOfTimeIncrement',ttimeincr,status)
655  IF (ttimeincr == 255) ttimeincr = 2 ! fix some MeteosWiss data
656 ! if analysis-like statistically processed data is encountered, the
657 ! reference time must be shifted to the end of the processing period
658  IF (status == grib_success .AND. ttimeincr == 1) THEN
659 ! old libsim convention, to be removed sometime in the future
660  CALL grib_get(gaid,'lengthOfTimeRange',p2g)
661  CALL grib_get(gaid,'indicatorOfUnitForTimeRange',unit)
662  CALL g2_interval_to_second(unit, p2g, p2)
663  this = this + timedelta_new(sec=p2)
664  ELSE IF (status == grib_success .AND. ttimeincr == 2 .AND. tprocdata == 0) THEN
665 ! generally accepted grib2 convention, DWD exception for cosmo
666 ! "accumulated" analysis is such that reftime points to the end of the
667 ! interval, so no time shift in that case
668  CALL grib_get(gaid,'lengthOfTimeRange',p2g)
669  CALL grib_get(gaid,'indicatorOfUnitForTimeRange',unit)
670  CALL g2_interval_to_second(unit, p2g, p2)
671  CALL grib_get(gaid,'centre',centre)
672  IF (centre /= 78) THEN
673  this = this + timedelta_new(sec=p2)
674  ENDIF
675  ELSE IF ((status == grib_success .AND. ttimeincr == 2) .OR. &
676  status /= grib_success) THEN ! usual case
677 ! do nothing
678  ELSE ! valid but unsupported typeOfTimeIncrement
679  CALL l4f_log(l4f_error,'typeOfTimeIncrement '//t2c(ttimeincr)// &
680  ' not supported')
681  CALL raise_error()
682  ENDIF
683  ENDIF
684 
685 ELSE
686  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
687  CALL raise_error()
688 
689 ENDIF
690 
691 END SUBROUTINE time_import_gribapi
692 
693 
694 SUBROUTINE time_export_gribapi(this, gaid, timerange)
695 TYPE(datetime),INTENT(in) :: this ! datetime object
696 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to export
697 TYPE(vol7d_timerange) :: timerange ! timerange, used for grib2 coding of statistically processed analysed data
698 
699 INTEGER :: editionnumber, centre
700 CHARACTER(len=8) :: env_var
701 LOGICAL :: g2cosmo_behavior
703 CALL grib_get(gaid,'GRIBEditionNumber',editionnumber)
704 
705 IF (editionnumber == 1) THEN
706 
707  CALL code_referencetime(this)
708 
709 ELSE IF (editionnumber == 2 )THEN
710 
711  IF (timerange%p1 >= timerange%p2) THEN ! forecast-like
712  CALL code_referencetime(this)
713  ELSE IF (timerange%p1 == 0) THEN ! analysis-like
714 ! ready for coding with general convention
715  CALL getenv('LIBSIM_G2COSMO_BEHAVIOR', env_var)
716  g2cosmo_behavior = len_trim(env_var) > 0
717  CALL grib_get(gaid,'centre',centre)
718  IF (g2cosmo_behavior .AND. centre == 78) THEN ! DWD analysis exception
719  CALL code_referencetime(this)
720  ELSE ! cosmo or old simc convention
721  CALL code_referencetime(this-timedelta_new(sec=timerange%p2))
722  ENDIF
723  ELSE ! bad timerange
724  CALL l4f_log( l4f_error, 'Timerange with 0>p1>p2 cannot be exported in grib2')
725  CALL raise_error()
726  ENDIF
727 
728 ELSE
729 
730  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
731  CALL raise_error()
732 
733 ENDIF
734 
735 CONTAINS
736 
737 SUBROUTINE code_referencetime(reftime)
738 TYPE(datetime),INTENT(in) :: reftime
739 
740 INTEGER :: date,time
741 CHARACTER(len=17) :: date_time
742 
743 ! datetime is AAAAMMGGhhmmssmsc
744 CALL getval(reftime, simpledate=date_time)
745 READ(date_time(:8),'(I8)')date
746 READ(date_time(9:12),'(I4)')time
747 CALL grib_set(gaid,'dataDate',date)
748 CALL grib_set(gaid,'dataTime',time)
749 
750 END SUBROUTINE code_referencetime
751 
752 END SUBROUTINE time_export_gribapi
753 
754 
755 SUBROUTINE level_import_gribapi(this, gaid)
756 TYPE(vol7d_level),INTENT(out) :: this ! vol7d_level object
757 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to import
758 
759 INTEGER :: EditionNumber,level1,l1,level2,l2
760 INTEGER :: ltype,ltype1,scalef1,scalev1,ltype2,scalef2,scalev2
761 
762 call grib_get(gaid,'GRIBEditionNumber',editionnumber)
763 
764 if (editionnumber == 1)then
765 
766  call grib_get(gaid,'indicatorOfTypeOfLevel',ltype)
767  call grib_get(gaid,'topLevel',l1)
768  call grib_get(gaid,'bottomLevel',l2)
769 
770  call level_g1_to_g2(ltype,l1,l2,ltype1,scalef1,scalev1,ltype2,scalef2,scalev2)
771 
772 else if (editionnumber == 2)then
773 
774  call grib_get(gaid,'typeOfFirstFixedSurface',ltype1)
775  call grib_get(gaid,'scaleFactorOfFirstFixedSurface',scalef1)
776  call grib_get(gaid,'scaledValueOfFirstFixedSurface',scalev1)
777  IF (scalef1 == -1 .OR. scalev1 == -1) THEN
778  scalef1 = imiss; scalev1 = imiss
779  ENDIF
780 
781  call grib_get(gaid,'typeOfSecondFixedSurface',ltype2)
782  call grib_get(gaid,'scaleFactorOfSecondFixedSurface',scalef2)
783  call grib_get(gaid,'scaledValueOfSecondFixedSurface',scalev2)
784  IF (scalef2 == -1 .OR. scalev2 == -1) THEN
785  scalef2 = imiss; scalev2 = imiss
786  ENDIF
787 
788 else
789 
790  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
791  CALL raise_error()
792 
793 end if
794 
795 ! Convert missing levels and units m -> mm
796 call level_g2_to_dballe(ltype1,scalef1,scalev1,ltype2,scalef2,scalev2, &
797  level1,l1,level2,l2)
798 
799 call init (this,level1,l1,level2,l2)
800 
801 END SUBROUTINE level_import_gribapi
802 
803 
804 SUBROUTINE level_export_gribapi(this, gaid)
805 TYPE(vol7d_level),INTENT(in) :: this ! vol7d_level object
806 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to export
807 
808 INTEGER :: EditionNumber, ltype1, scalef1, scalev1, ltype2, scalef2, scalev2, &
809  ltype, l1, l2
810 
811 CALL level_dballe_to_g2(this%level1, this%l1, this%level2, this%l2, &
812  ltype1, scalef1, scalev1, ltype2, scalef2, scalev2)
813 
814 call grib_get(gaid,'GRIBEditionNumber',editionnumber)
815 
816 if (editionnumber == 1)then
817 
818  CALL level_g2_to_g1(ltype1,scalef1,scalev1,ltype2,scalef2,scalev2,ltype,l1,l2)
819 
820  call grib_set(gaid,'indicatorOfTypeOfLevel',ltype)
821 ! it is important to set topLevel after, otherwise, in case of single levels
822 ! bottomLevel=0 overwrites topLevel (aliases in grib_api)
823  call grib_set(gaid,'bottomLevel',l2)
824  call grib_set(gaid,'topLevel',l1)
825 
826 else if (editionnumber == 2)then
828  CALL grib_set(gaid,'typeOfFirstFixedSurface',ltype1)
829  IF (.NOT.c_e(scalef1) .OR. .NOT.c_e(scalev1)) THEN ! code missing values correctly
830  CALL grib_set_missing(gaid,'scaleFactorOfFirstFixedSurface')
831  CALL grib_set_missing(gaid,'scaledValueOfFirstFixedSurface')
832  ELSE
833  CALL grib_set(gaid,'scaleFactorOfFirstFixedSurface',scalef1)
834  CALL grib_set(gaid,'scaledValueOfFirstFixedSurface',scalev1)
835  ENDIF
836 
837  CALL grib_set(gaid,'typeOfSecondFixedSurface',ltype2)
838  IF (ltype2 == 255 .OR. .NOT.c_e(scalef2) .OR. .NOT.c_e(scalev2)) THEN ! code missing values correctly
839  CALL grib_set_missing(gaid,'scaleFactorOfSecondFixedSurface')
840  CALL grib_set_missing(gaid,'scaledValueOfSecondFixedSurface')
841  ELSE
842  CALL grib_set(gaid,'scaleFactorOfSecondFixedSurface',scalef2)
843  CALL grib_set(gaid,'scaledValueOfSecondFixedSurface',scalev2)
844  ENDIF
845 
846 else
847 
848  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
849  CALL raise_error()
850 
851 end if
852 
853 END SUBROUTINE level_export_gribapi
854 
855 
856 SUBROUTINE timerange_import_gribapi(this, gaid)
857 TYPE(vol7d_timerange),INTENT(out) :: this ! vol7d_timerange object
858 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to import
859 
860 INTEGER :: EditionNumber, tri, unit, p1g, p2g, p1, p2, statproc, &
861  ttimeincr, tprocdata, status
862 
863 call grib_get(gaid,'GRIBEditionNumber',editionnumber)
864 
865 IF (editionnumber == 1) THEN
866 
867  CALL grib_get(gaid,'timeRangeIndicator',tri)
868  CALL grib_get(gaid,'P1',p1g)
869  CALL grib_get(gaid,'P2',p2g)
870  CALL grib_get(gaid,'indicatorOfUnitOfTimeRange',unit)
871  CALL timerange_g1_to_v7d(tri, p1g, p2g, unit, statproc, p1, p2)
872 
873 ELSE IF (editionnumber == 2) THEN
874 
875  CALL grib_get(gaid,'forecastTime',p1g)
876  CALL grib_get(gaid,'indicatorOfUnitOfTimeRange',unit)
877  CALL g2_interval_to_second(unit, p1g, p1)
878  call grib_get(gaid,'typeOfStatisticalProcessing',statproc,status)
879 
880  IF (status == grib_success .AND. statproc >= 0 .AND. statproc < 254) THEN ! statistically processed
881  CALL grib_get(gaid,'lengthOfTimeRange',p2g)
882  CALL grib_get(gaid,'indicatorOfUnitForTimeRange',unit)
883  CALL g2_interval_to_second(unit, p2g, p2)
884 
885 ! for forecast-like timeranges p1 has to be shifted to the end of interval
886  CALL grib_get(gaid,'typeOfProcessedData',tprocdata,status)
887  CALL grib_get(gaid,'typeOfTimeIncrement',ttimeincr)
888  IF (ttimeincr == 2 .AND. tprocdata /= 0) THEN
889  p1 = p1 + p2
890  ELSE
891  IF (p1 > 0) THEN
892  CALL l4f_log(l4f_warn,'Found p1>0 in grib2 analysis data, strange things may happen')
893  ENDIF
894  ENDIF
895  ELSE ! point in time
896  statproc = 254
897  p2 = 0
898 
899  ENDIF
900 
901 ELSE
902 
903  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
904  CALL raise_error()
906 ENDIF
907 
908 CALL init(this, statproc, p1, p2)
909 
910 END SUBROUTINE timerange_import_gribapi
911 
912 
913 SUBROUTINE timerange_export_gribapi(this, gaid, reftime)
914 TYPE(vol7d_timerange),INTENT(in) :: this ! vol7d_timerange object
915 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to export
916 TYPE(datetime) :: reftime ! reference time of data, used for coding correct end of statistical processing period in grib2
917 
918 INTEGER :: EditionNumber, centre, tri, currentunit, unit, p1_g1, p2_g1, p1, p2, pdtn
919 CHARACTER(len=8) :: env_var
920 LOGICAL :: g2cosmo_behavior
921 
922 CALL grib_get(gaid,'GRIBEditionNumber',editionnumber)
923 
924 IF (editionnumber == 1 ) THEN
925 ! Convert vol7d_timerange members to grib1 with reasonable time unit
926  CALL grib_get(gaid,'indicatorOfUnitOfTimeRange',currentunit)
927  CALL timerange_v7d_to_g1(this%timerange, this%p1, this%p2, &
928  tri, p1_g1, p2_g1, unit)
929 ! Set the native keys
930  CALL grib_set(gaid,'timeRangeIndicator',tri)
931  CALL grib_set(gaid,'P1',p1_g1)
932  CALL grib_set(gaid,'P2',p2_g1)
933  CALL grib_set(gaid,'indicatorOfUnitOfTimeRange',unit)
934 
935 ELSE IF (editionnumber == 2) THEN
936  CALL grib_get(gaid,'productDefinitionTemplateNumber', pdtn)
937 
938  IF (this%timerange == 254) THEN ! point in time -> template 4.0
939  IF (pdtn < 0 .OR. pdtn > 7) &
940  CALL grib_set(gaid,'productDefinitionTemplateNumber', 0)
941 ! Set reasonable time unit
942  CALL timerange_v7d_to_g2(this%p1,p1,unit)
943 ! Set the native keys
944  CALL grib_set(gaid,'indicatorOfUnitOfTimeRange',unit)
945  CALL grib_set(gaid,'forecastTime',p1)
946 
947  ELSE IF (this%timerange >= 0 .AND. this%timerange < 254) THEN
948 ! statistically processed -> template 4.8
949  IF (pdtn < 8 .OR. pdtn > 14) &
950  CALL grib_set(gaid,'productDefinitionTemplateNumber', 8)
951 
952  IF (this%p1 >= this%p2) THEN ! forecast-like
953 ! Set reasonable time unit
954  CALL timerange_v7d_to_g2(this%p1-this%p2,p1,unit)
955  CALL grib_set(gaid,'indicatorOfUnitOfTimeRange',unit)
956  CALL grib_set(gaid,'forecastTime',p1)
957  CALL code_endoftimeinterval(reftime+timedelta_new(sec=this%p1))
958 ! Successive times processed have same start time of forecast,
959 ! forecast time is incremented
960  CALL grib_set(gaid,'typeOfStatisticalProcessing',this%timerange)
961 ! typeOfTimeIncrement to be replaced with a check that typeOfProcessedData /= 0
962  CALL grib_set(gaid,'typeOfTimeIncrement',2)
963  CALL timerange_v7d_to_g2(this%p2,p2,unit)
964  CALL grib_set(gaid,'indicatorOfUnitForTimeRange',unit)
965  CALL grib_set(gaid,'lengthOfTimeRange',p2)
966 
967  ELSE IF (this%p1 == 0) THEN ! analysis-like
968 ! Set reasonable time unit
969  CALL timerange_v7d_to_g2(this%p2,p2,unit)
970  CALL grib_set(gaid,'indicatorOfUnitOfTimeRange',unit)
971  CALL grib_set(gaid,'forecastTime',0)
972  CALL code_endoftimeinterval(reftime)
973 ! Successive times processed have same forecast time, start time of
974 ! forecast is incremented
975  CALL grib_set(gaid,'typeOfStatisticalProcessing',this%timerange)
976 ! typeOfTimeIncrement to be replaced with typeOfProcessedData
977  CALL getenv('LIBSIM_G2COSMO_BEHAVIOR', env_var)
978  g2cosmo_behavior = len_trim(env_var) > 0
979  IF (g2cosmo_behavior) THEN
980  CALL grib_set(gaid,'typeOfProcessedData',0)
981  ELSE
982  CALL grib_set(gaid,'typeOfTimeIncrement',1)
983  ENDIF
984  CALL grib_set(gaid,'indicatorOfUnitForTimeRange',unit)
985  CALL grib_set(gaid,'lengthOfTimeRange',p2)
986 
987 ! warn about local use
988  IF (this%timerange >= 192) THEN
989  CALL l4f_log(l4f_warn, &
990  'coding in grib2 a nonstandard typeOfStatisticalProcessing '// &
991  t2c(this%timerange))
992  ENDIF
993  ELSE ! bad timerange
994  CALL l4f_log(l4f_error, &
995  'Timerange with 0>p1>p2 cannot be exported in grib2')
996  CALL raise_fatal_error()
997  ENDIF
998  ELSE
999  CALL l4f_log(l4f_error, &
1000  'typeOfStatisticalProcessing not supported: '//trim(to_char(this%timerange)))
1001  CALL raise_fatal_error()
1002  ENDIF
1003 
1004 ELSE
1005  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
1006  CALL raise_fatal_error()
1007 ENDIF
1008 
1009 CONTAINS
1010 
1011 ! Explicitely compute and code in grib2 template 4.8 the end of
1012 ! overalltimeinterval which is not done automatically by grib_api
1013 SUBROUTINE code_endoftimeinterval(endtime)
1014 TYPE(datetime),INTENT(in) :: endtime
1015 
1016 INTEGER :: year, month, day, hour, minute, msec
1017 
1018 CALL getval(endtime, year=year, month=month, day=day, &
1019  hour=hour, minute=minute, msec=msec)
1020  CALL grib_set(gaid,'yearOfEndOfOverallTimeInterval',year)
1021  CALL grib_set(gaid,'monthOfEndOfOverallTimeInterval',month)
1022  CALL grib_set(gaid,'dayOfEndOfOverallTimeInterval',day)
1023  CALL grib_set(gaid,'hourOfEndOfOverallTimeInterval',hour)
1024  CALL grib_set(gaid,'minuteOfEndOfOverallTimeInterval',minute)
1025  CALL grib_set(gaid,'secondOfEndOfOverallTimeInterval',msec/1000)
1026 
1027 END SUBROUTINE code_endoftimeinterval
1028 
1029 END SUBROUTINE timerange_export_gribapi
1030 
1031 
1032 SUBROUTINE var_import_gribapi(this, gaid)
1033 TYPE(volgrid6d_var),INTENT(out) :: this ! volgrid6d_var object
1034 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to import
1035 
1036 INTEGER :: EditionNumber, centre, discipline, category, number
1037 
1038 call grib_get(gaid,'GRIBEditionNumber',editionnumber)
1039 
1040 if (editionnumber == 1) then
1041 
1042  call grib_get(gaid,'centre',centre)
1043  call grib_get(gaid,'gribTablesVersionNo',category)
1044  call grib_get(gaid,'indicatorOfParameter',number)
1045 
1046  call init(this, centre, category, number)
1047 
1048 else if (editionnumber == 2) then
1049 
1050  call grib_get(gaid,'centre',centre)
1051  call grib_get(gaid,'discipline',discipline)
1052  call grib_get(gaid,'parameterCategory',category)
1053  call grib_get(gaid,'parameterNumber',number)
1054 
1055  call init(this, centre, category, number, discipline)
1056 
1057 else
1058 
1059  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
1060  CALL raise_error()
1061 
1062 endif
1063 
1064 END SUBROUTINE var_import_gribapi
1065 
1066 
1067 SUBROUTINE var_export_gribapi(this, gaid)
1068 TYPE(volgrid6d_var),INTENT(in) :: this ! volgrid6d_var object
1069 INTEGER,INTENT(in) :: gaid ! grib_api id of the grib loaded in memory to export
1070 
1071 INTEGER ::EditionNumber
1072 
1073 call grib_get(gaid,'GRIBEditionNumber',editionnumber)
1074 
1075 if (editionnumber == 1) then
1076 
1077  IF (this%centre /= 255) & ! if centre missing (coming from bufr), keep template
1078  CALL grib_set(gaid,'centre',this%centre)
1079  CALL grib_set(gaid,'gribTablesVersionNo',this%category)
1080  CALL grib_set(gaid,'indicatorOfParameter',this%number)
1081 
1082 else if (editionnumber == 2) then
1083 
1084 ! this must be changed to 65535!!!!
1085  IF (this%centre /= 255) & ! if centre missing (coming from bufr), keep template
1086  CALL grib_set(gaid,'centre',this%centre)
1087  CALL grib_set(gaid,'discipline',this%discipline)
1088  CALL grib_set(gaid,'parameterCategory',this%category)
1089  CALL grib_set(gaid,'parameterNumber',this%number)
1090 
1091 else
1093  CALL l4f_log(l4f_error,'GribEditionNumber '//t2c(editionnumber)//' not supported')
1094  CALL raise_error()
1095 
1096 end if
1097 
1098 END SUBROUTINE var_export_gribapi
1099 
1100 
1101 SUBROUTINE level_g2_to_dballe(ltype1,scalef1,scalev1,ltype2,scalef2,scalev2, lt1,l1,lt2,l2)
1102 integer,intent(in) :: ltype1,scalef1,scalev1,ltype2,scalef2,scalev2
1103 integer,intent(out) ::lt1,l1,lt2,l2
1104 
1105 
1106 CALL g2_to_dballe(ltype1, scalef1, scalev1, lt1, l1)
1107 CALL g2_to_dballe(ltype2, scalef2, scalev2, lt2, l2)
1109 CONTAINS
1110 
1111 SUBROUTINE g2_to_dballe(ltype, scalef, scalev, lt, l)
1112 integer,intent(in) :: ltype,scalef,scalev
1113 integer,intent(out) :: lt,l
1114 
1115 doubleprecision :: sl
1116 
1117 
1118 IF (ltype == 255 .OR. ltype == -1) THEN
1119  lt = imiss
1120  l = imiss
1121 ELSE IF (ltype <= 10 .OR. ltype == 101 .OR. (ltype >= 162 .AND. ltype <= 184)) THEN
1122  lt = ltype
1123  l = imiss
1124 ELSE
1125  lt = ltype
1126  IF (c_e(scalef) .AND. c_e(scalev)) THEN
1127  sl = scalev*(10.d0**(-scalef))
1128 ! apply unit conversions
1129  IF (any(ltype == height_level)) THEN
1130  l = nint(sl*1000.d0)
1131  ELSE IF (any(ltype == thermo_level)) THEN
1132  l = nint(sl*10.d0)
1133  ELSE IF (any(ltype == sigma_level)) THEN
1134  l = nint(sl*10000.d0)
1135  ELSE
1136  l = nint(sl)
1137  ENDIF
1138  ELSE
1139  l = imiss
1140  ENDIF
1141 ENDIF
1142 
1143 END SUBROUTINE g2_to_dballe
1144 
1145 END SUBROUTINE level_g2_to_dballe
1146 
1147 
1148 SUBROUTINE level_dballe_to_g2(lt1,l1,lt2,l2, ltype1,scalef1,scalev1,ltype2,scalef2,scalev2)
1149 integer,intent(in) :: lt1,l1,lt2,l2
1150 integer,intent(out) :: ltype1,scalef1,scalev1,ltype2,scalef2,scalev2
1151 
1152 CALL dballe_to_g2(lt1, l1, ltype1, scalef1, scalev1)
1153 CALL dballe_to_g2(lt2, l2, ltype2, scalef2, scalev2)
1154 
1155 CONTAINS
1156 
1157 SUBROUTINE dballe_to_g2(lt, l, ltype, scalef, scalev)
1158 INTEGER,INTENT(in) :: lt,l
1159 INTEGER,INTENT(out) :: ltype,scalef,scalev
1160 
1161 
1162 IF (lt == imiss) THEN
1163  ltype = 255
1164  scalev = 0
1165  scalef = 0
1166 ELSE IF (lt <= 10 .OR. lt == 101 .OR. (lt >= 162 .AND. lt <= 184)) THEN
1167  ltype = lt
1168  scalev = 0
1169  scalef = 0
1170 ELSE IF (lt == 256 .AND. l == imiss) THEN ! special case for cloud level -> surface
1171  ltype = 1
1172  scalev = 0
1173  scalef = 0
1174 ELSE
1175  ltype = lt
1176  scalev = l
1177  IF (any(ltype == height_level)) THEN
1178  scalef = 3
1179  ELSE IF (any(ltype == thermo_level)) THEN
1180  scalef = 1
1181  ELSE IF (any(ltype == sigma_level)) THEN
1182  scalef = 4
1183  ELSE
1184  scalef = 0
1185  ENDIF
1186 ENDIF
1187 
1188 !Caso generale reale
1189 !IF (ANY(ltype == height_level)) THEN
1190 ! sl=l/1000.D0
1191 !ELSE
1192 ! sl=l
1193 !END IF
1194 !IF (ABS(sl) < PRECISION) THEN
1195 ! scalef = 0
1196 ! scalev = 0
1197 !ELSE
1198 ! magn = LOG10(ABS(sl))
1199 ! DO scalef = magn, MAX(magn, 20)
1200 ! IF (ABS((sl*10.D0**(scalef) - ANINT(sl*10.D0**(scalef))) / &
1201 ! sl*10.D0**(scalef)) < PRECISION) EXIT
1202 ! ENDDO
1203 ! sl = scalev*(10.D0**(-scalef))
1204 !ENDIF
1205 
1206 END SUBROUTINE dballe_to_g2
1207 
1208 END SUBROUTINE level_dballe_to_g2
1209 
1210 
1211 SUBROUTINE level_g1_to_g2(ltype,l1,l2,ltype1,scalef1,scalev1,ltype2,scalef2,scalev2)
1212 integer,intent(in) :: ltype,l1,l2
1213 integer,intent(out) :: ltype1,scalef1,scalev1,ltype2,scalef2,scalev2
1214 
1215 ltype1=255
1216 scalef1=0
1217 scalev1=0
1218 ltype2=255
1219 scalef2=0
1220 scalev2=0
1221 
1222 if (ltype > 0 .and. ltype <= 9)then
1223  ltype1=ltype
1224 else if (ltype == 20) then
1225  ltype1=20
1226  scalev1=l1
1227  scalef1=2
1228 else if (ltype == 100) then
1229  ltype1=100
1230  scalev1=l1*100
1231 else if (ltype == 101) then
1232  ltype1=100
1233  scalev1=l1*1000
1234  ltype2=100
1235  scalev2=l2*1000
1236 else if (ltype == 102) then
1237  ltype1=101
1238 else if (ltype == 103) then
1239  ltype1=102
1240  scalev1=l1
1241 else if (ltype == 104) then
1242  ltype1=102
1243  scalev1=l1*100
1244  ltype2=102
1245  scalev2=l2*100
1246 else if (ltype == 105) then
1247  ltype1=103
1248  scalev1=l1
1249 else if (ltype == 106) then
1250  ltype1=103
1251  scalev1=l1*100
1252  ltype2=103
1253  scalev2=l2*100
1254 else if (ltype == 107) then
1255  ltype1=104
1256  scalef1=4
1257  scalev1=l1
1258 else if (ltype == 108) then
1259  ltype1=104
1260  scalef1=2
1261  scalev1=l1
1262  ltype2=104
1263  scalef2=2
1264  scalev2=l2
1265 else if (ltype == 109) then
1266  ltype1=105
1267  scalev1=l1
1268 else if (ltype == 110) then
1269  ltype1=105
1270  scalev1=l1
1271  ltype2=105
1272  scalev2=l2
1273 else if (ltype == 111) then
1274  ltype1=106
1275  scalef1=2
1276  scalev1=l1
1277 else if (ltype == 112) then
1278  ltype1=106
1279  scalef1=2
1280  scalev1=l1
1281  ltype2=106
1282  scalef2=2
1283  scalev2=l2
1284 else if (ltype == 113) then
1285  ltype1=107
1286  scalev1=l1
1287 else if (ltype == 114) then
1288  ltype1=107
1289  scalev1=475+l1
1290  ltype2=107
1291  scalev2=475+l2
1292 else if (ltype == 115) then
1293  ltype1=108
1294  scalev1=l1*100
1295 else if (ltype == 116) then
1296  ltype1=108
1297  scalev1=l1*100
1298  ltype2=108
1299  scalev2=l2*100
1300 else if (ltype == 117) then
1301  ltype1=109
1302  scalef1=9
1303  scalev1=l1
1304  if ( btest(l1,15) ) then
1305  scalev1=-1*mod(l1,32768)
1306  endif
1307 else if (ltype == 119) then
1308  ltype1=111
1309  scalef1=4
1310  scalev1=l1
1311 else if (ltype == 120) then
1312  ltype1=111
1313  scalef1=2
1314  scalev1=l1
1315  ltype2=111
1316  scalef2=2
1317  scalev2=l2
1318 else if (ltype == 121) then
1319  ltype1=100
1320  scalev1=(1100+l1)*100
1321  ltype2=100
1322  scalev2=(1100+l2)*100
1323 else if (ltype == 125) then
1324  ltype1=103
1325  scalef1=2
1326  scalev1=l1
1327 else if (ltype == 128) then
1328  ltype1=104
1329  scalef1=3
1330  scalev1=1100+l1
1331  ltype2=104
1332  scalef2=3
1333  scalev2=1100+l2
1334 else if (ltype == 141) then
1335  ltype1=100
1336  scalev1=l1*100
1337  ltype2=100
1338  scalev2=(1100+l2)*100
1339 else if (ltype == 160) then
1340  ltype1=160
1341  scalev1=l1
1342 else if (ltype == 200) then ! entire atmosphere
1343  ltype1=1
1344  ltype2=8
1345 else if (ltype == 210) then ! entire ocean
1346  ltype1=1
1347  ltype2=9
1348 else
1349 
1350  call l4f_log(l4f_error,'level_g1_to_g2: GRIB1 level '//trim(to_char(ltype)) &
1351  //' cannot be converted to GRIB2.')
1352  call raise_error()
1353 endif
1354 
1355 END SUBROUTINE level_g1_to_g2
1356 
1357 
1358 SUBROUTINE level_g2_to_g1(ltype1,scalef1,scalev1,ltype2,scalef2,scalev2,ltype,l1,l2)
1359 integer,intent(in) :: ltype1,scalef1,scalev1,ltype2,scalef2,scalev2
1360 integer,intent(out) :: ltype,l1,l2
1361 
1362 if (ltype1 > 0 .and. ltype1 <= 9 .and. ltype2 == 255) then ! simple
1363  ltype = ltype1
1364  l1 = 0
1365  l2 = 0
1366 else if (ltype1 == 20 .and. ltype2 == 255) then ! isothermal
1367  ltype = 2
1368  l1 = rescale2(scalef1-2,scalev1)!*100
1369  l2 = 0
1370 else if (ltype1 == 100 .and. ltype2 == 255) then ! isobaric
1371  ltype = 100
1372  l1 = rescale2(scalef1+2,scalev1)!/100
1373  l2 = 0
1374 else if (ltype1 == 100 .and. ltype2 == 100) then
1375  ltype = 101
1376  l1 = rescale1(scalef1+3,scalev1)!/1000
1377  l2 = rescale1(scalef2+3,scalev2)!/1000
1378 else if (ltype1 == 101 .and. ltype2 == 255) then
1379  ltype = 102
1380  l1 = 0
1381  l2 = 0
1382 else if (ltype1 == 102 .and. ltype2 == 255) then ! altitude over sea level
1383  ltype = 103
1384  l1 = rescale2(scalef1,scalev1)
1385  l2 = 0
1386 else if (ltype1 == 102 .and. ltype2 == 102) then
1387  ltype = 104
1388  l1 = rescale1(scalef1+2,scalev1)!/100
1389  l2 = rescale1(scalef2+2,scalev2)!/100
1390 else if (ltype1 == 103 .and. ltype2 == 255) then ! height over ground
1391  ltype = 105
1392  l1 = rescale2(scalef1,scalev1)
1393  l2 = 0
1394 else if (ltype1 == 103 .and. ltype2 == 103) then
1395  ltype = 106
1396  l1 = rescale1(scalef1+2,scalev1)!/100
1397  l2 = rescale1(scalef2+2,scalev2)!/100
1398 else if (ltype1 == 104 .and. ltype2 == 255) then ! sigma
1399  ltype = 107
1400  l1 = rescale2(scalef1,scalev1-4)!*10000
1401  l2 = 0
1402 else if (ltype1 == 104 .and. ltype2 == 104) then
1403  ltype = 108
1404  l1 = rescale1(scalef1-2,scalev1)!*100
1405  l2 = rescale1(scalef2-2,scalev2)!*100
1406 else if (ltype1 == 105 .and. ltype2 == 255) then ! hybrid
1407  ltype = 109
1408  l1 = rescale2(scalef1,scalev1)
1409  l2 = 0
1410 else if (ltype1 == 105 .and. ltype2 == 105) then
1411  ltype = 110
1412  l1 = rescale1(scalef1,scalev1)
1413  l2 = rescale1(scalef2,scalev2)
1414 else if (ltype1 == 106 .and. ltype2 == 255) then ! depth
1415  ltype = 111
1416  l1 = rescale2(scalef1-2,scalev1)!*100
1417  l2 = 0
1418 else if (ltype1 == 106 .and. ltype2 == 106) then
1419  ltype = 112
1420  l1 = rescale1(scalef1-2,scalev1)!*100
1421  l2 = rescale1(scalef2-2,scalev2)!*100
1422 else if (ltype1 == 107 .and. ltype2 == 255) then ! isentropic
1423  ltype = 113
1424  l1 = rescale2(scalef1,scalev1)
1425  l2 = 0
1426 else if (ltype1 == 107 .and. ltype2 == 107) then
1427  ltype = 114
1428  l1 = rescale1(scalef1,scalev1)
1429  l2 = rescale1(scalef2,scalev2)
1430 else if (ltype1 == 108 .and. ltype2 == 255) then ! pressure diff to ground
1431  ltype = 115
1432  l1 = rescale2(scalef1+2,scalev1)!/100
1433  l2 = 0
1434 else if (ltype1 == 108 .and. ltype2 == 108) then
1435  ltype = 116
1436  l1 = rescale1(scalef1+2,scalev1)!/100
1437  l2 = rescale1(scalef2+2,scalev2)!/100
1438 else if (ltype1 == 109 .and. ltype2 == 255) then ! potential vorticity surf
1439  ltype = 117
1440  l1 = rescale2(scalef1+9,scalev1)!/10**9
1441  l2 = 0
1442 else if (ltype1 == 111 .and. ltype2 == 255) then ! eta level
1443  ltype = 119
1444  l1 = rescale2(scalef1-2,scalev1)!*100
1445  l2 = 0
1446 else if (ltype1 == 111 .and. ltype2 == 111) then
1447  ltype = 120
1448  l1 = rescale1(scalef1-4,scalev1)!*10000
1449  l2 = rescale1(scalef2-4,scalev2)!*10000
1450 else if (ltype1 == 160 .and. ltype2 == 255) then ! depth below sea
1451  ltype = 160
1452  l1 = rescale2(scalef1,scalev1)
1453  l2 = 0
1454 else if (ltype1 == 1 .and. ltype2 == 8) then ! entire atmosphere
1455  ltype = 200
1456 else if (ltype1 == 1 .and. ltype2 == 9) then ! entire ocean
1457  ltype = 201
1458 else ! mi sono rotto per ora
1459 
1460  ltype = 255
1461  l1 = 0
1462  l2 = 0
1463  call l4f_log(l4f_error,'level_g2_to_g1: GRIB2 levels '//trim(to_char(ltype1))//' ' &
1464  //trim(to_char(ltype2))//' cannot be converted to GRIB1.')
1465  call raise_error()
1466 endif
1467 
1468 CONTAINS
1469 
1470 FUNCTION rescale1(scalef, scalev) RESULT(rescale)
1471 INTEGER,INTENT(in) :: scalef, scalev
1472 INTEGER :: rescale
1473 
1474 rescale = min(255, nint(scalev*10.0d0**(-scalef)))
1475 
1476 END FUNCTION rescale1
1477 
1478 FUNCTION rescale2(scalef, scalev) RESULT(rescale)
1479 INTEGER,INTENT(in) :: scalef, scalev
1480 INTEGER :: rescale
1481 
1482 rescale = min(65535, nint(scalev*10.0d0**(-scalef)))
1483 
1484 END FUNCTION rescale2
1485 
1486 END SUBROUTINE level_g2_to_g1
1487 
1488 ! Convert timerange from grib1 to grib2-like way:
1489 !
1490 ! Tri 2 (point in time) gives (hopefully temporarily) statproc 205.
1491 !
1492 ! Tri 13 (COSMO-nudging) gives p1 (forecast time) 0 and a temporary
1493 ! 257 statproc.
1494 !
1495 ! Further processing and correction of the values returned is
1496 ! performed in normalize_gridinfo.
1497 SUBROUTINE timerange_g1_to_v7d(tri, p1_g1, p2_g1, unit, statproc, p1, p2)
1498 INTEGER,INTENT(in) :: tri, p1_g1, p2_g1, unit
1499 INTEGER,INTENT(out) :: statproc, p1, p2
1500 
1501 IF (tri == 0 .OR. tri == 1) THEN ! point in time
1502  statproc = 254
1503  CALL g1_interval_to_second(unit, p1_g1, p1)
1504  p2 = 0
1505 ELSE IF (tri == 10) THEN ! point in time
1506  statproc = 254
1507  CALL g1_interval_to_second(unit, p1_g1*256+p2_g1, p1)
1508  p2 = 0
1509 ELSE IF (tri == 2) THEN ! somewhere between p1 and p2, not good for grib2 standard
1510  statproc = 205
1511  CALL g1_interval_to_second(unit, p2_g1, p1)
1512  CALL g1_interval_to_second(unit, p2_g1-p1_g1, p2)
1513 ELSE IF (tri == 3) THEN ! average
1514  statproc = 0
1515  CALL g1_interval_to_second(unit, p2_g1, p1)
1516  CALL g1_interval_to_second(unit, p2_g1-p1_g1, p2)
1517 ELSE IF (tri == 4) THEN ! accumulation
1518  statproc = 1
1519  CALL g1_interval_to_second(unit, p2_g1, p1)
1520  CALL g1_interval_to_second(unit, p2_g1-p1_g1, p2)
1521 ELSE IF (tri == 5) THEN ! difference
1522  statproc = 4
1523  CALL g1_interval_to_second(unit, p2_g1, p1)
1524  CALL g1_interval_to_second(unit, p2_g1-p1_g1, p2)
1525 ELSE IF (tri == 13) THEN ! COSMO-nudging, use a temporary value then normalize
1526  statproc = 257 ! check if 257 is legal!
1527  p1 = 0 ! analysis regardless of p2_g1
1528  CALL g1_interval_to_second(unit, p2_g1-p1_g1, p2)
1529 ELSE
1530  call l4f_log(l4f_error,'timerange_g1_to_g2: GRIB1 timerange '//trim(to_char(tri)) &
1531  //' cannot be converted to GRIB2.')
1532  CALL raise_error()
1533 ENDIF
1534 
1535 if (statproc == 254 .and. p2 /= 0 ) then
1536  call l4f_log(l4f_warn,"inconsistence in timerange:254,"//trim(to_char(p1))//","//trim(to_char(p2)))
1537 end if
1538 
1539 END SUBROUTINE timerange_g1_to_v7d
1540 
1541 
1542 !0 Minute
1543 !1 Hour
1544 !2 Day
1545 !3 Month
1546 !4 Year
1547 !5 Decade (10 years)
1548 !6 Normal (30 years)
1549 !7 Century(100 years)
1550 !8-9 Reserved
1551 !10 3 hours
1552 !11 6 hours
1553 !12 12 hours
1554 ! in COSMO, grib1:
1555 !13 = 15 minuti
1556 !14 = 30 minuti
1557 ! in grib2:
1558 !13 Second
1559 
1560 SUBROUTINE g1_interval_to_second(unit, valuein, valueout)
1561 INTEGER,INTENT(in) :: unit, valuein
1562 INTEGER,INTENT(out) :: valueout
1563 
1564 INTEGER,PARAMETER :: unitlist(0:14)=(/ 60,3600,86400,2592000, &
1565  31536000,315360000,946080000,imiss,imiss,imiss,10800,21600,43200,900,1800/)
1566 
1567 valueout = imiss
1568 IF (unit >= lbound(unitlist,1) .AND. unit <= ubound(unitlist,1)) THEN
1569  IF (c_e(unitlist(unit))) THEN
1570  valueout = valuein*unitlist(unit)
1571  ENDIF
1572 ENDIF
1573 
1574 END SUBROUTINE g1_interval_to_second
1575 
1576 
1577 SUBROUTINE g2_interval_to_second(unit, valuein, valueout)
1578 INTEGER,INTENT(in) :: unit, valuein
1579 INTEGER,INTENT(out) :: valueout
1580 
1581 INTEGER,PARAMETER :: unitlist(0:13)=(/ 60,3600,86400,2592000, &
1582  31536000,315360000,946080000,imiss,imiss,imiss,10800,21600,43200,1/)
1583 
1584 valueout = imiss
1585 IF (unit >= lbound(unitlist,1) .AND. unit <= ubound(unitlist,1)) THEN
1586  IF (c_e(unitlist(unit))) THEN
1587  valueout = valuein*unitlist(unit)
1588  ENDIF
1589 ENDIF
1590 
1591 END SUBROUTINE g2_interval_to_second
1592 
1593 
1594 ! Convert timerange from grib2-like to grib1 way:
1595 !
1596 ! Statproc 205 (point in time, non standard, not good in grib2) is
1597 ! correctly converted to tri 2.
1598 !
1599 ! Statproc 257 (COSMO nudging-like, non standard, not good in grib2)
1600 ! should not appear here, but is anyway converted to tri 13 (real
1601 ! COSMO-nudging).
1602 !
1603 ! In case p1_g1<0 (i.e. statistically processed analysis data, with
1604 ! p1=0 and p2>0), COSMO-nudging tri 13 is (mis-)used.
1605 SUBROUTINE timerange_v7d_to_g1(statproc, p1, p2, tri, p1_g1, p2_g1, unit)
1606 INTEGER,INTENT(in) :: statproc, p1, p2
1607 INTEGER,INTENT(out) :: tri, p1_g1, p2_g1, unit
1608 
1609 INTEGER :: ptmp, pdl
1610 
1611 pdl = p1 - p2
1612 IF (statproc == 254) pdl = p1 ! avoid unexpected situations (necessary?)
1613 
1614 CALL timerange_choose_unit_g1(p1, pdl, p2_g1, p1_g1, unit)
1615 IF (statproc == 0) THEN ! average
1616  tri = 3
1617 ELSE IF (statproc == 1) THEN ! accumulation
1618  tri = 4
1619 ELSE IF (statproc == 4) THEN ! difference
1620  tri = 5
1621 ELSE IF (statproc == 205) THEN ! point in time interval, not good for grib2 standard
1622  tri = 2
1623 ELSE IF (statproc == 257) THEN ! COSMO-nudging (statistical processing in the past)
1624 ! this should never happen (at least from COSMO grib1), since 257 is
1625 ! converted to something else in normalize_gridinfo; now a negative
1626 ! p1_g1 is set, it will be corrected in the next section
1627  tri = 13
1628 ! CALL second_to_gribtr(p1, p2_g1, unit, 1)
1629 ! CALL second_to_gribtr(p1-p2, p1_g1, unit, 1)
1630 ELSE IF (statproc == 254) THEN ! point in time
1631  tri = 0
1632  p2_g1 = 0
1633 ELSE
1634  CALL l4f_log(l4f_error,'timerange_v7d_to_g1: GRIB2 statisticalprocessing ' &
1635  //trim(to_char(statproc))//' cannot be converted to GRIB1.')
1636  CALL raise_error()
1637 ENDIF
1638 
1639 IF (p1_g1 > 255 .OR. p2_g1 > 255) THEN
1640  ptmp = max(p1_g1,p2_g1)
1641  p2_g1 = mod(ptmp,256)
1642  p1_g1 = ptmp/256
1643  IF (tri /= 0) THEN ! if not instantaneous give warning
1644  CALL l4f_log(l4f_warn,'timerange_v7d_to_g1: timerange too long for grib1 ' &
1645  //trim(to_char(ptmp))//', forcing time range indicator to 10.')
1646  ENDIF
1647  tri = 10
1648 ENDIF
1649 
1650 
1651 ! p1 < 0 is not allowed, use COSMO trick
1652 IF (p1_g1 < 0) THEN
1653  ptmp = p1_g1
1654  p1_g1 = 0
1655  p2_g1 = p2_g1 - ptmp
1656  tri = 13
1657 ENDIF
1658 
1659 END SUBROUTINE timerange_v7d_to_g1
1660 
1661 
1662 SUBROUTINE timerange_v7d_to_g2(valuein, valueout, unit)
1663 INTEGER,INTENT(in) :: valuein
1664 INTEGER,INTENT(out) :: valueout, unit
1665 
1666 IF (valuein == imiss) THEN
1667  valueout = imiss
1668  unit = 1
1669 ELSE IF (mod(valuein,3600) == 0) THEN ! prefer hours
1670  valueout = valuein/3600
1671  unit = 1
1672 ELSE IF (mod(valuein,60) == 0) THEN ! then minutes
1673  valueout = valuein/60
1674  unit = 0
1675 ELSE ! seconds
1676  valueout = valuein
1677  unit = 13
1678 ENDIF
1679 
1680 END SUBROUTINE timerange_v7d_to_g2
1681 
1682 
1683 ! These units are tested for applicability:
1684 ! 0 Minute
1685 ! 1 Hour
1686 ! 2 Day
1687 ! 10 3 hours
1688 ! 11 6 hours
1689 ! 12 12 hours
1690 SUBROUTINE timerange_choose_unit_g1(valuein1, valuein2, valueout1, valueout2, unit)
1691 INTEGER,INTENT(in) :: valuein1, valuein2
1692 INTEGER,INTENT(out) :: valueout1, valueout2, unit
1693 
1694 INTEGER :: i
1695 TYPE unitchecker
1696  INTEGER :: unit
1697  INTEGER :: sectounit
1698 END TYPE unitchecker
1699 
1700 TYPE(unitchecker),PARAMETER :: hunit(5) = (/ &
1701  unitchecker(1, 3600), unitchecker(10, 10800), unitchecker(11, 21600), &
1702  unitchecker(12, 43200), unitchecker(2, 86400) /)
1703 TYPE(unitchecker),PARAMETER :: munit(3) = (/ & ! 13 14 COSMO extensions
1704  unitchecker(0, 60), unitchecker(13, 900), unitchecker(14, 1800) /)
1705 
1706 unit = imiss
1707 IF (.NOT.c_e(valuein1) .OR. .NOT.c_e(valuein2)) THEN
1708  valueout1 = imiss
1709  valueout2 = imiss
1710  unit = 1
1711 ELSE IF (mod(valuein1,3600) == 0 .AND. mod(valuein2,3600) == 0) THEN ! prefer hours
1712  DO i = 1, SIZE(hunit)
1713  IF (mod(valuein1, hunit(i)%sectounit) == 0 &
1714  .AND. mod(valuein2, hunit(i)%sectounit) == 0 &
1715  .AND. valuein1/hunit(i)%sectounit < 255 &
1716  .AND. valuein2/hunit(i)%sectounit < 255) THEN
1717  valueout1 = valuein1/hunit(i)%sectounit
1718  valueout2 = valuein2/hunit(i)%sectounit
1719  unit = hunit(i)%unit
1720  EXIT
1721  ENDIF
1722  ENDDO
1723  IF (.NOT.c_e(unit)) THEN
1724 ! last chance, disable overflow check and start from longest unit,
1725  DO i = SIZE(hunit), 1, -1
1726  IF (mod(valuein1, hunit(i)%sectounit) == 0 &
1727  .AND. mod(valuein2, hunit(i)%sectounit) == 0) THEN
1728  valueout1 = valuein1/hunit(i)%sectounit
1729  valueout2 = valuein2/hunit(i)%sectounit
1730  unit = hunit(i)%unit
1731  EXIT
1732  ENDIF
1733  ENDDO
1734  ENDIF
1735 ELSE IF (mod(valuein1,60) == 0. .AND. mod(valuein2,60) == 0) THEN ! then minutes
1736  DO i = 1, SIZE(munit)
1737  IF (mod(valuein1, munit(i)%sectounit) == 0 &
1738  .AND. mod(valuein2, munit(i)%sectounit) == 0 &
1739  .AND. valuein1/munit(i)%sectounit < 255 &
1740  .AND. valuein2/munit(i)%sectounit < 255) THEN
1741  valueout1 = valuein1/munit(i)%sectounit
1742  valueout2 = valuein2/munit(i)%sectounit
1743  unit = munit(i)%unit
1744  EXIT
1745  ENDIF
1746  ENDDO
1747  IF (.NOT.c_e(unit)) THEN
1748 ! last chance, disable overflow check and start from longest unit,
1749  DO i = SIZE(munit), 1, -1
1750  IF (mod(valuein1, munit(i)%sectounit) == 0 &
1751  .AND. mod(valuein2, munit(i)%sectounit) == 0) THEN
1752  valueout1 = valuein1/munit(i)%sectounit
1753  valueout2 = valuein2/munit(i)%sectounit
1754  unit = munit(i)%unit
1755  EXIT
1756  ENDIF
1757  ENDDO
1758  ENDIF
1759 ENDIF
1760 
1761 IF (.NOT.c_e(unit)) THEN
1762  CALL l4f_log(l4f_error,'timerange_second_to_g1: cannot find a grib1 timerange unit for coding ' &
1763  //t2c(valuein1)//','//t2c(valuein2)//'s intervals' )
1764  CALL raise_error()
1765 ENDIF
1766 
1767 END SUBROUTINE timerange_choose_unit_g1
1768 
1769 
1770 ! Standardize variables and timerange in DB-all.e thinking:
1771 !
1772 ! Timerange 205 (point in time interval) is converted to maximum or
1773 ! minimum if parameter is recognized as such and parameter is
1774 ! corrected as well, otherwise 205 is kept (with possible error
1775 ! conditions later).
1776 !
1777 ! Timerange 257 (COSMO nudging) is converted to point in time if
1778 ! interval length is 0, or to a proper timerange if parameter is
1779 ! recognized as a COSMO statistically processed parameter (and in case
1780 ! of maximum or minimum the parameter is corrected as well); if
1781 ! parameter is not recognized, it is converted to instantaneous with a
1782 ! warning.
1783 SUBROUTINE normalize_gridinfo(this)
1784 TYPE(gridinfo_def),intent(inout) :: this
1785 
1786 IF (this%timerange%timerange == 254) THEN ! instantaneous
1787 
1788 !tmin
1789  IF (this%var == volgrid6d_var_new(255,2,16,255)) THEN
1790  this%var%number=11
1791  RETURN
1792  ENDIF
1793 
1794 !tmax
1795  IF (this%var == volgrid6d_var_new(255,2,15,255)) THEN
1796  this%var%number=11
1797  RETURN
1798  ENDIF
1799 
1800 ELSE IF (this%timerange%timerange == 205) THEN ! point in time interval
1801 
1802 !tmin
1803  IF (this%var == volgrid6d_var_new(255,2,16,255)) THEN
1804  this%var%number=11
1805  this%timerange%timerange=3
1806  RETURN
1807  ENDIF
1808 
1809 !tmax
1810  IF (this%var == volgrid6d_var_new(255,2,15,255)) THEN
1811  this%var%number=11
1812  this%timerange%timerange=2
1813  RETURN
1814  ENDIF
1815 
1816 ! it is accepted to keep 187 since it is wind gust, not max wind
1817  IF (this%var%discipline == 255 .AND. &
1818  any(this%var%centre == cosmo_centre)) THEN ! grib1 & COSMO
1819 
1820  IF (this%var%category == 201) THEN ! table 201
1821 
1822  IF (this%var%number == 187) THEN ! wind gust
1823 ! this%var%category=2
1824 ! this%var%number=32
1825  this%timerange%timerange=2
1826  ENDIF
1827  ENDIF
1828  ENDIF
1829 
1830 ELSE IF (this%timerange%timerange == 257) THEN ! COSMO-nudging
1831 
1832  IF (this%timerange%p2 == 0) THEN ! point in time
1833 
1834  this%timerange%timerange=254
1835 
1836  ELSE ! guess timerange according to parameter
1837 
1838  IF (this%var%discipline == 255 .AND. &
1839  any(this%var%centre == cosmo_centre)) THEN ! grib1 & COSMO
1840 
1841  IF (this%var%category >= 1 .AND. this%var%category <= 3) THEN ! WMO table 2
1842 
1843  if (this%var%number == 11) then ! T
1844  this%timerange%timerange=0 ! average
1845 
1846  else if (this%var%number == 15) then ! T
1847  this%timerange%timerange=2 ! maximum
1848  this%var%number=11 ! reset also parameter
1849 
1850  else if (this%var%number == 16) then ! T
1851  this%timerange%timerange=3 ! minimum
1852  this%var%number=11 ! reset also parameter
1853 
1854  else if (this%var%number == 17) then ! TD
1855  this%timerange%timerange=0 ! average
1856 
1857  else if (this%var%number == 33) then ! U
1858  this%timerange%timerange=0 ! average
1859 
1860  else if (this%var%number == 34) then ! V
1861  this%timerange%timerange=0 ! average
1862 
1863  else if (this%var%number == 57) then ! evaporation
1864  this%timerange%timerange=1 ! accumulated
1865 
1866  else if (this%var%number == 61) then ! TOT_PREC
1867  this%timerange%timerange=1 ! accumulated
1868 
1869  else if (this%var%number == 78) then ! SNOW_CON
1870  this%timerange%timerange=1 ! accumulated
1871 
1872  else if (this%var%number == 79) then ! SNOW_GSP
1873  this%timerange%timerange=1 ! accumulated
1874 
1875  else if (this%var%number == 90) then ! RUNOFF
1876  this%timerange%timerange=1 ! accumulated
1877 
1878  else if (this%var%number == 111) then ! fluxes
1879  this%timerange%timerange=0 ! average
1880  else if (this%var%number == 112) then
1881  this%timerange%timerange=0 ! average
1882  else if (this%var%number == 113) then
1883  this%timerange%timerange=0 ! average
1884  else if (this%var%number == 114) then
1885  this%timerange%timerange=0 ! average
1886  else if (this%var%number == 121) then
1887  this%timerange%timerange=0 ! average
1888  else if (this%var%number == 122) then
1889  this%timerange%timerange=0 ! average
1890  else if (this%var%number == 124) then
1891  this%timerange%timerange=0 ! average
1892  else if (this%var%number == 125) then
1893  this%timerange%timerange=0 ! average
1894  else if (this%var%number == 126) then
1895  this%timerange%timerange=0 ! average
1896  else if (this%var%number == 127) then
1897  this%timerange%timerange=0 ! average
1898 
1899  endif
1900 
1901  ELSE IF (this%var%category == 201) THEN ! table 201
1902 
1903  if (this%var%number == 5) then ! photosynthetic flux
1904  this%timerange%timerange=0 ! average
1905 
1906  else if (this%var%number == 20) then ! SUN_DUR
1907  this%timerange%timerange=1 ! accumulated
1908 
1909  else if (this%var%number == 22) then ! radiation fluxes
1910  this%timerange%timerange=0 ! average
1911  else if (this%var%number == 23) then
1912  this%timerange%timerange=0 ! average
1913  else if (this%var%number == 24) then
1914  this%timerange%timerange=0 ! average
1915  else if (this%var%number == 25) then
1916  this%timerange%timerange=0 ! average
1917  else if (this%var%number == 26) then
1918  this%timerange%timerange=0 ! average
1919  else if (this%var%number == 27) then
1920  this%timerange%timerange=0 ! average
1921 
1922  else if (this%var%number == 42) then ! water divergence
1923  this%timerange%timerange=1 ! accumulated
1924 
1925  else if (this%var%number == 102) then ! RAIN_GSP
1926  this%timerange%timerange=1 ! accumulated
1927 
1928  else if (this%var%number == 113) then ! RAIN_CON
1929  this%timerange%timerange=1 ! accumulated
1930 
1931  else if (this%var%number == 132) then ! GRAU_GSP
1932  this%timerange%timerange=1 ! accumulated
1933 
1934  else if (this%var%number == 135) then ! HAIL_GSP
1935  this%timerange%timerange=1 ! accumulated
1936 
1937  else if (this%var%number == 187) then ! UVMAX
1938 ! this%var%category=2 ! reset also parameter
1939 ! this%var%number=32
1940  this%timerange%timerange=2 ! maximum
1941 
1942  else if (this%var%number == 218) then ! maximum 10m dynamical gust
1943  this%timerange%timerange=2 ! maximum
1944 
1945  else if (this%var%number == 219) then ! maximum 10m convective gust
1946  this%timerange%timerange=2 ! maximum
1947 
1948  endif
1949 
1950  ELSE IF (this%var%category == 202) THEN ! table 202
1951 
1952  if (this%var%number == 231) then ! sso parameters
1953  this%timerange%timerange=0 ! average
1954  else if (this%var%number == 232) then
1955  this%timerange%timerange=0 ! average
1956  else if (this%var%number == 233) then
1957  this%timerange%timerange=0 ! average
1958  endif
1959 
1960  ELSE ! parameter not recognized, set instantaneous?
1961 
1962  call l4f_category_log(this%category,l4f_warn, &
1963  'normalize_gridinfo: found COSMO non instantaneous analysis 13,0,'//&
1964  trim(to_char(this%timerange%p2)))
1965  call l4f_category_log(this%category,l4f_warn, &
1966  'associated to an apparently instantaneous parameter '//&
1967  trim(to_char(this%var%centre))//','//trim(to_char(this%var%category))//','//&
1968  trim(to_char(this%var%number))//','//trim(to_char(this%var%discipline)))
1969  call l4f_category_log(this%category,l4f_warn, 'forcing to instantaneous')
1970 
1971  this%timerange%p2 = 0
1972  this%timerange%timerange = 254
1973 
1974  ENDIF ! category
1975  ENDIF ! grib1 & COSMO
1976  ENDIF ! p2
1977 ENDIF ! timerange
1978 
1979 IF (this%var%discipline == 255 .AND. &
1980  any(this%var%centre == ecmwf_centre)) THEN ! grib1 & ECMWF
1981 ! useful references:
1982 ! http://www.ecmwf.int/publications/manuals/libraries/tables/tables_index.html
1983 ! http://www.ecmwf.int/products/data/technical/soil/discret_soil_lay.html
1984 
1985  IF (this%var%category == 128) THEN ! table 128
1986 
1987  IF ((this%var%number == 142 .OR. & ! large scale precipitation
1988  this%var%number == 143 .OR. & ! convective precipitation
1989  this%var%number == 144 .OR. & ! total snow
1990  this%var%number == 228 .OR. & ! total precipitation
1991  this%var%number == 145 .OR. & ! boundary layer dissipation
1992  this%var%number == 146 .OR. & ! surface sensible heat flux
1993  this%var%number == 147 .OR. & ! surface latent heat flux
1994  this%var%number == 169) .AND. & ! surface solar radiation downwards
1995  this%timerange%timerange == 254) THEN
1996  this%timerange%timerange = 1 ! accumulated
1997  this%timerange%p2 = this%timerange%p1 ! length of period = forecast time
1998 
1999  ELSE IF ((this%var%number == 165 .OR. & ! 10m U
2000  this%var%number == 166) .AND. & ! 10m V
2001  this%level%level1 == 1) THEN
2002  this%level%level1 = 103
2003  this%level%l1 = 10000 ! 10m
2004 
2005  ELSE IF ((this%var%number == 167 .OR. & ! 2m T
2006  this%var%number == 168) .AND. & ! 2m Td
2007  this%level%level1 == 1) THEN
2008  this%level%level1 = 103
2009  this%level%l1 = 2000 ! 2m
2010 
2011  ELSE IF (this%var%number == 39 .OR. this%var%number == 139 .OR. this%var%number == 140) THEN ! SWVL1,STL1,SWL1
2012  this%level%level1 = 106 ! below surface
2013  this%level%l1 = 0
2014  this%level%l2 = 70 ! 7cm
2015 
2016  ELSE IF (this%var%number == 40 .OR. this%var%number == 170) THEN ! SWVL2,STL2 (STL2 wrong before 2000)
2017  this%level%level1 = 106 ! below surface
2018  this%level%l1 = 70
2019  this%level%l2 = 280
2020 
2021  ELSE IF (this%var%number == 171) THEN ! SWL2
2022  this%level%level1 = 106 ! below surface
2023  this%level%l1 = 70
2024  this%level%l2 = 210
2025 
2026  ELSE IF (this%var%number == 41 .OR. this%var%number == 183) THEN ! SWVL3,STL3 (STL3 wrong before 2000)
2027  this%level%level1 = 106 ! below surface
2028  this%level%l1 = 280
2029  this%level%l2 = 1000
2030 
2031  ELSE IF (this%var%number == 184) THEN ! SWL3
2032  this%level%level1 = 106 ! below surface
2033  this%level%l1 = 210
2034  this%level%l2 = 1000
2035 
2036  ELSE IF (this%var%number == 42 .OR. this%var%number == 236 .OR. this%var%number == 237) THEN ! SWVL4,STL4,SWL4
2037  this%level%level1 = 106 ! below surface
2038  this%level%l1 = 1000
2039  this%level%l2 = 2890
2040 
2041  ELSE IF (this%var%number == 121 .AND. &
2042  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! MX2T6
2043  this%timerange%timerange = 2 ! max
2044  this%timerange%p2 = 21600 ! length of period = 6 hours
2045  this%var%number=167 ! set to T2m, it could be 130 T as well
2046  this%level%level1 = 103
2047  this%level%l1 = 2000 ! 2m
2048 
2049  ELSE IF (this%var%number == 122 .AND. &
2050  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! MN2T6
2051  this%timerange%timerange = 3 ! min
2052  this%timerange%p2 = 21600 ! length of period = 6 hours
2053  this%var%number=1
2054  this%var%number=167 ! set to T2m, it could be 130 T as well
2055  this%level%level1 = 103
2056  this%level%l1 = 2000 ! 2m
2057 
2058  ELSE IF (this%var%number == 123 .AND. &
2059  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! 10FG6
2060  this%timerange%timerange = 2 ! max
2061  this%timerange%p2 = 21600 ! length of period = 6 hours
2062  this%level%level1 = 103
2063  this%level%l1 = 10000 ! 10m
2064 
2065 ! set cloud cover to bufr style
2066  ELSE IF (this%var%number == 186) THEN ! low cloud cover
2067  this%var%number = 248
2068  this%level = vol7d_level_new(level1=256, level2=258, l2=1)
2069  ELSE IF (this%var%number == 187) THEN ! medium cloud cover
2070  this%var%number = 248
2071  this%level = vol7d_level_new(level1=256, level2=258, l2=2)
2072  ELSE IF (this%var%number == 188) THEN ! high cloud cover
2073  this%var%number = 248
2074  this%level = vol7d_level_new(level1=256, level2=258, l2=3)
2075 
2076  ENDIF
2077  ELSE IF (this%var%category == 228) THEN ! table 228
2078 
2079  IF (this%var%number == 24) THEN
2080  this%level%level1 = 4 ! Level of 0C Isotherm
2081  this%level%l1 = 0
2082  this%level%level2 = 255
2083  this%level%l2 = 0
2084 
2085  ELSE IF (this%var%number == 26 .AND. &
2086  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! MX2T3
2087  this%timerange%timerange = 2 ! max
2088  this%timerange%p2 = 10800 ! length of period = 3 hours
2089  this%var%category = 128 ! reset to table version 128
2090  this%var%number=167 ! set to T2m, it could be 130 T as well
2091  this%level%level1 = 103
2092  this%level%l1 = 2000 ! 2m
2093 
2094  ELSE IF (this%var%number == 27 .AND. &
2095  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! MN2T3
2096  this%timerange%timerange = 3 ! min
2097  this%timerange%p2 = 10800 ! length of period = 3 hours
2098  this%var%category = 128 ! reset to table version 128
2099  this%var%number=167 ! set to T2m, it could be 130 T as well
2100  this%level%level1 = 103
2101  this%level%l1 = 2000 ! 2m
2102 
2103  ELSE IF (this%var%number == 28 .AND. &
2104  (this%timerange%timerange == 254 .OR. this%timerange%timerange == 205)) THEN ! 10FG3
2105  this%timerange%timerange = 2 ! max
2106  this%timerange%p2 = 10800 ! length of period = 3 hours
2107  this%level%level1 = 103
2108  this%level%l1 = 10000 ! 10m
2109 
2110  ENDIF
2111 
2112  ENDIF ! table 128
2113 ENDIF ! grib1 & ECMWF
2114 
2115 IF (this%var%discipline == 255 .AND. &
2116  this%var%category >= 1 .AND. this%var%category <= 3) THEN ! grib1 WMO table 2
2117 
2118 ! set cloud cover to bufr style
2119  IF (this%var%number == 73) THEN ! low cloud cover
2120  this%var%number = 71
2121  this%level = vol7d_level_new(level1=256, level2=258, l2=1)
2122  ELSE IF (this%var%number == 74) THEN ! medium cloud cover
2123  this%var%number = 71
2124  this%level = vol7d_level_new(level1=256, level2=258, l2=2)
2125  ELSE IF (this%var%number == 75) THEN ! high cloud cover
2126  this%var%number = 71
2127  this%level = vol7d_level_new(level1=256, level2=258, l2=3)
2128 
2129  ENDIF
2130 
2131 ENDIF
2132 
2133 
2134 END SUBROUTINE normalize_gridinfo
2135 
2136 
2137 ! Destandardize variables and timerange from DB-all.e thinking:
2138 !
2139 ! Parameters having maximum or minimum statistical processing and
2140 ! having a corresponding extreme parameter in grib table, are
2141 ! temporarily converted to timerange 205 and to the corresponding
2142 ! extreme parameter; if parameter is not recognized, the max or min
2143 ! statistical processing is kept (with possible error conditions
2144 ! later).
2145 SUBROUTINE unnormalize_gridinfo(this)
2146 TYPE(gridinfo_def),intent(inout) :: this
2147 
2148 IF (this%timerange%timerange == 3) THEN ! min
2149 
2150  IF (this%var == volgrid6d_var_new(255,2,11,255)) THEN ! tmin
2151  this%var%number=16
2152  this%timerange%timerange=205
2153 
2154  ELSE IF (any(this%var%centre == ecmwf_centre)) THEN ! ECMWF
2155  IF (this%var == volgrid6d_var_new(this%var%centre,128,167,255)) THEN ! tmin
2156  this%var%number=122
2157  this%timerange%timerange=205
2158 
2159  ENDIF
2160  ENDIF
2161 ELSE IF (this%timerange%timerange == 2) THEN ! max
2162 
2163  IF (this%var == volgrid6d_var_new(255,2,11,255)) THEN ! tmax
2164  this%var%number=15
2165  this%timerange%timerange=205
2166 
2167  ELSE IF (any(this%var%centre == ecmwf_centre)) THEN ! ECMWF
2168  IF (this%var == volgrid6d_var_new(this%var%centre,128,167,255)) THEN ! tmax
2169  this%var%number=121
2170  this%timerange%timerange=205
2171 
2172  ELSE IF(this%var == volgrid6d_var_new(this%var%centre,128,123,255)) THEN ! uvmax
2173  this%timerange%timerange=205
2174 
2175  ELSE IF(this%var == volgrid6d_var_new(this%var%centre,228,28,255)) THEN ! uvmax
2176  this%timerange%timerange=205
2177 
2178  ENDIF
2179  ELSE IF (any(this%var%centre == cosmo_centre)) THEN ! grib1 & COSMO
2180 
2181 ! wind
2182 ! it is accepted to keep 187 since it is wind gust, not max wind
2183 ! IF (this%var == volgrid6d_var_new(255,2,32,255)) THEN
2184 ! this%var%category=201
2185 ! this%var%number=187
2186 ! this%timerange%timerange=205
2187 ! ENDIF
2188  IF (this%var == volgrid6d_var_new(this%var%centre,201,187,255)) THEN
2189  this%timerange%timerange=205
2190  ENDIF
2191  ENDIF
2192 ENDIF
2193 
2194 ! reset cloud cover to grib1 style
2195 IF (this%var%discipline == 255 .AND. this%var%category == 2) THEN ! grib1 table 2
2196  IF (this%var%number == 71 .AND. &
2197  this%level%level1 == 256 .AND. this%level%level2 == 258) THEN ! l/m/h cloud cover
2198  IF (this%level%l2 == 1) THEN ! l
2199  this%var%number = 73
2200  ELSE IF (this%level%l2 == 2) THEN ! m
2201  this%var%number = 74
2202  ELSE IF (this%level%l2 == 3) THEN ! h
2203  this%var%number = 75
2204  ENDIF
2205  this%level = vol7d_level_new(level1=1) ! reset to surface
2206  ENDIF
2207 ENDIF
2208 
2209 IF (any(this%var%centre == ecmwf_centre)) THEN ! ECMWF
2210 ! reset cloud cover to grib1 style
2211  IF (this%var%discipline == 255 .AND. this%var%category == 128) THEN ! grib1 table 128
2212  IF ((this%var%number == 248 .OR. this%var%number == 164) .AND. &
2213  this%level%level1 == 256 .AND. this%level%level2 == 258) THEN ! l/m/h cloud cover
2214  IF (this%level%l2 == 1) THEN ! l
2215  this%var%number = 186
2216  ELSE IF (this%level%l2 == 2) THEN ! m
2217  this%var%number = 187
2218  ELSE IF (this%level%l2 == 3) THEN ! h
2219  this%var%number = 188
2220  ENDIF
2221  this%level = vol7d_level_new(level1=1) ! reset to surface
2222  ENDIF
2223  ENDIF
2224 ENDIF
2225 
2226 END SUBROUTINE unnormalize_gridinfo
2227 #endif
2228 
2229 
2230 ! =========================================
2231 ! gdal driver specific code
2232 ! could this be moved to a separate module?
2233 ! =========================================
2234 #ifdef HAVE_LIBGDAL
2235 SUBROUTINE gridinfo_import_gdal(this, gdalid)
2236 TYPE(gridinfo_def),INTENT(inout) :: this ! gridinfo object
2237 TYPE(gdalrasterbandh),INTENT(in) :: gdalid ! gdal rasterband pointer
2238 
2239 TYPE(gdaldataseth) :: hds
2240 
2241 
2242 !call time_import_gdal(this%time, gaid)
2243 this%time = datetime_new(year=2010, month=1, day=1) ! conventional year
2244 
2245 !call timerange_import_gdal(this%timerange,gaid)
2246 this%timerange = vol7d_timerange_new(254, 0, 0) ! instantaneous data
2247 
2248 !call level_import_gdal(this%level, gaid)
2249 hds = gdalgetbanddataset(gdalid) ! go back to dataset
2250 IF (gdalgetrastercount(hds) == 1) THEN ! single level dataset
2251  this%level = vol7d_level_new(1, 0) ! surface
2252 ELSE
2253  this%level = vol7d_level_new(105, gdalgetbandnumber(gdalid)) ! hybrid level
2254 ENDIF
2255 
2256 !call var_import_gdal(this%var, gaid)
2257 this%var = volgrid6d_var_new(centre=255, category=2, number=8) ! topography height
2258 
2259 END SUBROUTINE gridinfo_import_gdal
2260 #endif
2261 
2262 
2263 END MODULE gridinfo_class
2264 
2265 
2270 
2271 
Export gridinfo descriptors information into a grid_id object.
Derived type defining a dynamically extensible array of TYPE(gridinfo_def) elements.
Functions that return a trimmed CHARACTER representation of the input variable.
Derived type associated to a block/message/record/band of gridded data coming from a file-like object...
Method for removing elements of the array at a desired position.
Class for expressing an absolute time value.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Derived type associated to a file-like object containing many blocks/messages/records/bands of gridde...
This module defines an abstract interface to different drivers for access to files containing gridded...
Module for describing geographically referenced regular grids.
Definition: grid_class.F90:247
Decode and return the data array from a grid_id object associated to a gridinfo object.
Encode a data array into a grid_id object associated to a gridinfo object.
Import information from a file or grid_id object into the gridinfo descriptors.
Classi per la gestione delle coordinate temporali.
Destructor, it releases every information associated with the object.
Definisce l&#39;intervallo temporale di un&#39;osservazione meteo.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Quick method to append an element to the array.
Restituiscono il valore dell&#39;oggetto in forma di stringa stampabile.
Restituiscono il valore dell&#39;oggetto nella forma desiderata.
Operatore di resto della divisione.
Class for managing information about a single gridded georeferenced field, typically imported from an...
Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. ...
Method for packing the array object reducing at a minimum the memory occupation, without destroying i...
Object describing a single gridded message/band.
Display on standard output a description of the gridinfo object provided.
Clone the object, creating a new independent instance of the object exactly equal to the starting one...
Constructor, it creates a new instance of the object.
classe per la gestione del logging
Class for managing physical variables in a grib 1/2 fashion.
Copy an object, creating a fully new instance.
Definition: grid_class.F90:312
Method for inserting elements of the array at a desired position.
Class defining a real conversion function between units.
Apply the conversion function this to values.
Emit log message for a category with specific priority.

Generated with Doxygen.