49 CHARACTER(len=65) :: description
50 CHARACTER(len=24) :: unit
53 TYPE(volgrid6d_var),
PARAMETER :: volgrid6d_var_miss= &
56 TYPE(vol7d_var),
PARAMETER :: vol7d_var_horstag(2) = (/ &
57 vol7d_var(
'B11003',
'',
'', 0, 0, 0, 0, 0, 0), &
58 vol7d_var(
'B11004',
'',
'', 0, 0, 0, 0, 0, 0) &
61 TYPE(vol7d_var),
PARAMETER :: vol7d_var_horcomp(4) = (/ &
62 vol7d_var(
'B11003',
'',
'', 0, 0, 0, 0, 0, 0), &
63 vol7d_var(
'B11004',
'',
'', 0, 0, 0, 0, 0, 0), &
64 vol7d_var(
'B11200',
'',
'', 0, 0, 0, 0, 0, 0), &
65 vol7d_var(
'B11201',
'',
'', 0, 0, 0, 0, 0, 0) &
82 TYPE(conv_func),
PARAMETER :: conv_func_miss=
conv_func(rmiss,rmiss)
83 TYPE(conv_func),
PARAMETER :: conv_func_identity=
conv_func(1.0,0.0)
85 TYPE vg6d_v7d_var_conv
86 TYPE(volgrid6d_var) :: vg6d_var
87 TYPE(vol7d_var) :: v7d_var
88 TYPE(conv_func) :: c_func
90 END TYPE vg6d_v7d_var_conv
92 TYPE(vg6d_v7d_var_conv),
PARAMETER :: vg6d_v7d_var_conv_miss= &
93 vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
95 TYPE(vg6d_v7d_var_conv),
ALLOCATABLE :: conv_fwd(:), conv_bwd(:)
111 MODULE PROCEDURE volgrid6d_var_init
117 MODULE PROCEDURE volgrid6d_var_delete
121 MODULE PROCEDURE volgrid6d_var_c_e
129 INTERFACE OPERATOR (==)
130 MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
137 INTERFACE OPERATOR (/=)
138 MODULE PROCEDURE volgrid6d_var_ne, conv_func_ne
141 #define VOL7D_POLY_TYPE TYPE(volgrid6d_var) 142 #define VOL7D_POLY_TYPES _var6d 143 #include "array_utilities_pre.F90" 147 MODULE PROCEDURE display_volgrid6d_var
154 INTERFACE OPERATOR (*)
155 MODULE PROCEDURE conv_func_mult
156 END INTERFACE OPERATOR (*)
161 MODULE PROCEDURE conv_func_compute
167 MODULE PROCEDURE varbufr2vargrib_convert, vargrib2varbufr_convert
172 c_e, volgrid6d_var_normalize, &
173 OPERATOR(==),
OPERATOR(/=),
OPERATOR(*), &
174 count_distinct, pack_distinct, count_and_pack_distinct, &
175 map_distinct, map_inv_distinct, &
177 vargrib2varbufr, varbufr2vargrib, &
179 volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
185 ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
186 discipline, description, unit)
RESULT(this)
187 integer,
INTENT(in),
OPTIONAL :: centre
188 integer,
INTENT(in),
OPTIONAL :: category
189 integer,
INTENT(in),
OPTIONAL :: number
190 integer,
INTENT(in),
OPTIONAL :: discipline
191 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
192 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
194 TYPE(volgrid6d_var) :: this
196 CALL init(this, centre, category, number, discipline, description, unit)
198 END FUNCTION volgrid6d_var_new
202 ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
203 TYPE(volgrid6d_var),
INTENT(INOUT) :: this
204 INTEGER,
INTENT(in),
OPTIONAL :: centre
205 INTEGER,
INTENT(in),
OPTIONAL :: category
206 INTEGER,
INTENT(in),
OPTIONAL :: number
207 INTEGER,
INTENT(in),
OPTIONAL :: discipline
208 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
209 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
211 IF (
PRESENT(centre))
THEN 215 this%category = imiss
217 this%discipline = imiss
221 IF (
PRESENT(category))
THEN 222 this%category = category
224 this%category = imiss
226 this%discipline = imiss
231 IF (
PRESENT(number))
THEN 235 this%discipline = imiss
242 IF (
PRESENT(discipline))
THEN 243 this%discipline = discipline
245 this%discipline = 255
248 IF (
PRESENT(description))
THEN 249 this%description = description
251 this%description = cmiss
254 IF (
PRESENT(unit))
THEN 262 END SUBROUTINE volgrid6d_var_init
266 SUBROUTINE volgrid6d_var_delete(this)
270 this%category = imiss
272 this%discipline = imiss
273 this%description = cmiss
276 END SUBROUTINE volgrid6d_var_delete
279 ELEMENTAL FUNCTION volgrid6d_var_c_e(this)
RESULT(c_e)
280 TYPE(volgrid6d_var),
INTENT(IN) :: this
282 c_e = this /= volgrid6d_var_miss
283 END FUNCTION volgrid6d_var_c_e
286 ELEMENTAL FUNCTION volgrid6d_var_eq(this, that)
RESULT(res)
287 TYPE(volgrid6d_var),
INTENT(IN) :: this, that
290 IF (this%discipline == that%discipline)
THEN 292 IF (this%discipline == 255)
THEN 293 res = ((this%category == that%category) .OR. &
294 (this%category >= 1 .AND. this%category <=3 .AND. &
295 that%category >= 1 .AND. that%category <=3)) .AND. &
296 this%number == that%number
298 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
299 (this%number >= 128 .AND. this%number <= 254))
THEN 300 res = res .AND. this%centre == that%centre
304 res = this%category == that%category .AND. &
305 this%number == that%number
307 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
308 (this%category >= 192 .AND. this%category <= 254) .OR. &
309 (this%number >= 192 .AND. this%number <= 254))
THEN 310 res = res .AND. this%centre == that%centre
318 END FUNCTION volgrid6d_var_eq
321 ELEMENTAL FUNCTION volgrid6d_var_ne(this, that)
RESULT(res)
322 TYPE(volgrid6d_var),
INTENT(IN) :: this, that
325 res = .NOT.(this == that)
327 END FUNCTION volgrid6d_var_ne
330 #include "array_utilities_inc.F90" 334 SUBROUTINE display_volgrid6d_var(this)
335 TYPE(volgrid6d_var),
INTENT(in) :: this
337 print*,
"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
339 END SUBROUTINE display_volgrid6d_var
354 SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
355 TYPE(volgrid6d_var),
INTENT(in) :: vargrib(:)
356 TYPE(vol7d_var),
INTENT(out) :: varbufr(:)
357 TYPE(conv_func),
POINTER :: c_func(:)
359 INTEGER :: i, n, stallo
361 n = min(
SIZE(varbufr),
SIZE(vargrib))
362 ALLOCATE(c_func(n),stat=stallo)
363 IF (stallo /= 0)
THEN 364 call l4f_log(l4f_fatal,
"allocating memory")
365 call raise_fatal_error()
369 varbufr(i) =
convert(vargrib(i), c_func(i))
372 END SUBROUTINE vargrib2varbufr
385 FUNCTION vargrib2varbufr_convert(vargrib, c_func)
RESULT(convert)
386 TYPE(volgrid6d_var),
INTENT(in) :: vargrib
387 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
388 TYPE(vol7d_var) :: convert
392 IF (.NOT.
ALLOCATED(conv_fwd))
CALL vg6d_v7d_var_conv_setup()
394 DO i = 1,
SIZE(conv_fwd)
395 IF (vargrib == conv_fwd(i)%vg6d_var)
THEN 397 IF (
PRESENT(c_func)) c_func = conv_fwd(i)%c_func
403 IF (
PRESENT(c_func)) c_func = conv_func_miss
406 convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
409 CALL l4f_log(l4f_warn,
'vargrib2varbufr: variable '// &
410 trim(
to_char(vargrib%centre))//
':'//trim(
to_char(vargrib%category))//
':'// &
411 trim(
to_char(vargrib%number))//
':'//trim(
to_char(vargrib%discipline))// &
412 ' not found in table')
414 END FUNCTION vargrib2varbufr_convert
432 SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
433 TYPE(vol7d_var),
INTENT(in) :: varbufr(:)
434 TYPE(volgrid6d_var),
INTENT(out) :: vargrib(:)
435 TYPE(conv_func),
POINTER :: c_func(:)
436 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
438 INTEGER :: i, n, stallo
440 n = min(
SIZE(varbufr),
SIZE(vargrib))
441 ALLOCATE(c_func(n),stat=stallo)
442 IF (stallo /= 0)
THEN 443 CALL l4f_log(l4f_fatal,
"allocating memory")
444 CALL raise_fatal_error()
448 vargrib(i) =
convert(varbufr(i), c_func(i), grid_id_template)
451 END SUBROUTINE varbufr2vargrib
467 FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template)
RESULT(convert)
468 TYPE(vol7d_var),
INTENT(in) :: varbufr
469 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
470 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
471 TYPE(volgrid6d_var) :: convert
474 #ifdef HAVE_LIBGRIBAPI 475 INTEGER :: gaid, editionnumber, category, centre
478 IF (.NOT.
ALLOCATED(conv_bwd))
CALL vg6d_v7d_var_conv_setup()
480 #ifdef HAVE_LIBGRIBAPI 481 editionnumber=255; category=255; centre=255
483 IF (
PRESENT(grid_id_template))
THEN 484 #ifdef HAVE_LIBGRIBAPI 485 gaid = grid_id_get_gaid(grid_id_template)
487 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
488 IF (editionnumber == 1)
THEN 489 CALL grib_get(gaid,
'gribTablesVersionNo',category)
491 CALL grib_get(gaid,
'centre',centre)
496 DO i = 1,
SIZE(conv_bwd)
497 IF (varbufr == conv_bwd(i)%v7d_var)
THEN 498 #ifdef HAVE_LIBGRIBAPI 499 IF (editionnumber /= 255)
THEN 500 IF (editionnumber == 1)
THEN 501 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle
502 ELSE IF (editionnumber == 2)
THEN 503 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle
505 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
506 conv_bwd(i)%vg6d_var%centre /= centre) cycle
510 IF (
PRESENT(c_func)) c_func = conv_bwd(i)%c_func
516 IF (
PRESENT(c_func)) c_func = conv_func_miss
519 IF (any(varbufr%gribhint /= imiss))
THEN 520 convert%centre = varbufr%gribhint(1)
521 convert%category = varbufr%gribhint(2)
522 convert%number = varbufr%gribhint(3)
523 convert%discipline = varbufr%gribhint(4)
526 CALL l4f_log(l4f_warn,
'varbufr2vargrib: variable '// &
527 trim(varbufr%btable)//
" : "//trim(varbufr%description)//
" : "//trim(varbufr%unit)// &
528 ' not found in table')
530 END FUNCTION varbufr2vargrib_convert
540 SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
541 TYPE(volgrid6d_var),
INTENT(inout) :: this
542 TYPE(conv_func),
INTENT(out) :: c_func
543 TYPE(grid_id),
INTENT(in) :: grid_id_template
545 LOGICAL :: eqed, eqcentre
546 INTEGER :: gaid, editionnumber, centre
547 TYPE(volgrid6d_var) :: tmpgrib
548 TYPE(vol7d_var) :: tmpbufr
549 TYPE(conv_func) tmpc_func1, tmpc_func2
553 c_func = conv_func_miss
555 #ifdef HAVE_LIBGRIBAPI 556 gaid = grid_id_get_gaid(grid_id_template)
558 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
559 CALL grib_get(gaid,
'centre', centre)
560 eqed = editionnumber == 1 .EQV. this%discipline == 255
561 eqcentre = centre == this%centre
565 IF (eqed .AND. eqcentre)
RETURN 567 tmpbufr =
convert(this, tmpc_func1)
568 tmpgrib =
convert(tmpbufr, tmpc_func2, grid_id_template)
570 IF (tmpgrib /= volgrid6d_var_miss)
THEN 573 c_func = tmpc_func1 * tmpc_func2
575 IF (c_func == conv_func_identity) c_func = conv_func_miss
576 ELSE IF (.NOT.eqed)
THEN 581 END SUBROUTINE volgrid6d_var_normalize
586 SUBROUTINE vg6d_v7d_var_conv_setup()
587 INTEGER :: un, i, n, stallo
590 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
600 ALLOCATE(conv_fwd(n),stat=stallo)
601 IF (stallo /= 0)
THEN 602 CALL l4f_log(l4f_fatal,
"allocating memory")
603 CALL raise_fatal_error()
606 conv_fwd(:) = vg6d_v7d_var_conv_miss
607 CALL import_var_conv(un, conv_fwd)
611 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
623 ALLOCATE(conv_bwd(n),stat=stallo)
624 IF (stallo /= 0)
THEN 625 CALL l4f_log(l4f_fatal,
"allocating memory")
626 CALL raise_fatal_error()
629 conv_bwd(:) = vg6d_v7d_var_conv_miss
630 CALL import_var_conv(un, conv_bwd)
632 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
633 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
639 SUBROUTINE import_var_conv(un, conv_type)
640 INTEGER,
INTENT(in) :: un
641 TYPE(vg6d_v7d_var_conv),
INTENT(out) :: conv_type(:)
645 CHARACTER(len=1024) :: line
646 CHARACTER(len=10) :: btable
647 INTEGER :: centre, category, number, discipline
649 DO i = 1,
SIZE(conv_type)
650 READ(un,
'(A)',end=200)line
655 CALL init(conv_type(i)%v7d_var, btable=btable)
661 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
662 number=number, discipline=discipline)
671 END SUBROUTINE import_var_conv
673 END SUBROUTINE vg6d_v7d_var_conv_setup
676 ELEMENTAL FUNCTION conv_func_eq(this, that)
RESULT(res)
680 res = this%a == that%a .AND. this%b == that%b
682 END FUNCTION conv_func_eq
685 ELEMENTAL FUNCTION conv_func_ne(this, that)
RESULT(res)
689 res = .NOT.(this == that)
691 END FUNCTION conv_func_ne
694 FUNCTION conv_func_mult(this, that)
RESULT(mult)
700 IF (this == conv_func_miss .OR. that == conv_func_miss)
THEN 701 mult = conv_func_miss
703 mult%a = this%a*that%a
704 mult%b = this%a*that%b+this%b
707 END FUNCTION conv_func_mult
716 ELEMENTAL SUBROUTINE conv_func_compute(this, values)
718 REAL,
INTENT(inout) :: values
720 IF (this /= conv_func_miss)
THEN 721 IF (c_e(values)) values = values*this%a + this%b
726 END SUBROUTINE conv_func_compute
742 SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
744 INTEGER,
POINTER :: xind(:), yind(:)
748 INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
753 CALL vargrib2varbufr(this, varbufr, c_func)
755 DO i = 1,
SIZE(vol7d_var_horcomp)
756 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
759 IF (any(counts(1::2) > 1))
THEN 760 CALL l4f_log(l4f_warn,
'> 1 variable refer to x component of the same field, (un)rotation impossible')
764 IF (any(counts(2::2) > 1))
THEN 765 CALL l4f_log(l4f_warn,
'> 1 variable refer to y component of the same field, (un)rotation impossible')
772 DO i = 1,
SIZE(vol7d_var_horcomp), 2
773 IF (counts(i) == 0 .AND. counts(i+1) > 0)
THEN 774 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
775 ' present but the corresponding x-component '// &
776 trim(vol7d_var_horcomp(i)%btable)//
' is missing, (un)rotation impossible')
778 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0)
THEN 779 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i)%btable)// &
780 ' present but the corresponding y-component '// &
781 trim(vol7d_var_horcomp(i+1)%btable)//
' is missing, (un)rotation impossible')
784 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
788 ALLOCATE(xind(nv), yind(nv))
790 DO i = 1,
SIZE(vol7d_var_horcomp), 2
791 IF (counts(i) == 1 .AND. counts(i+1) == 1)
THEN 793 xind(nv) =
index(varbufr(:), vol7d_var_horcomp(i))
794 yind(nv) =
index(varbufr(:), vol7d_var_horcomp(i+1))
799 END SUBROUTINE volgrid6d_var_hor_comp_index
806 FUNCTION volgrid6d_var_is_hor_comp(this)
RESULT(is_hor_comp)
808 LOGICAL :: is_hor_comp
813 is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
815 END FUNCTION volgrid6d_var_is_hor_comp
Represent level object in a pretty string.
Definition of a physical variable in grib coding style.
This module defines an abstract interface to different drivers for access to files containing gridded...
Apply the conversion function this to values.
Display on the screen a brief content of object.
Utilities for managing files.
Methods for successively obtaining the fields of a csv_record object.
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
Initialize a volgrid6d_var object with the optional arguments provided.
Destructor for the corresponding object, it assigns it to a missing value.
Definitions of constants and functions for working with missing values.
Class for interpreting the records of a csv file.
Class for managing physical variables in a grib 1/2 fashion.
Definisce una variabile meteorologica osservata o un suo attributo.
Class defining a real conversion function between units.
Apply the conversion function this to values.
Definition of constants to be used for declaring variables of a desired type.