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, &
173 c_e, volgrid6d_var_normalize, &
174 OPERATOR(==),
OPERATOR(/=),
OPERATOR(*), &
175 count_distinct, pack_distinct, count_and_pack_distinct, &
176 map_distinct, map_inv_distinct, &
178 vargrib2varbufr, varbufr2vargrib, &
180 volgrid6d_var_hor_comp_index, volgrid6d_var_is_hor_comp
186 ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
187 discipline, description, unit)
RESULT(this)
188 integer,
INTENT(in),
OPTIONAL :: centre
189 integer,
INTENT(in),
OPTIONAL :: category
190 integer,
INTENT(in),
OPTIONAL :: number
191 integer,
INTENT(in),
OPTIONAL :: discipline
192 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
193 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
195 TYPE(volgrid6d_var) :: this
197 CALL init(this, centre, category, number, discipline, description, unit)
199 END FUNCTION volgrid6d_var_new
203 ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
204 TYPE(volgrid6d_var),
INTENT(INOUT) :: this
205 INTEGER,
INTENT(in),
OPTIONAL :: centre
206 INTEGER,
INTENT(in),
OPTIONAL :: category
207 INTEGER,
INTENT(in),
OPTIONAL :: number
208 INTEGER,
INTENT(in),
OPTIONAL :: discipline
209 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
210 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
212 IF (
PRESENT(centre))
THEN
216 this%category = imiss
218 this%discipline = imiss
222 IF (
PRESENT(category))
THEN
223 this%category = category
225 this%category = imiss
227 this%discipline = imiss
232 IF (
PRESENT(number))
THEN
236 this%discipline = imiss
243 IF (
PRESENT(discipline))
THEN
244 this%discipline = discipline
246 this%discipline = 255
249 IF (
PRESENT(description))
THEN
250 this%description = description
252 this%description = cmiss
255 IF (
PRESENT(unit))
THEN
263 END SUBROUTINE volgrid6d_var_init
267 SUBROUTINE volgrid6d_var_delete(this)
271 this%category = imiss
273 this%discipline = imiss
274 this%description = cmiss
277 END SUBROUTINE volgrid6d_var_delete
280 ELEMENTAL FUNCTION volgrid6d_var_c_e(this)
RESULT(c_e)
281 TYPE(volgrid6d_var),
INTENT(IN) :: this
283 c_e = this /= volgrid6d_var_miss
284 END FUNCTION volgrid6d_var_c_e
287 ELEMENTAL FUNCTION volgrid6d_var_eq(this, that)
RESULT(res)
288 TYPE(volgrid6d_var),
INTENT(IN) :: this, that
291 IF (this%discipline == that%discipline)
THEN
293 IF (this%discipline == 255)
THEN
294 res = this%category == that%category .AND. &
295 this%number == that%number
297 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
298 (this%number >= 128 .AND. this%number <= 254))
THEN
299 res = res .AND. this%centre == that%centre
303 res = this%category == that%category .AND. &
304 this%number == that%number
306 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
307 (this%category >= 192 .AND. this%category <= 254) .OR. &
308 (this%number >= 192 .AND. this%number <= 254))
THEN
309 res = res .AND. this%centre == that%centre
317 END FUNCTION volgrid6d_var_eq
320 ELEMENTAL FUNCTION volgrid6d_var_ne(this, that)
RESULT(res)
321 TYPE(volgrid6d_var),
INTENT(IN) :: this, that
324 res = .NOT.(this == that)
326 END FUNCTION volgrid6d_var_ne
329 #include "array_utilities_inc.F90"
333 SUBROUTINE display_volgrid6d_var(this)
334 TYPE(volgrid6d_var),
INTENT(in) :: this
336 print*,
"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
338 END SUBROUTINE display_volgrid6d_var
353 SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
354 TYPE(volgrid6d_var),
INTENT(in) :: vargrib(:)
355 TYPE(vol7d_var),
INTENT(out) :: varbufr(:)
356 TYPE(conv_func),
POINTER :: c_func(:)
358 INTEGER :: i, n, stallo
360 n = min(
SIZE(varbufr),
SIZE(vargrib))
361 ALLOCATE(c_func(n),stat=stallo)
362 IF (stallo /= 0)
THEN
363 call l4f_log(l4f_fatal,
"allocating memory")
364 call raise_fatal_error()
368 varbufr(i) =
convert(vargrib(i), c_func(i))
371 END SUBROUTINE vargrib2varbufr
384 FUNCTION vargrib2varbufr_convert(vargrib, c_func)
RESULT(convert)
385 TYPE(volgrid6d_var),
INTENT(in) :: vargrib
386 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
387 TYPE(vol7d_var) :: convert
391 IF (.NOT.
ALLOCATED(conv_fwd))
CALL vg6d_v7d_var_conv_setup()
393 DO i = 1,
SIZE(conv_fwd)
394 IF (vargrib == conv_fwd(i)%vg6d_var)
THEN
396 IF (
PRESENT(c_func)) c_func = conv_fwd(i)%c_func
402 IF (
PRESENT(c_func)) c_func = conv_func_miss
405 convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
408 CALL l4f_log(l4f_warn,
'vargrib2varbufr: variable '// &
409 trim(to_char(vargrib%centre))//
':'//trim(to_char(vargrib%category))//
':'// &
410 trim(to_char(vargrib%number))//
':'//trim(to_char(vargrib%discipline))// &
411 ' not found in table')
413 END FUNCTION vargrib2varbufr_convert
431 SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
432 TYPE(vol7d_var),
INTENT(in) :: varbufr(:)
433 TYPE(volgrid6d_var),
INTENT(out) :: vargrib(:)
434 TYPE(conv_func),
POINTER :: c_func(:)
435 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
437 INTEGER :: i, n, stallo
439 n = min(
SIZE(varbufr),
SIZE(vargrib))
440 ALLOCATE(c_func(n),stat=stallo)
441 IF (stallo /= 0)
THEN
442 CALL l4f_log(l4f_fatal,
"allocating memory")
443 CALL raise_fatal_error()
447 vargrib(i) =
convert(varbufr(i), c_func(i), grid_id_template)
450 END SUBROUTINE varbufr2vargrib
466 FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template)
RESULT(convert)
467 TYPE(vol7d_var),
INTENT(in) :: varbufr
468 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
469 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
470 TYPE(volgrid6d_var) :: convert
473 #ifdef HAVE_LIBGRIBAPI
474 INTEGER :: gaid, editionnumber, category, centre
477 IF (.NOT.
ALLOCATED(conv_bwd))
CALL vg6d_v7d_var_conv_setup()
479 #ifdef HAVE_LIBGRIBAPI
480 editionnumber=255; category=255; centre=255
482 IF (
PRESENT(grid_id_template))
THEN
483 #ifdef HAVE_LIBGRIBAPI
484 gaid = grid_id_get_gaid(grid_id_template)
486 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
487 IF (editionnumber == 1)
THEN
488 CALL grib_get(gaid,
'gribTablesVersionNo',category)
490 CALL grib_get(gaid,
'centre',centre)
495 DO i = 1,
SIZE(conv_bwd)
496 IF (varbufr == conv_bwd(i)%v7d_var)
THEN
497 #ifdef HAVE_LIBGRIBAPI
498 IF (editionnumber /= 255)
THEN
499 IF (editionnumber == 1)
THEN
500 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle
501 ELSE IF (editionnumber == 2)
THEN
502 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle
504 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
505 conv_bwd(i)%vg6d_var%centre /= centre) cycle
509 IF (
PRESENT(c_func)) c_func = conv_bwd(i)%c_func
515 IF (
PRESENT(c_func)) c_func = conv_func_miss
518 IF (any(varbufr%gribhint /= imiss))
THEN
519 convert%centre = varbufr%gribhint(1)
520 convert%category = varbufr%gribhint(2)
521 convert%number = varbufr%gribhint(3)
522 convert%discipline = varbufr%gribhint(4)
525 CALL l4f_log(l4f_warn,
'varbufr2vargrib: variable '// &
526 trim(varbufr%btable)//
" : "//trim(varbufr%description)//
" : "//trim(varbufr%unit)// &
527 ' not found in table')
529 END FUNCTION varbufr2vargrib_convert
539 SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
540 TYPE(volgrid6d_var),
INTENT(inout) :: this
541 TYPE(conv_func),
INTENT(out) :: c_func
542 TYPE(grid_id),
INTENT(in) :: grid_id_template
544 LOGICAL :: eqed, eqcentre
545 INTEGER :: gaid, editionnumber, centre
546 TYPE(volgrid6d_var) :: tmpgrib
547 TYPE(vol7d_var) :: tmpbufr
548 TYPE(conv_func) tmpc_func1, tmpc_func2
552 c_func = conv_func_miss
554 #ifdef HAVE_LIBGRIBAPI
555 gaid = grid_id_get_gaid(grid_id_template)
557 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
558 CALL grib_get(gaid,
'centre', centre)
559 eqed = editionnumber == 1 .EQV. this%discipline == 255
560 eqcentre = centre == this%centre
564 IF (eqed .AND. eqcentre)
RETURN
566 tmpbufr =
convert(this, tmpc_func1)
567 tmpgrib =
convert(tmpbufr, tmpc_func2, grid_id_template)
569 IF (tmpgrib /= volgrid6d_var_miss)
THEN
572 c_func = tmpc_func1 * tmpc_func2
574 IF (c_func == conv_func_identity) c_func = conv_func_miss
575 ELSE IF (.NOT.eqed)
THEN
580 END SUBROUTINE volgrid6d_var_normalize
585 SUBROUTINE vg6d_v7d_var_conv_setup()
586 INTEGER :: un, i, n, stallo
589 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
599 ALLOCATE(conv_fwd(n),stat=stallo)
600 IF (stallo /= 0)
THEN
601 CALL l4f_log(l4f_fatal,
"allocating memory")
602 CALL raise_fatal_error()
605 conv_fwd(:) = vg6d_v7d_var_conv_miss
606 CALL import_var_conv(un, conv_fwd)
610 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
622 ALLOCATE(conv_bwd(n),stat=stallo)
623 IF (stallo /= 0)
THEN
624 CALL l4f_log(l4f_fatal,
"allocating memory")
625 CALL raise_fatal_error()
628 conv_bwd(:) = vg6d_v7d_var_conv_miss
629 CALL import_var_conv(un, conv_bwd)
631 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
632 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
638 SUBROUTINE import_var_conv(un, conv_type)
639 INTEGER,
INTENT(in) :: un
640 TYPE(vg6d_v7d_var_conv),
INTENT(out) :: conv_type(:)
643 TYPE(csv_record) :: csv
644 CHARACTER(len=1024) :: line
645 CHARACTER(len=10) :: btable
646 INTEGER :: centre, category, number, discipline
648 DO i = 1,
SIZE(conv_type)
649 READ(un,
'(A)',
END=200)line
651 CALL csv_record_getfield(csv, btable)
652 CALL csv_record_getfield(csv)
653 CALL csv_record_getfield(csv)
654 CALL init(conv_type(i)%v7d_var, btable=btable)
656 CALL csv_record_getfield(csv, centre)
657 CALL csv_record_getfield(csv, category)
658 CALL csv_record_getfield(csv, number)
659 CALL csv_record_getfield(csv, discipline)
660 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
661 number=number, discipline=discipline)
663 CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
664 CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
670 END SUBROUTINE import_var_conv
672 END SUBROUTINE vg6d_v7d_var_conv_setup
675 ELEMENTAL FUNCTION conv_func_eq(this, that)
RESULT(res)
679 res = this%a == that%a .AND. this%b == that%b
681 END FUNCTION conv_func_eq
684 ELEMENTAL FUNCTION conv_func_ne(this, that)
RESULT(res)
688 res = .NOT.(this == that)
690 END FUNCTION conv_func_ne
693 FUNCTION conv_func_mult(this, that)
RESULT(mult)
699 IF (this == conv_func_miss .OR. that == conv_func_miss)
THEN
700 mult = conv_func_miss
702 mult%a = this%a*that%a
703 mult%b = this%a*that%b+this%b
706 END FUNCTION conv_func_mult
715 ELEMENTAL SUBROUTINE conv_func_compute(this, values)
717 REAL,
INTENT(inout) :: values
719 IF (this /= conv_func_miss)
THEN
720 IF (c_e(values)) values = values*this%a + this%b
725 END SUBROUTINE conv_func_compute
735 ELEMENTAL FUNCTION conv_func_convert(this, values)
RESULT(convert)
737 REAL,
INTENT(in) :: values
743 END FUNCTION conv_func_convert
759 SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
761 INTEGER,
POINTER :: xind(:), yind(:)
763 TYPE(vol7d_var) :: varbufr(size(this))
765 INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
770 CALL vargrib2varbufr(this, varbufr, c_func)
772 DO i = 1,
SIZE(vol7d_var_horcomp)
773 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
776 IF (any(counts(1::2) > 1))
THEN
777 CALL l4f_log(l4f_warn,
'> 1 variable refer to x component of the same field, (un)rotation impossible')
781 IF (any(counts(2::2) > 1))
THEN
782 CALL l4f_log(l4f_warn,
'> 1 variable refer to y component of the same field, (un)rotation impossible')
789 DO i = 1,
SIZE(vol7d_var_horcomp), 2
790 IF (counts(i) == 0 .AND. counts(i+1) > 0)
THEN
791 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
792 ' present but the corresponding x-component '// &
793 trim(vol7d_var_horcomp(i)%btable)//
' is missing, (un)rotation impossible')
795 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0)
THEN
796 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i)%btable)// &
797 ' present but the corresponding y-component '// &
798 trim(vol7d_var_horcomp(i+1)%btable)//
' is missing, (un)rotation impossible')
801 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
805 ALLOCATE(xind(nv), yind(nv))
807 DO i = 1,
SIZE(vol7d_var_horcomp), 2
808 IF (counts(i) == 1 .AND. counts(i+1) == 1)
THEN
810 xind(nv) =
index(varbufr(:), vol7d_var_horcomp(i))
811 yind(nv) =
index(varbufr(:), vol7d_var_horcomp(i+1))
816 END SUBROUTINE volgrid6d_var_hor_comp_index
823 FUNCTION volgrid6d_var_is_hor_comp(this)
RESULT(is_hor_comp)
825 LOGICAL :: is_hor_comp
827 TYPE(vol7d_var) :: varbufr
830 is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
832 END FUNCTION volgrid6d_var_is_hor_comp
Apply the conversion function this to values.
Apply the conversion function this to values.
Destructor for the corresponding object, it assigns it to a missing value.
Display on the screen a brief content of object.
Initialize a volgrid6d_var object with the optional arguments provided.
Utilities for managing files.
This module defines an abstract interface to different drivers for access to files containing gridded...
Definition of constants to be used for declaring variables of a desired type.
Definitions of constants and functions for working with missing values.
Classe per la gestione delle variabili osservate da stazioni meteo e affini.
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.
Definition of a physical variable in grib coding style.