49 CHARACTER(len=65) :: description
50 CHARACTER(len=24) :: unit
53TYPE(volgrid6d_var),
PARAMETER :: volgrid6d_var_miss= &
56TYPE(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) &
61TYPE(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) &
82TYPE(conv_func),
PARAMETER :: conv_func_miss=
conv_func(rmiss,rmiss)
83TYPE(conv_func),
PARAMETER :: conv_func_identity=
conv_func(1.0,0.0)
86 TYPE(volgrid6d_var) :: vg6d_var
87 TYPE(vol7d_var) :: v7d_var
88 TYPE(conv_func) :: c_func
90END TYPE vg6d_v7d_var_conv
92TYPE(vg6d_v7d_var_conv),
PARAMETER :: vg6d_v7d_var_conv_miss= &
93 vg6d_v7d_var_conv(volgrid6d_var_miss, vol7d_var_miss, conv_func_miss)
95TYPE(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
129INTERFACE OPERATOR (==)
130 MODULE PROCEDURE volgrid6d_var_eq, conv_func_eq
137INTERFACE 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
154INTERFACE OPERATOR (*)
155 MODULE PROCEDURE conv_func_mult
156END 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
186ELEMENTAL FUNCTION volgrid6d_var_new(centre, category, number, &
187 discipline, description, unit)
RESULT(this)
188integer,
INTENT(in),
OPTIONAL :: centre
189integer,
INTENT(in),
OPTIONAL :: category
190integer,
INTENT(in),
OPTIONAL :: number
191integer,
INTENT(in),
OPTIONAL :: discipline
192CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
193CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
195TYPE(volgrid6d_var) :: this
197CALL init(this, centre, category, number, discipline, description, unit)
199END FUNCTION volgrid6d_var_new
203ELEMENTAL SUBROUTINE volgrid6d_var_init(this, centre, category, number, discipline,description,unit)
204TYPE(volgrid6d_var),
INTENT(INOUT) :: this
205INTEGER,
INTENT(in),
OPTIONAL :: centre
206INTEGER,
INTENT(in),
OPTIONAL :: category
207INTEGER,
INTENT(in),
OPTIONAL :: number
208INTEGER,
INTENT(in),
OPTIONAL :: discipline
209CHARACTER(len=*),
INTENT(in),
OPTIONAL :: description
210CHARACTER(len=*),
INTENT(in),
OPTIONAL :: unit
212IF (
PRESENT(centre))
THEN
216 this%category = imiss
218 this%discipline = imiss
222IF (
PRESENT(category))
THEN
223 this%category = category
225 this%category = imiss
227 this%discipline = imiss
232IF (
PRESENT(number))
THEN
236 this%discipline = imiss
243IF (
PRESENT(discipline))
THEN
244 this%discipline = discipline
246 this%discipline = 255
249IF (
PRESENT(description))
THEN
250 this%description = description
252 this%description = cmiss
255IF (
PRESENT(unit))
THEN
263END SUBROUTINE volgrid6d_var_init
267SUBROUTINE volgrid6d_var_delete(this)
268TYPE(volgrid6d_var),
INTENT(INOUT) :: this
273this%discipline = imiss
274this%description = cmiss
277END SUBROUTINE volgrid6d_var_delete
280ELEMENTAL FUNCTION volgrid6d_var_c_e(this)
RESULT(c_e)
281TYPE(volgrid6d_var),
INTENT(IN) :: this
283c_e = this /= volgrid6d_var_miss
284END FUNCTION volgrid6d_var_c_e
287ELEMENTAL FUNCTION volgrid6d_var_eq(this, that)
RESULT(res)
288TYPE(volgrid6d_var),
INTENT(IN) :: this, that
291IF (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
319END FUNCTION volgrid6d_var_eq
322ELEMENTAL FUNCTION volgrid6d_var_ne(this, that)
RESULT(res)
323TYPE(volgrid6d_var),
INTENT(IN) :: this, that
326res = .NOT.(this == that)
328END FUNCTION volgrid6d_var_ne
331#include "array_utilities_inc.F90"
335SUBROUTINE display_volgrid6d_var(this)
336TYPE(volgrid6d_var),
INTENT(in) :: this
338print*,
"GRIDVAR: ",this%centre,this%discipline,this%category,this%number
340END SUBROUTINE display_volgrid6d_var
355SUBROUTINE vargrib2varbufr(vargrib, varbufr, c_func)
356TYPE(volgrid6d_var),
INTENT(in) :: vargrib(:)
357TYPE(vol7d_var),
INTENT(out) :: varbufr(:)
358TYPE(conv_func),
POINTER :: c_func(:)
360INTEGER :: i, n, stallo
362n = min(
SIZE(varbufr),
SIZE(vargrib))
363ALLOCATE(c_func(n),stat=stallo)
365 call l4f_log(l4f_fatal,
"allocating memory")
366 call raise_fatal_error()
370 varbufr(i) =
convert(vargrib(i), c_func(i))
373END SUBROUTINE vargrib2varbufr
386FUNCTION vargrib2varbufr_convert(vargrib, c_func)
RESULT(convert)
387TYPE(volgrid6d_var),
INTENT(in) :: vargrib
388TYPE(conv_func),
INTENT(out),
OPTIONAL :: c_func
389TYPE(vol7d_var) :: convert
393IF (.NOT.
ALLOCATED(conv_fwd))
CALL vg6d_v7d_var_conv_setup()
395DO 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
404IF (
PRESENT(c_func)) c_func = conv_func_miss
407convert%gribhint(:) = (/vargrib%centre, vargrib%category, vargrib%number, &
410CALL 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')
415END FUNCTION vargrib2varbufr_convert
433SUBROUTINE varbufr2vargrib(varbufr, vargrib, c_func, grid_id_template)
437TYPE(
grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
439INTEGER :: i, n, stallo
441n = min(
SIZE(varbufr),
SIZE(vargrib))
442ALLOCATE(c_func(n),stat=stallo)
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)
452END SUBROUTINE varbufr2vargrib
468FUNCTION varbufr2vargrib_convert(varbufr, c_func, grid_id_template)
RESULT(convert)
470TYPE(
conv_func),
INTENT(out),
OPTIONAL :: c_func
471TYPE(
grid_id),
INTENT(in),
OPTIONAL :: grid_id_template
475#ifdef HAVE_LIBGRIBAPI
476INTEGER :: gaid, editionnumber, category, centre
479IF (.NOT.
ALLOCATED(conv_bwd))
CALL vg6d_v7d_var_conv_setup()
481#ifdef HAVE_LIBGRIBAPI
482editionnumber=255; category=255; centre=255
484IF (
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)
497DO 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
517IF (
PRESENT(c_func)) c_func = conv_func_miss
520IF (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)
527CALL l4f_log(l4f_warn,
'varbufr2vargrib: variable '// &
528 trim(varbufr%btable)//
" : "//trim(varbufr%description)//
" : "//trim(varbufr%unit)// &
529 ' not found in table')
531END FUNCTION varbufr2vargrib_convert
541SUBROUTINE volgrid6d_var_normalize(this, c_func, grid_id_template)
544TYPE(
grid_id),
INTENT(in) :: grid_id_template
546LOGICAL :: eqed, eqcentre
547INTEGER :: gaid, editionnumber, centre
554c_func = conv_func_miss
556#ifdef HAVE_LIBGRIBAPI
557gaid = 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
566IF (eqed .AND. eqcentre)
RETURN
568tmpbufr =
convert(this, tmpc_func1)
569tmpgrib =
convert(tmpbufr, tmpc_func2, grid_id_template)
571IF (tmpgrib /= volgrid6d_var_miss)
THEN
574 c_func = tmpc_func1 * tmpc_func2
576 IF (c_func == conv_func_identity) c_func = conv_func_miss
577ELSE IF (.NOT.eqed)
THEN
582END SUBROUTINE volgrid6d_var_normalize
587SUBROUTINE vg6d_v7d_var_conv_setup()
588INTEGER :: un, i, n, stallo
591un = open_package_file(
'vargrib2bufr.csv', filetype_data)
601ALLOCATE(conv_fwd(n),stat=stallo)
603 CALL l4f_log(l4f_fatal,
"allocating memory")
604 CALL raise_fatal_error()
607conv_fwd(:) = vg6d_v7d_var_conv_miss
608CALL import_var_conv(un, conv_fwd)
612un = open_package_file(
'vargrib2bufr.csv', filetype_data)
624ALLOCATE(conv_bwd(n),stat=stallo)
626 CALL l4f_log(l4f_fatal,
"allocating memory")
627 CALL raise_fatal_error()
630conv_bwd(:) = vg6d_v7d_var_conv_miss
631CALL 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
640SUBROUTINE import_var_conv(un, conv_type)
641INTEGER,
INTENT(in) :: un
642TYPE(vg6d_v7d_var_conv),
INTENT(out) :: conv_type(:)
645TYPE(csv_record) :: csv
646CHARACTER(len=1024) :: line
647CHARACTER(len=10) :: btable
648INTEGER :: centre, category, number, discipline
650DO 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)
672END SUBROUTINE import_var_conv
674END SUBROUTINE vg6d_v7d_var_conv_setup
677ELEMENTAL FUNCTION conv_func_eq(this, that)
RESULT(res)
681res = this%a == that%a .AND. this%b == that%b
683END FUNCTION conv_func_eq
686ELEMENTAL FUNCTION conv_func_ne(this, that)
RESULT(res)
690res = .NOT.(this == that)
692END FUNCTION conv_func_ne
695FUNCTION conv_func_mult(this, that)
RESULT(mult)
701IF (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
708END FUNCTION conv_func_mult
717ELEMENTAL SUBROUTINE conv_func_compute(this, values)
719REAL,
INTENT(inout) :: values
721IF (this /= conv_func_miss)
THEN
722 IF (c_e(values)) values = values*this%a + this%b
727END SUBROUTINE conv_func_compute
737ELEMENTAL FUNCTION conv_func_convert(this, values)
RESULT(convert)
739REAL,
INTENT(in) :: values
745END FUNCTION conv_func_convert
761SUBROUTINE volgrid6d_var_hor_comp_index(this, xind, yind)
763INTEGER,
POINTER :: xind(:), yind(:)
765TYPE(vol7d_var) :: varbufr(size(this))
767INTEGER :: i, nv, counts(size(vol7d_var_horcomp))
772CALL vargrib2varbufr(this, varbufr, c_func)
774DO i = 1,
SIZE(vol7d_var_horcomp)
775 counts(i) = count(varbufr(:) == vol7d_var_horcomp(i))
778IF (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')
783IF (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')
791DO 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
807ALLOCATE(xind(nv), yind(nv))
809DO 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))
818END SUBROUTINE volgrid6d_var_hor_comp_index
825FUNCTION volgrid6d_var_is_hor_comp(this)
RESULT(is_hor_comp)
827LOGICAL :: is_hor_comp
829TYPE(vol7d_var) :: varbufr
832is_hor_comp = any(varbufr == vol7d_var_horcomp(:))
834END 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.
Derived type associated to a block/message/record/band of gridded data coming from a file-like object...
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.