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) .OR. &
295 (this%category >= 1 .AND. this%category <=3 .AND. &
296 that%category >= 1 .AND. that%category <=3)) .AND. &
297 this%number == that%number
299 IF ((this%category >= 128 .AND. this%category <= 254) .OR. &
300 (this%number >= 128 .AND. this%number <= 254))
THEN
301 res = res .AND. this%centre == that%centre
305 res = this%category == that%category .AND. &
306 this%number == that%number
308 IF ((this%discipline >= 192 .AND. this%discipline <= 254) .OR. &
309 (this%category >= 192 .AND. this%category <= 254) .OR. &
310 (this%number >= 192 .AND. this%number <= 254))
THEN
311 res = res .AND. this%centre == that%centre
319 END FUNCTION volgrid6d_var_eq
322 ELEMENTAL FUNCTION volgrid6d_var_ne(this, that)
RESULT(res)
323 TYPE(volgrid6d_var),
INTENT(IN) :: this, that
326 res = .NOT.(this == that)
328 END FUNCTION volgrid6d_var_ne
331 #include "array_utilities_inc.F90"
335 SUBROUTINE display_volgrid6d_var(this)
336 TYPE(volgrid6d_var),
INTENT(in) :: this
338 print*,
"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
340 END SUBROUTINE display_volgrid6d_var
355 SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
356 TYPE(volgrid6d_var),
INTENT(in) :: vargrib(:)
357 TYPE(vol7d_var),
INTENT(out) :: varbufr(:)
358 TYPE(conv_func),
POINTER :: c_func(:)
360 INTEGER :: i, n, stallo
362 n = min(
SIZE(varbufr),
SIZE(vargrib))
363 ALLOCATE(c_func(n),stat=stallo)
364 IF (stallo /= 0)
THEN
365 call l4f_log(l4f_fatal,
"allocating memory")
366 call raise_fatal_error()
370 varbufr(i) =
convert(vargrib(i), c_func(i))
373 END SUBROUTINE vargrib2varbufr
386 FUNCTION vargrib2varbufr_convert(vargrib, c_func)
RESULT(convert)
387 TYPE(volgrid6d_var),
INTENT(in) :: vargrib
388 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
389 TYPE(vol7d_var) :: convert
393 IF (.NOT.
ALLOCATED(conv_fwd))
CALL vg6d_v7d_var_conv_setup()
395 DO i = 1,
SIZE(conv_fwd)
396 IF (vargrib == conv_fwd(i)%vg6d_var)
THEN
398 IF (
PRESENT(c_func)) c_func = conv_fwd(i)%c_func
404 IF (
PRESENT(c_func)) c_func = conv_func_miss
407 convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
410 CALL l4f_log(l4f_warn,
'vargrib2varbufr: variable '// &
411 trim(to_char(vargrib%centre))//
':'//trim(to_char(vargrib%category))//
':'// &
412 trim(to_char(vargrib%number))//
':'//trim(to_char(vargrib%discipline))// &
413 ' not found in table')
415 END FUNCTION vargrib2varbufr_convert
433 SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
434 TYPE(vol7d_var),
INTENT(in) :: varbufr(:)
435 TYPE(volgrid6d_var),
INTENT(out) :: vargrib(:)
436 TYPE(conv_func),
POINTER :: c_func(:)
437 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
439 INTEGER :: i, n, stallo
441 n = min(
SIZE(varbufr),
SIZE(vargrib))
442 ALLOCATE(c_func(n),stat=stallo)
443 IF (stallo /= 0)
THEN
444 CALL l4f_log(l4f_fatal,
"allocating memory")
445 CALL raise_fatal_error()
449 vargrib(i) =
convert(varbufr(i), c_func(i), grid_id_template)
452 END SUBROUTINE varbufr2vargrib
468 FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template)
RESULT(convert)
469 TYPE(vol7d_var),
INTENT(in) :: varbufr
470 TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
471 TYPE(grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
472 TYPE(volgrid6d_var) :: convert
475 #ifdef HAVE_LIBGRIBAPI
476 INTEGER :: gaid, editionnumber, category, centre
479 IF (.NOT.
ALLOCATED(conv_bwd))
CALL vg6d_v7d_var_conv_setup()
481 #ifdef HAVE_LIBGRIBAPI
482 editionnumber=255; category=255; centre=255
484 IF (
PRESENT(grid_id_template))
THEN
485 #ifdef HAVE_LIBGRIBAPI
486 gaid = grid_id_get_gaid(grid_id_template)
488 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
489 IF (editionnumber == 1)
THEN
490 CALL grib_get(gaid,
'gribTablesVersionNo',category)
492 CALL grib_get(gaid,
'centre',centre)
497 DO i = 1,
SIZE(conv_bwd)
498 IF (varbufr == conv_bwd(i)%v7d_var)
THEN
499 #ifdef HAVE_LIBGRIBAPI
500 IF (editionnumber /= 255)
THEN
501 IF (editionnumber == 1)
THEN
502 IF (conv_bwd(i)%vg6d_var%discipline /= 255) cycle
503 ELSE IF (editionnumber == 2)
THEN
504 IF (conv_bwd(i)%vg6d_var%discipline == 255) cycle
506 IF (conv_bwd(i)%vg6d_var%centre /= 255 .AND. &
507 conv_bwd(i)%vg6d_var%centre /= centre) cycle
511 IF (
PRESENT(c_func)) c_func = conv_bwd(i)%c_func
517 IF (
PRESENT(c_func)) c_func = conv_func_miss
520 IF (any(varbufr%gribhint /= imiss))
THEN
521 convert%centre = varbufr%gribhint(1)
522 convert%category = varbufr%gribhint(2)
523 convert%number = varbufr%gribhint(3)
524 convert%discipline = varbufr%gribhint(4)
527 CALL l4f_log(l4f_warn,
'varbufr2vargrib: variable '// &
528 trim(varbufr%btable)//
" : "//trim(varbufr%description)//
" : "//trim(varbufr%unit)// &
529 ' not found in table')
531 END FUNCTION varbufr2vargrib_convert
541 SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
542 TYPE(volgrid6d_var),
INTENT(inout) :: this
543 TYPE(conv_func),
INTENT(out) :: c_func
544 TYPE(grid_id),
INTENT(in) :: grid_id_template
546 LOGICAL :: eqed, eqcentre
547 INTEGER :: gaid, editionnumber, centre
548 TYPE(volgrid6d_var) :: tmpgrib
549 TYPE(vol7d_var) :: tmpbufr
550 TYPE(conv_func) tmpc_func1, tmpc_func2
554 c_func = conv_func_miss
556 #ifdef HAVE_LIBGRIBAPI
557 gaid = grid_id_get_gaid(grid_id_template)
559 CALL grib_get(gaid,
'GRIBEditionNumber', editionnumber)
560 CALL grib_get(gaid,
'centre', centre)
561 eqed = editionnumber == 1 .EQV. this%discipline == 255
562 eqcentre = centre == this%centre
566 IF (eqed .AND. eqcentre)
RETURN
568 tmpbufr =
convert(this, tmpc_func1)
569 tmpgrib =
convert(tmpbufr, tmpc_func2, grid_id_template)
571 IF (tmpgrib /= volgrid6d_var_miss)
THEN
574 c_func = tmpc_func1 * tmpc_func2
576 IF (c_func == conv_func_identity) c_func = conv_func_miss
577 ELSE IF (.NOT.eqed)
THEN
582 END SUBROUTINE volgrid6d_var_normalize
587 SUBROUTINE vg6d_v7d_var_conv_setup()
588 INTEGER :: un, i, n, stallo
591 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
601 ALLOCATE(conv_fwd(n),stat=stallo)
602 IF (stallo /= 0)
THEN
603 CALL l4f_log(l4f_fatal,
"allocating memory")
604 CALL raise_fatal_error()
607 conv_fwd(:) = vg6d_v7d_var_conv_miss
608 CALL import_var_conv(un, conv_fwd)
612 un = open_package_file(
'vargrib2bufr.csv', filetype_data)
624 ALLOCATE(conv_bwd(n),stat=stallo)
625 IF (stallo /= 0)
THEN
626 CALL l4f_log(l4f_fatal,
"allocating memory")
627 CALL raise_fatal_error()
630 conv_bwd(:) = vg6d_v7d_var_conv_miss
631 CALL import_var_conv(un, conv_bwd)
633 conv_bwd(i)%c_func%a = 1./conv_bwd(i)%c_func%a
634 conv_bwd(i)%c_func%b = - conv_bwd(i)%c_func%b
640 SUBROUTINE import_var_conv(un, conv_type)
641 INTEGER,
INTENT(in) :: un
642 TYPE(vg6d_v7d_var_conv),
INTENT(out) :: conv_type(:)
645 TYPE(csv_record) :: csv
646 CHARACTER(len=1024) :: line
647 CHARACTER(len=10) :: btable
648 INTEGER :: centre, category, number, discipline
650 DO i = 1,
SIZE(conv_type)
651 READ(un,
'(A)',
END=200)line
653 CALL csv_record_getfield(csv, btable)
654 CALL csv_record_getfield(csv)
655 CALL csv_record_getfield(csv)
656 CALL init(conv_type(i)%v7d_var, btable=btable)
658 CALL csv_record_getfield(csv, centre)
659 CALL csv_record_getfield(csv, category)
660 CALL csv_record_getfield(csv, number)
661 CALL csv_record_getfield(csv, discipline)
662 CALL init(conv_type(i)%vg6d_var, centre=centre, category=category, &
663 number=number, discipline=discipline)
665 CALL csv_record_getfield(csv, conv_type(i)%c_func%a)
666 CALL csv_record_getfield(csv, conv_type(i)%c_func%b)
672 END SUBROUTINE import_var_conv
674 END SUBROUTINE vg6d_v7d_var_conv_setup
677 ELEMENTAL FUNCTION conv_func_eq(this, that)
RESULT(res)
681 res = this%a == that%a .AND. this%b == that%b
683 END FUNCTION conv_func_eq
686 ELEMENTAL FUNCTION conv_func_ne(this, that)
RESULT(res)
690 res = .NOT.(this == that)
692 END FUNCTION conv_func_ne
695 FUNCTION conv_func_mult(this, that)
RESULT(mult)
701 IF (this == conv_func_miss .OR. that == conv_func_miss)
THEN
702 mult = conv_func_miss
704 mult%a = this%a*that%a
705 mult%b = this%a*that%b+this%b
708 END FUNCTION conv_func_mult
717 ELEMENTAL SUBROUTINE conv_func_compute(this, values)
719 REAL,
INTENT(inout) :: values
721 IF (this /= conv_func_miss)
THEN
722 IF (c_e(values)) values = values*this%a + this%b
727 END SUBROUTINE conv_func_compute
737 ELEMENTAL FUNCTION conv_func_convert(this, values)
RESULT(convert)
739 REAL,
INTENT(in) :: values
745 END FUNCTION conv_func_convert
761 SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
763 INTEGER,
POINTER :: xind(:), yind(:)
765 TYPE(vol7d_var) :: varbufr(size(this))
767 INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
772 CALL vargrib2varbufr(this, varbufr, c_func)
774 DO i = 1,
SIZE(vol7d_var_horcomp)
775 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
778 IF (any(counts(1::2) > 1))
THEN
779 CALL l4f_log(l4f_warn,
'> 1 variable refer to x component of the same field, (un)rotation impossible')
783 IF (any(counts(2::2) > 1))
THEN
784 CALL l4f_log(l4f_warn,
'> 1 variable refer to y component of the same field, (un)rotation impossible')
791 DO i = 1,
SIZE(vol7d_var_horcomp), 2
792 IF (counts(i) == 0 .AND. counts(i+1) > 0)
THEN
793 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i+1)%btable)// &
794 ' present but the corresponding x-component '// &
795 trim(vol7d_var_horcomp(i)%btable)//
' is missing, (un)rotation impossible')
797 ELSE IF (counts(i+1) == 0 .AND. counts(i) > 0)
THEN
798 CALL l4f_log(l4f_warn,
'variable '//trim(vol7d_var_horcomp(i)%btable)// &
799 ' present but the corresponding y-component '// &
800 trim(vol7d_var_horcomp(i+1)%btable)//
' is missing, (un)rotation impossible')
803 IF (counts(i) == 1 .AND. counts(i+1) == 1) nv = nv + 1
807 ALLOCATE(xind(nv), yind(nv))
809 DO i = 1,
SIZE(vol7d_var_horcomp), 2
810 IF (counts(i) == 1 .AND. counts(i+1) == 1)
THEN
812 xind(nv) =
index(varbufr(:), vol7d_var_horcomp(i))
813 yind(nv) =
index(varbufr(:), vol7d_var_horcomp(i+1))
818 END SUBROUTINE volgrid6d_var_hor_comp_index
825 FUNCTION volgrid6d_var_is_hor_comp(this)
RESULT(is_hor_comp)
827 LOGICAL :: is_hor_comp
829 TYPE(vol7d_var) :: varbufr
832 is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
834 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.