libsim Versione 7.2.6
|
◆ vol7d_get_volanaattrr()
Crea una vista a dimensione ridotta di un volume di attributi di anagrafica di tipo REAL. È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio: REAL, POINTER :: vol1d(:)
...
CALL vol7d_get_volanaattrr(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 3592 del file vol7d_class.F90. 3594! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3595! authors:
3596! Davide Cesari <dcesari@arpa.emr.it>
3597! Paolo Patruno <ppatruno@arpa.emr.it>
3598
3599! This program is free software; you can redistribute it and/or
3600! modify it under the terms of the GNU General Public License as
3601! published by the Free Software Foundation; either version 2 of
3602! the License, or (at your option) any later version.
3603
3604! This program is distributed in the hope that it will be useful,
3605! but WITHOUT ANY WARRANTY; without even the implied warranty of
3606! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3607! GNU General Public License for more details.
3608
3609! You should have received a copy of the GNU General Public License
3610! along with this program. If not, see <http://www.gnu.org/licenses/>.
3611#include "config.h"
3612
3613!> \defgroup vol7d Libsim package, vol7d library.
3614!! The libsim vol7d library contains classes for managing pointwise
3615!! data, tipically weather observations, and for their import from a
3616!! Db-All.e database or from a WMO BUFR file. In order to compile and
3617!! link programs using this library, you have to insert the required
3618!! \c USE statements in the program units involved, specify the
3619!! location of module files when compiling (tipically \c
3620!! -I/usr/lib/gfortran/modules or \c -I/usr/lib64/gfortran/modules or
3621!! \c -I/usr/include) and indicate the library name \c -lsim_vol7d
3622!! when linking, assuming that the library has been installed in a
3623!! default location.
3624
3625!> Classe per la gestione di un volume completo di dati osservati.
3626!! Questo modulo definisce gli oggetti e i metodi per gestire
3627!! volumi di dati meteorologici sparsi.
3628!! I volumi definiti sono principalmente di 4 categorie:
3629!! - volumi di anagrafica (vol7d::volanar & c.), hanno 3 dimensioni:
3630!! - anagrafica
3631!! - variabile di anagrafica
3632!! - rete
3633!! - volumi di attributi di anagrafica (vol7d::volanaattrr & c.), hanno 4 dimensioni:
3634!! - anagrafica
3635!! - variabile di anagrafica
3636!! - rete
3637!! - variabile di attributi delle variabili di anagrafica
3638!! - volumi di dati (vol7d::voldatir & c.), hanno 6 dimensioni:
3639!! - anagrafica
3640!! - tempo
3641!! - livello verticale
3642!! - intervallo temporale (timerange)
3643!! - variabile di dati
3644!! - rete
3645!! - volumi di attributi di dati (vol7d::voldatiattrr & c.), hanno 7 dimensioni:
3646!! - anagrafica
3647!! - tempo
3648!! - livello verticale
3649!! - intervallo temporale (timerange)
3650!! - variabile di dati
3651!! - rete
3652!! - variabile di attributi delle variabili di dati
3653!!
3654!! Tutte le variabili sono inoltre disponibil1 in 5 tipi diversi:
3655!! - reale (abbreviato r)
3656!! - doppia precisione (abbreviato d)
3657!! - intero (abbreviato i)
3658!! - byte (abbreviato b)
3659!! - carattere (abbreviato c)
3660!!
3661!! Per ognuna delle dimensioni possibili, incluse le variabili e gli
3662!! attributi con i loro diversi tipi,
3663!! è definito un cosiddetto "vettore di descrittori", con un
3664!! numero di elementi pari all'estensione della dimensione stessa,
3665!! che contiene le informazioni necessarie a descrivere
3666!! gli elementi di quella dimensione.
3667!! In realtà l'utente non dovrà generalmente occuparsi di costruire
3668!! un oggetto vol7d con le proprie mani ma utilizzerà nella maggior parte
3669!! dei casi i metodi di importazione preconfezionati che importano dati da
3670!! DB-All.e (vol7d_dballe_class) o dal DB Oracle del SIM (vol7d_oraclesim_class).
3671!!
3672!!
3673!! Il programma esempio_v7d.f90 contiene un esempio elementare di uso
3674!! della classe vol7d:
3675!! \include esempio_v7d.f90
3676!!
3677!! \ingroup vol7d
3685USE io_units
3692IMPLICIT NONE
3693
3694
3695INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
3696 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
3697
3698INTEGER, PARAMETER :: vol7d_ana_a=1 !< indice della dimensione "anagrafica" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
3699INTEGER, PARAMETER :: vol7d_var_a=2 !< indice della dimensione "variabile" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
3700INTEGER, PARAMETER :: vol7d_network_a=3 !< indice della dimensione "rete" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
3701INTEGER, PARAMETER :: vol7d_attr_a=4 !< indice della dimensione "attributo" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
3702INTEGER, PARAMETER :: vol7d_ana_d=1 !< indice della dimensione "anagrafica" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3703INTEGER, PARAMETER :: vol7d_time_d=2 !< indice della dimensione "tempo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3704INTEGER, PARAMETER :: vol7d_level_d=3 !< indice della dimensione "livello verticale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3705INTEGER, PARAMETER :: vol7d_timerange_d=4 !< indice della dimensione "intervallo temporale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3706INTEGER, PARAMETER :: vol7d_var_d=5 !< indice della dimensione "variabile" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3707INTEGER, PARAMETER :: vol7d_network_d=6 !< indice della dimensione "rete" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3708INTEGER, PARAMETER :: vol7d_attr_d=7 !< indice della dimensione "attributo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
3709INTEGER, PARAMETER :: vol7d_cdatalen=32
3710
3711TYPE vol7d_varmap
3712 INTEGER :: r, d, i, b, c
3713END TYPE vol7d_varmap
3714
3715!> Definisce un oggetto contenente i volumi anagrafica e dati e tutti
3716!! i descrittori delle loro dimensioni.
3718!> vettore descrittore della dimensione anagrafica
3719 TYPE(vol7d_ana),POINTER :: ana(:)
3720!> vettore descrittore della dimensione tempo
3721 TYPE(datetime),POINTER :: time(:)
3722!> vettore descrittore della dimensione livello verticale
3723 TYPE(vol7d_level),POINTER :: level(:)
3724!> vettore descrittore della dimensione intervallo temporale (timerange)
3725 TYPE(vol7d_timerange),POINTER :: timerange(:)
3726!> vettore descrittore della dimensione rete
3727 TYPE(vol7d_network),POINTER :: network(:)
3728!> vettore descrittore della dimensione variabile di anagrafica
3729 TYPE(vol7d_varvect) :: anavar
3730!> vettore descrittore della dimensione attributo delle variabili di anagrafica
3731 TYPE(vol7d_varvect) :: anaattr
3732!> vettore descrittore della dimensione variabile di anagrafica che ha tali attributi
3733 TYPE(vol7d_varvect) :: anavarattr
3734!> vettore descrittore della dimensione variabile di dati
3735 TYPE(vol7d_varvect) :: dativar
3736!> vettore descrittore della dimensione attributo delle variabili di dati
3737 TYPE(vol7d_varvect) :: datiattr
3738!> vettore descrittore della dimensione variabile di dati che ha tali attributi
3739 TYPE(vol7d_varvect) :: dativarattr
3740
3741!> volume di anagrafica a valori reali
3742 REAL,POINTER :: volanar(:,:,:)
3743!> volume di anagrafica a valori a doppia precisione
3744 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
3745!> volume di anagrafica a valori interi
3746 INTEGER,POINTER :: volanai(:,:,:)
3747!> volume di anagrafica a valori byte
3748 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
3749!> volume di anagrafica a valori carattere
3750 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
3751
3752!> volume di attributi di anagrafica a valori reali
3753 REAL,POINTER :: volanaattrr(:,:,:,:)
3754!> volume di attributi di anagrafica a valori a doppia precisione
3755 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
3756!> volume di attributi di anagrafica a valori interi
3757 INTEGER,POINTER :: volanaattri(:,:,:,:)
3758!> volume di attributi di anagrafica a valori byte
3759 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
3760!> volume di attributi di anagrafica a valori carattere
3761 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
3762
3763!> volume di dati a valori reali
3764 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
3765!> volume di dati a valori a doppia precisione
3766 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
3767!> volume di dati a valori interi
3768 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
3769!> volume di dati a valori byte
3770 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
3771!> volume di dati a valori carattere
3772 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
3773
3774!> volume di attributi di dati a valori reali
3775 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
3776!> volume di attributi di dati a valori a doppia precisione
3777 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
3778!> volume di attributi di dati a valori interi
3779 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
3780!> volume di attributi di dati a valori byte
3781 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
3782!> volume di attributi di dati a valori carattere
3783 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
3784
3785!> time definition; 0=time is reference time, 1=time is validity time
3786 integer :: time_definition
3787
3789
3790!> Costruttore per la classe vol7d.
3791!! Deve essere richiamato
3792!! per tutti gli oggetti di questo tipo definiti in un programma.
3794 MODULE PROCEDURE vol7d_init
3795END INTERFACE
3796
3797!> Distruttore per la classe vol7d.
3799 MODULE PROCEDURE vol7d_delete
3800END INTERFACE
3801
3802!> Scrittura su file.
3804 MODULE PROCEDURE vol7d_write_on_file
3805END INTERFACE
3806
3807!> Lettura da file.
3808INTERFACE import
3809 MODULE PROCEDURE vol7d_read_from_file
3810END INTERFACE
3811
3812!>Print object
3814 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
3815END INTERFACE
3816
3817!>Represent data in a pretty string
3819 MODULE PROCEDURE to_char_dat
3820END INTERFACE
3821
3822!>doubleprecision data conversion
3824 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3825END INTERFACE
3826
3827!>real data conversion
3829 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
3830END INTERFACE
3831
3832!>integer data conversion
3834 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
3835END INTERFACE
3836
3837!>copy object
3839 MODULE PROCEDURE vol7d_copy
3840END INTERFACE
3841
3842!> Test for a missing volume
3844 MODULE PROCEDURE vol7d_c_e
3845END INTERFACE
3846
3847!> Check for problems
3848!! return 0 if all check passed
3849!! print diagnostics with log4f
3851 MODULE PROCEDURE vol7d_check
3852END INTERFACE
3853
3854!> Reduce some dimensions (level and timerage) for semplification (rounding).
3855!! You can use this for simplify and use variables in computation like alchimia
3856!! where fields have to be on the same coordinate
3857!! It return real or character data only: if input is charcter data only it return character otherwise il return
3858!! all the data converted to real.
3859!! examples:
3860!! means in time for short periods and istantaneous values
3861!! 2 meter and surface levels
3862!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
3863!! will be taken (order is by icreasing var index).
3864!! You can use predefined values for classic semplification
3865!! almost_equal_levels and almost_equal_timeranges
3866!! The level or timerange in output will be defined by the first element of level and timerange list
3868 MODULE PROCEDURE v7d_rounding
3869END INTERFACE
3870
3871!!$INTERFACE get_volana
3872!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
3873!!$ vol7d_get_volanab, vol7d_get_volanac
3874!!$END INTERFACE
3875!!$
3876!!$INTERFACE get_voldati
3877!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
3878!!$ vol7d_get_voldatib, vol7d_get_voldatic
3879!!$END INTERFACE
3880!!$
3881!!$INTERFACE get_volanaattr
3882!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
3883!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
3884!!$END INTERFACE
3885!!$
3886!!$INTERFACE get_voldatiattr
3887!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
3888!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
3889!!$END INTERFACE
3890
3891PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
3892 vol7d_get_volc, &
3893 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
3894 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
3895 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
3896 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
3897 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
3898 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
3899 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
3900 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
3901 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
3902 vol7d_display, dat_display, dat_vect_display, &
3903 to_char_dat, vol7d_check
3904
3905PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3906
3907PRIVATE vol7d_c_e
3908
3909CONTAINS
3910
3911
3912!> Inizializza un oggetto di tipo vol7d.
3913!! Non riceve alcun parametro tranne l'oggetto stesso. Attenzione, è necessario
3914!! comunque chiamare sempre il costruttore per evitare di avere dei puntatori in
3915!! uno stato indefinito.
3916SUBROUTINE vol7d_init(this,time_definition)
3917TYPE(vol7d),intent(out) :: this !< oggetto da inizializzare
3918integer,INTENT(IN),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1)
3919
3926CALL vol7d_var_features_init() ! initialise var features table once
3927
3928NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
3929
3930NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
3931NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
3932NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
3933NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
3934NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
3935
3936if(present(time_definition)) then
3937 this%time_definition=time_definition
3938else
3939 this%time_definition=1 !default to validity time
3940end if
3941
3942END SUBROUTINE vol7d_init
3943
3944
3945!> Distrugge l'oggetto in maniera pulita, liberando l'eventuale memoria
3946!! dinamicamente allocata. Permette di distruggere la sola parte di dati
3947!! mantenendo l'anagrafica.
3948ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
3949TYPE(vol7d),intent(inout) :: this !< oggetto da distruggere
3950LOGICAL, INTENT(in), OPTIONAL :: dataonly !< dealloca solo i dati, tenendo l'anagrafica, (default \c .FALSE.)
3951
3952
3953IF (.NOT. optio_log(dataonly)) THEN
3954 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
3955 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
3956 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
3957 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
3958 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
3959 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
3960 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
3961 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
3962 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
3963 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
3964ENDIF
3965IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
3966IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
3967IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
3968IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
3969IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
3970IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
3971IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
3972IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
3973IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
3974IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
3975
3976IF (.NOT. optio_log(dataonly)) THEN
3977 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
3978 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
3979ENDIF
3980IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
3981IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
3982IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
3983
3984IF (.NOT. optio_log(dataonly)) THEN
3988ENDIF
3992
3993END SUBROUTINE vol7d_delete
3994
3995
3996
3997integer function vol7d_check(this)
3998TYPE(vol7d),intent(in) :: this !< object to check
3999integer :: i,j,k,l,m,n
4000
4001vol7d_check=0
4002
4003if (associated(this%voldatii)) then
4004do i = 1,size(this%voldatii,1)
4005 do j = 1,size(this%voldatii,2)
4006 do k = 1,size(this%voldatii,3)
4007 do l = 1,size(this%voldatii,4)
4008 do m = 1,size(this%voldatii,5)
4009 do n = 1,size(this%voldatii,6)
4010 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4011 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4013 vol7d_check=1
4014 end if
4015 end do
4016 end do
4017 end do
4018 end do
4019 end do
4020end do
4021end if
4022
4023
4024if (associated(this%voldatir)) then
4025do i = 1,size(this%voldatir,1)
4026 do j = 1,size(this%voldatir,2)
4027 do k = 1,size(this%voldatir,3)
4028 do l = 1,size(this%voldatir,4)
4029 do m = 1,size(this%voldatir,5)
4030 do n = 1,size(this%voldatir,6)
4031 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4032 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4034 vol7d_check=2
4035 end if
4036 end do
4037 end do
4038 end do
4039 end do
4040 end do
4041end do
4042end if
4043
4044if (associated(this%voldatid)) then
4045do i = 1,size(this%voldatid,1)
4046 do j = 1,size(this%voldatid,2)
4047 do k = 1,size(this%voldatid,3)
4048 do l = 1,size(this%voldatid,4)
4049 do m = 1,size(this%voldatid,5)
4050 do n = 1,size(this%voldatid,6)
4051 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4052 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4054 vol7d_check=3
4055 end if
4056 end do
4057 end do
4058 end do
4059 end do
4060 end do
4061end do
4062end if
4063
4064if (associated(this%voldatib)) then
4065do i = 1,size(this%voldatib,1)
4066 do j = 1,size(this%voldatib,2)
4067 do k = 1,size(this%voldatib,3)
4068 do l = 1,size(this%voldatib,4)
4069 do m = 1,size(this%voldatib,5)
4070 do n = 1,size(this%voldatib,6)
4071 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4072 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4074 vol7d_check=4
4075 end if
4076 end do
4077 end do
4078 end do
4079 end do
4080 end do
4081end do
4082end if
4083
4084end function vol7d_check
4085
4086
4087
4088!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4089!> stampa a video una sintesi del contenuto
4090SUBROUTINE vol7d_display(this)
4091TYPE(vol7d),intent(in) :: this !< oggetto da visualizzare
4092integer :: i
4093
4094REAL :: rdat
4095DOUBLE PRECISION :: ddat
4096INTEGER :: idat
4097INTEGER(kind=int_b) :: bdat
4098CHARACTER(len=vol7d_cdatalen) :: cdat
4099
4100
4101print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4102if (this%time_definition == 0) then
4103 print*,"TIME DEFINITION: time is reference time"
4104else if (this%time_definition == 1) then
4105 print*,"TIME DEFINITION: time is validity time"
4106else
4107 print*,"Time definition have a wrong walue:", this%time_definition
4108end if
4109
4110IF (ASSOCIATED(this%network))then
4111 print*,"---- network vector ----"
4112 print*,"elements=",size(this%network)
4113 do i=1, size(this%network)
4115 end do
4116end IF
4117
4118IF (ASSOCIATED(this%ana))then
4119 print*,"---- ana vector ----"
4120 print*,"elements=",size(this%ana)
4121 do i=1, size(this%ana)
4123 end do
4124end IF
4125
4126IF (ASSOCIATED(this%time))then
4127 print*,"---- time vector ----"
4128 print*,"elements=",size(this%time)
4129 do i=1, size(this%time)
4131 end do
4132end if
4133
4134IF (ASSOCIATED(this%level)) then
4135 print*,"---- level vector ----"
4136 print*,"elements=",size(this%level)
4137 do i =1,size(this%level)
4139 end do
4140end if
4141
4142IF (ASSOCIATED(this%timerange))then
4143 print*,"---- timerange vector ----"
4144 print*,"elements=",size(this%timerange)
4145 do i =1,size(this%timerange)
4147 end do
4148end if
4149
4150
4151print*,"---- ana vector ----"
4152print*,""
4153print*,"->>>>>>>>> anavar -"
4155print*,""
4156print*,"->>>>>>>>> anaattr -"
4158print*,""
4159print*,"->>>>>>>>> anavarattr -"
4161
4162print*,"-- ana data section (first point) --"
4163
4164idat=imiss
4165rdat=rmiss
4166ddat=dmiss
4167bdat=ibmiss
4168cdat=cmiss
4169
4170!ntime = MIN(SIZE(this%time),nprint)
4171!ntimerange = MIN(SIZE(this%timerange),nprint)
4172!nlevel = MIN(SIZE(this%level),nprint)
4173!nnetwork = MIN(SIZE(this%network),nprint)
4174!nana = MIN(SIZE(this%ana),nprint)
4175
4176IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4177if (associated(this%volanai)) then
4178 do i=1,size(this%anavar%i)
4179 idat=this%volanai(1,i,1)
4181 end do
4182end if
4183idat=imiss
4184
4185if (associated(this%volanar)) then
4186 do i=1,size(this%anavar%r)
4187 rdat=this%volanar(1,i,1)
4189 end do
4190end if
4191rdat=rmiss
4192
4193if (associated(this%volanad)) then
4194 do i=1,size(this%anavar%d)
4195 ddat=this%volanad(1,i,1)
4197 end do
4198end if
4199ddat=dmiss
4200
4201if (associated(this%volanab)) then
4202 do i=1,size(this%anavar%b)
4203 bdat=this%volanab(1,i,1)
4205 end do
4206end if
4207bdat=ibmiss
4208
4209if (associated(this%volanac)) then
4210 do i=1,size(this%anavar%c)
4211 cdat=this%volanac(1,i,1)
4213 end do
4214end if
4215cdat=cmiss
4216ENDIF
4217
4218print*,"---- data vector ----"
4219print*,""
4220print*,"->>>>>>>>> dativar -"
4222print*,""
4223print*,"->>>>>>>>> datiattr -"
4225print*,""
4226print*,"->>>>>>>>> dativarattr -"
4228
4229print*,"-- data data section (first point) --"
4230
4231idat=imiss
4232rdat=rmiss
4233ddat=dmiss
4234bdat=ibmiss
4235cdat=cmiss
4236
4237IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4238 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4239if (associated(this%voldatii)) then
4240 do i=1,size(this%dativar%i)
4241 idat=this%voldatii(1,1,1,1,i,1)
4243 end do
4244end if
4245idat=imiss
4246
4247if (associated(this%voldatir)) then
4248 do i=1,size(this%dativar%r)
4249 rdat=this%voldatir(1,1,1,1,i,1)
4251 end do
4252end if
4253rdat=rmiss
4254
4255if (associated(this%voldatid)) then
4256 do i=1,size(this%dativar%d)
4257 ddat=this%voldatid(1,1,1,1,i,1)
4259 end do
4260end if
4261ddat=dmiss
4262
4263if (associated(this%voldatib)) then
4264 do i=1,size(this%dativar%b)
4265 bdat=this%voldatib(1,1,1,1,i,1)
4267 end do
4268end if
4269bdat=ibmiss
4270
4271if (associated(this%voldatic)) then
4272 do i=1,size(this%dativar%c)
4273 cdat=this%voldatic(1,1,1,1,i,1)
4275 end do
4276end if
4277cdat=cmiss
4278ENDIF
4279
4280print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4281
4282END SUBROUTINE vol7d_display
4283
4284
4285!> stampa a video una sintesi del contenuto
4286SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4287TYPE(vol7d_var),intent(in) :: this !< oggetto da visualizzare
4288!> real
4289REAL :: rdat
4290!> double precision
4291DOUBLE PRECISION :: ddat
4292!> integer
4293INTEGER :: idat
4294!> byte
4295INTEGER(kind=int_b) :: bdat
4296!> character
4297CHARACTER(len=*) :: cdat
4298
4299print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4300
4301end SUBROUTINE dat_display
4302
4303!> stampa a video una sintesi del contenuto
4304SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4305
4306TYPE(vol7d_var),intent(in) :: this(:) !< oggetto da visualizzare
4307!> real
4308REAL :: rdat(:)
4309!> double precision
4310DOUBLE PRECISION :: ddat(:)
4311!> integer
4312INTEGER :: idat(:)
4313!> byte
4314INTEGER(kind=int_b) :: bdat(:)
4315!> character
4316CHARACTER(len=*):: cdat(:)
4317
4318integer :: i
4319
4320do i =1,size(this)
4322end do
4323
4324end SUBROUTINE dat_vect_display
4325
4326
4327FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4328#ifdef HAVE_DBALLE
4329USE dballef
4330#endif
4331TYPE(vol7d_var),INTENT(in) :: this
4332!> real
4333REAL :: rdat
4334!> double precision
4335DOUBLE PRECISION :: ddat
4336!> integer
4337INTEGER :: idat
4338!> byte
4339INTEGER(kind=int_b) :: bdat
4340!> character
4341CHARACTER(len=*) :: cdat
4342CHARACTER(len=80) :: to_char_dat
4343
4344CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4345
4346
4347#ifdef HAVE_DBALLE
4348INTEGER :: handle, ier
4349
4350handle = 0
4351to_char_dat="VALUE: "
4352
4357
4359 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4360 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4361 ier = idba_fatto(handle)
4362 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4363endif
4364
4365#else
4366
4367to_char_dat="VALUE: "
4373
4374#endif
4375
4376END FUNCTION to_char_dat
4377
4378
4379!> Tests whether anything has ever been assigned to a vol7d object
4380!! (.TRUE.) or it is as clean as after an init (.FALSE.).
4381FUNCTION vol7d_c_e(this) RESULT(c_e)
4382TYPE(vol7d), INTENT(in) :: this
4383
4384LOGICAL :: c_e
4385
4387 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
4388 ASSOCIATED(this%network) .OR. &
4389 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4390 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4391 ASSOCIATED(this%anavar%c) .OR. &
4392 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
4393 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
4394 ASSOCIATED(this%anaattr%c) .OR. &
4395 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4396 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4397 ASSOCIATED(this%dativar%c) .OR. &
4398 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
4399 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
4400 ASSOCIATED(this%datiattr%c)
4401
4402END FUNCTION vol7d_c_e
4403
4404
4405!> Metodo per allocare i descrittori delle 7 dimensioni.
4406!! Riceve un grande numero di parametri opzionali che
4407!! indicano quali descrittori allocare e con quale estensione;
4408!! i descrittori non specificati non vengono toccati.
4409!! Può essere quindi chiamato più volte allocando via via
4410!! descrittori relativi a dimensioni diverse.
4411!! Se un descrittore richiesto è già allocato, viene deallocato
4412!! (perdendone l'eventuale contenuto) e riallocato con l'estensione
4413!! richiesta.
4414!! Per i descrittori relativi a dimensioni che non siano variabili o attributi,
4415!! è possibile specificare l'estensione di una dimensione a 0,
4416!! in tal caso il descrittore viene comunque allocato con lunghezza nulla,
4417!! che è diverso da non allocarlo. Per i descrittori di variabili e attributi
4418!! passare un'estensione 0 equivale a non fornire il parametro.
4419!! Avere uno o più descrittori dimensionati con estensione nulla fa sì
4420!! che anche il volume dati successivamente allocato abbia estensione nulla;
4421!! sebbene ciò appaia inutile, un volume del genere può in realtà servire,
4422!! in associazione ai metodi ::vol7d_merge o ::vol7d_append per estendere
4423!! un volume esistente aggiungendo elementi in alcune dimensioni (quelle
4424!! a estensione non nulla, ovviamente) e mantenendo invariato tutto il resto.
4425!! Per quanto riguarda i descrittori delle dimensioni relative alle
4426!! variabili, la relativa estensione è specificata con la nomenclatura
4427!! \a n<x><y><z> dove <x> può valere:
4428!! - \a ana per variabili relative a voumi di anagrafica
4429!! - \a dati per variabili relative a voumi di dati
4430!!
4431!! <y> può valere:
4432!! - \a var per variabili
4433!! - \a attr per attributi
4434!! - \a varattr variabili aventi attributi nei volumi di attributi
4435!!
4436!! <z> può valere:
4437!! - \a r per variabili o attributi a valori reali
4438!! - \a d per variabili o attributi a valori a doppia precisione
4439!! - \a i per variabili o attributi a valori interi
4440!! - \a b per variabili o attributi a valori byte
4441!! - \a c per variabili o attributi a valori carattere
4442!!
4443SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
4444 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4445 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4446 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4447 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4448 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4449 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
4450 ini)
4451TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i descrittori
4452INTEGER,INTENT(in),OPTIONAL :: nana !< estensione della dimensione anagrafica
4453INTEGER,INTENT(in),OPTIONAL :: ntime !< estensione della dimensione tempo
4454INTEGER,INTENT(in),OPTIONAL :: nlevel !< estensione della dimensione livello varticale
4455INTEGER,INTENT(in),OPTIONAL :: ntimerange !< estensione della dimensione intervallo temporale (timerange)
4456INTEGER,INTENT(in),OPTIONAL :: nnetwork !< estensione della dimensione rete
4457!> estensione delle possibili dimensioni variabile
4458INTEGER,INTENT(in),OPTIONAL :: &
4459 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4460 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4461 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4462 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4463 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4464 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
4465LOGICAL,INTENT(in),OPTIONAL :: ini !< se fornito e vale \c .TRUE., viene chiamato il costruttore, senza parametri opzionali, per ogni elemento di tutti i descrittori allocati, inizializzandolo quindi a valore mancante
4466
4467INTEGER :: i
4468LOGICAL :: linit
4469
4470IF (PRESENT(ini)) THEN
4471 linit = ini
4472ELSE
4473 linit = .false.
4474ENDIF
4475
4476! Dimensioni principali
4477IF (PRESENT(nana)) THEN
4478 IF (nana >= 0) THEN
4479 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4480 ALLOCATE(this%ana(nana))
4481 IF (linit) THEN
4482 DO i = 1, nana
4484 ENDDO
4485 ENDIF
4486 ENDIF
4487ENDIF
4488IF (PRESENT(ntime)) THEN
4489 IF (ntime >= 0) THEN
4490 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4491 ALLOCATE(this%time(ntime))
4492 IF (linit) THEN
4493 DO i = 1, ntime
4495 ENDDO
4496 ENDIF
4497 ENDIF
4498ENDIF
4499IF (PRESENT(nlevel)) THEN
4500 IF (nlevel >= 0) THEN
4501 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4502 ALLOCATE(this%level(nlevel))
4503 IF (linit) THEN
4504 DO i = 1, nlevel
4506 ENDDO
4507 ENDIF
4508 ENDIF
4509ENDIF
4510IF (PRESENT(ntimerange)) THEN
4511 IF (ntimerange >= 0) THEN
4512 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4513 ALLOCATE(this%timerange(ntimerange))
4514 IF (linit) THEN
4515 DO i = 1, ntimerange
4517 ENDDO
4518 ENDIF
4519 ENDIF
4520ENDIF
4521IF (PRESENT(nnetwork)) THEN
4522 IF (nnetwork >= 0) THEN
4523 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4524 ALLOCATE(this%network(nnetwork))
4525 IF (linit) THEN
4526 DO i = 1, nnetwork
4528 ENDDO
4529 ENDIF
4530 ENDIF
4531ENDIF
4532! Dimensioni dei tipi delle variabili
4533CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
4534 nanavari, nanavarb, nanavarc, ini)
4535CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
4536 nanaattri, nanaattrb, nanaattrc, ini)
4537CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
4538 nanavarattri, nanavarattrb, nanavarattrc, ini)
4539CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
4540 ndativari, ndativarb, ndativarc, ini)
4541CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
4542 ndatiattri, ndatiattrb, ndatiattrc, ini)
4543CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
4544 ndativarattri, ndativarattrb, ndativarattrc, ini)
4545
4546END SUBROUTINE vol7d_alloc
4547
4548
4549FUNCTION vol7d_check_alloc_ana(this)
4550TYPE(vol7d),INTENT(in) :: this
4551LOGICAL :: vol7d_check_alloc_ana
4552
4553vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
4554
4555END FUNCTION vol7d_check_alloc_ana
4556
4557SUBROUTINE vol7d_force_alloc_ana(this, ini)
4558TYPE(vol7d),INTENT(inout) :: this
4559LOGICAL,INTENT(in),OPTIONAL :: ini
4560
4561! Alloco i descrittori minimi per avere un volume di anagrafica
4562IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
4563IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
4564
4565END SUBROUTINE vol7d_force_alloc_ana
4566
4567
4568FUNCTION vol7d_check_alloc_dati(this)
4569TYPE(vol7d),INTENT(in) :: this
4570LOGICAL :: vol7d_check_alloc_dati
4571
4572vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
4573 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
4574 ASSOCIATED(this%timerange)
4575
4576END FUNCTION vol7d_check_alloc_dati
4577
4578SUBROUTINE vol7d_force_alloc_dati(this, ini)
4579TYPE(vol7d),INTENT(inout) :: this
4580LOGICAL,INTENT(in),OPTIONAL :: ini
4581
4582! Alloco i descrittori minimi per avere un volume di dati
4583CALL vol7d_force_alloc_ana(this, ini)
4584IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
4585IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
4586IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
4587
4588END SUBROUTINE vol7d_force_alloc_dati
4589
4590
4591SUBROUTINE vol7d_force_alloc(this)
4592TYPE(vol7d),INTENT(inout) :: this
4593
4594! If anything really not allocated yet, allocate with size 0
4595IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
4596IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
4597IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
4598IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
4599IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
4600
4601END SUBROUTINE vol7d_force_alloc
4602
4603
4604FUNCTION vol7d_check_vol(this)
4605TYPE(vol7d),INTENT(in) :: this !< oggetto da controllare
4606LOGICAL :: vol7d_check_vol
4607
4608vol7d_check_vol = c_e(this)
4609
4610! Anagrafica
4611IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4612 vol7d_check_vol = .false.
4613ENDIF
4614
4615IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4616 vol7d_check_vol = .false.
4617ENDIF
4618
4619IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4620 vol7d_check_vol = .false.
4621ENDIF
4622
4623IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4624 vol7d_check_vol = .false.
4625ENDIF
4626
4627IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4628 vol7d_check_vol = .false.
4629ENDIF
4630IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4631 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4632 ASSOCIATED(this%anavar%c)) THEN
4633 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
4634ENDIF
4635
4636! Attributi dell'anagrafica
4637IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4638 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4639 vol7d_check_vol = .false.
4640ENDIF
4641
4642IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4643 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4644 vol7d_check_vol = .false.
4645ENDIF
4646
4647IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4648 .NOT.ASSOCIATED(this%volanaattri)) THEN
4649 vol7d_check_vol = .false.
4650ENDIF
4651
4652IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4653 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4654 vol7d_check_vol = .false.
4655ENDIF
4656
4657IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4658 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4659 vol7d_check_vol = .false.
4660ENDIF
4661
4662! Dati
4663IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4664 vol7d_check_vol = .false.
4665ENDIF
4666
4667IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4668 vol7d_check_vol = .false.
4669ENDIF
4670
4671IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4672 vol7d_check_vol = .false.
4673ENDIF
4674
4675IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4676 vol7d_check_vol = .false.
4677ENDIF
4678
4679IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4680 vol7d_check_vol = .false.
4681ENDIF
4682
4683! Attributi dei dati
4684IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4685 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4686 vol7d_check_vol = .false.
4687ENDIF
4688
4689IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4690 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4691 vol7d_check_vol = .false.
4692ENDIF
4693
4694IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4695 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4696 vol7d_check_vol = .false.
4697ENDIF
4698
4699IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4700 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4701 vol7d_check_vol = .false.
4702ENDIF
4703
4704IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4705 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4706 vol7d_check_vol = .false.
4707ENDIF
4708IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4709 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4710 ASSOCIATED(this%dativar%c)) THEN
4711 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
4712ENDIF
4713
4714END FUNCTION vol7d_check_vol
4715
4716
4717!> Metodo per allocare i volumi richiesti di variabili e attributi per
4718!! anagrafica e dati.
4719!! Se alcuni dei descrittori relativi alle dimensioni anagrafica,
4720!! livello verticale, tempo, intervallo temporale (timerange), rete non sono
4721!! stati richiesti preventivamente con la ::vol7d_alloc, essi vengono allocati
4722!! automaticamente da questo metodo
4723!! con estensione di default pari a 1 (non 0!), questo significa, ad esempio,
4724!! che se prevedo di avere soli dati superficiali, cioè ad un solo livello
4725!! verticale, o una sola rete di stazioni, non devo preoccuparmi di
4726!! specificare questa informazione.
4727!! Tra i 20 possibili volumi allocabili
4728!! ((variabili,attributi)*(anagrafica,dati)*(r,d,i,b,c)=20)
4729!! saranno allocati solo quelli per cui è stato precedentemente richiesto il
4730!! corrispondente descrittore variabili/attributi con la ::vol7d_alloc.
4731SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
4732TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i volumi
4733LOGICAL,INTENT(in),OPTIONAL :: ini !< se fornito e vale \c .TRUE., viene chiamato il costruttore, senza parametri opzionali, per ogni elemento di tutti i descrittori allocati
4734LOGICAL,INTENT(in),OPTIONAL :: inivol !< se fornito e vale \c .TRUE., i volumi allocati saranno inizializzati a valore mancante
4735
4736LOGICAL :: linivol
4737
4738IF (PRESENT(inivol)) THEN
4739 linivol = inivol
4740ELSE
4741 linivol = .true.
4742ENDIF
4743
4744! Anagrafica
4745IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4746 CALL vol7d_force_alloc_ana(this, ini)
4747 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
4748 IF (linivol) this%volanar(:,:,:) = rmiss
4749ENDIF
4750
4751IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4752 CALL vol7d_force_alloc_ana(this, ini)
4753 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
4754 IF (linivol) this%volanad(:,:,:) = rdmiss
4755ENDIF
4756
4757IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4758 CALL vol7d_force_alloc_ana(this, ini)
4759 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
4760 IF (linivol) this%volanai(:,:,:) = imiss
4761ENDIF
4762
4763IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4764 CALL vol7d_force_alloc_ana(this, ini)
4765 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
4766 IF (linivol) this%volanab(:,:,:) = ibmiss
4767ENDIF
4768
4769IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4770 CALL vol7d_force_alloc_ana(this, ini)
4771 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
4772 IF (linivol) this%volanac(:,:,:) = cmiss
4773ENDIF
4774
4775! Attributi dell'anagrafica
4776IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4777 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4778 CALL vol7d_force_alloc_ana(this, ini)
4779 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
4780 SIZE(this%network), SIZE(this%anaattr%r)))
4781 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
4782ENDIF
4783
4784IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4785 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4786 CALL vol7d_force_alloc_ana(this, ini)
4787 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
4788 SIZE(this%network), SIZE(this%anaattr%d)))
4789 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
4790ENDIF
4791
4792IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4793 .NOT.ASSOCIATED(this%volanaattri)) THEN
4794 CALL vol7d_force_alloc_ana(this, ini)
4795 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
4796 SIZE(this%network), SIZE(this%anaattr%i)))
4797 IF (linivol) this%volanaattri(:,:,:,:) = imiss
4798ENDIF
4799
4800IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4801 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4802 CALL vol7d_force_alloc_ana(this, ini)
4803 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
4804 SIZE(this%network), SIZE(this%anaattr%b)))
4805 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
4806ENDIF
4807
4808IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4809 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4810 CALL vol7d_force_alloc_ana(this, ini)
4811 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
4812 SIZE(this%network), SIZE(this%anaattr%c)))
4813 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
4814ENDIF
4815
4816! Dati
4817IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4818 CALL vol7d_force_alloc_dati(this, ini)
4819 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4820 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
4821 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
4822ENDIF
4823
4824IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4825 CALL vol7d_force_alloc_dati(this, ini)
4826 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4827 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
4828 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
4829ENDIF
4830
4831IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4832 CALL vol7d_force_alloc_dati(this, ini)
4833 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4834 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
4835 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
4836ENDIF
4837
4838IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4839 CALL vol7d_force_alloc_dati(this, ini)
4840 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4841 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
4842 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
4843ENDIF
4844
4845IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4846 CALL vol7d_force_alloc_dati(this, ini)
4847 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4848 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
4849 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
4850ENDIF
4851
4852! Attributi dei dati
4853IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4854 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4855 CALL vol7d_force_alloc_dati(this, ini)
4856 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4857 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
4858 SIZE(this%datiattr%r)))
4859 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
4860ENDIF
4861
4862IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4863 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4864 CALL vol7d_force_alloc_dati(this, ini)
4865 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4866 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
4867 SIZE(this%datiattr%d)))
4868 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
4869ENDIF
4870
4871IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4872 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4873 CALL vol7d_force_alloc_dati(this, ini)
4874 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4875 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
4876 SIZE(this%datiattr%i)))
4877 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
4878ENDIF
4879
4880IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4881 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4882 CALL vol7d_force_alloc_dati(this, ini)
4883 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4884 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
4885 SIZE(this%datiattr%b)))
4886 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
4887ENDIF
4888
4889IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4890 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4891 CALL vol7d_force_alloc_dati(this, ini)
4892 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4893 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
4894 SIZE(this%datiattr%c)))
4895 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
4896ENDIF
4897
4898! Catch-all method
4899CALL vol7d_force_alloc(this)
4900
4901! Creo gli indici var-attr
4902
4903#ifdef DEBUG
4904CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
4905#endif
4906
4907CALL vol7d_set_attr_ind(this)
4908
4909
4910
4911END SUBROUTINE vol7d_alloc_vol
4912
4913
4914!> Metodo per creare gli indici che associano le variabili aventi attributo
4915!! alle variabili nei relativi descrittori.
4916!! Ha senso chiamare questo metodo solo dopo che i descrittori delle variabili
4917!! e degli attributi desiderati sono stati allocati ed è stato assegnato un
4918!! valore ai relativi membri btable (vedi vol7d_var_class::vol7d_var), se
4919!! i descrittori non sono stati allocati o assegnati, il metodo non fa niente.
4920SUBROUTINE vol7d_set_attr_ind(this)
4921TYPE(vol7d),INTENT(inout) :: this !< oggetto in cui creare gli indici
4922
4923INTEGER :: i
4924
4925! real
4926IF (ASSOCIATED(this%dativar%r)) THEN
4927 IF (ASSOCIATED(this%dativarattr%r)) THEN
4928 DO i = 1, SIZE(this%dativar%r)
4929 this%dativar%r(i)%r = &
4930 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
4931 ENDDO
4932 ENDIF
4933
4934 IF (ASSOCIATED(this%dativarattr%d)) THEN
4935 DO i = 1, SIZE(this%dativar%r)
4936 this%dativar%r(i)%d = &
4937 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
4938 ENDDO
4939 ENDIF
4940
4941 IF (ASSOCIATED(this%dativarattr%i)) THEN
4942 DO i = 1, SIZE(this%dativar%r)
4943 this%dativar%r(i)%i = &
4944 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
4945 ENDDO
4946 ENDIF
4947
4948 IF (ASSOCIATED(this%dativarattr%b)) THEN
4949 DO i = 1, SIZE(this%dativar%r)
4950 this%dativar%r(i)%b = &
4951 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
4952 ENDDO
4953 ENDIF
4954
4955 IF (ASSOCIATED(this%dativarattr%c)) THEN
4956 DO i = 1, SIZE(this%dativar%r)
4957 this%dativar%r(i)%c = &
4958 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
4959 ENDDO
4960 ENDIF
4961ENDIF
4962! double
4963IF (ASSOCIATED(this%dativar%d)) THEN
4964 IF (ASSOCIATED(this%dativarattr%r)) THEN
4965 DO i = 1, SIZE(this%dativar%d)
4966 this%dativar%d(i)%r = &
4967 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
4968 ENDDO
4969 ENDIF
4970
4971 IF (ASSOCIATED(this%dativarattr%d)) THEN
4972 DO i = 1, SIZE(this%dativar%d)
4973 this%dativar%d(i)%d = &
4974 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
4975 ENDDO
4976 ENDIF
4977
4978 IF (ASSOCIATED(this%dativarattr%i)) THEN
4979 DO i = 1, SIZE(this%dativar%d)
4980 this%dativar%d(i)%i = &
4981 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
4982 ENDDO
4983 ENDIF
4984
4985 IF (ASSOCIATED(this%dativarattr%b)) THEN
4986 DO i = 1, SIZE(this%dativar%d)
4987 this%dativar%d(i)%b = &
4988 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
4989 ENDDO
4990 ENDIF
4991
4992 IF (ASSOCIATED(this%dativarattr%c)) THEN
4993 DO i = 1, SIZE(this%dativar%d)
4994 this%dativar%d(i)%c = &
4995 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
4996 ENDDO
4997 ENDIF
4998ENDIF
4999! integer
5000IF (ASSOCIATED(this%dativar%i)) THEN
5001 IF (ASSOCIATED(this%dativarattr%r)) THEN
5002 DO i = 1, SIZE(this%dativar%i)
5003 this%dativar%i(i)%r = &
5004 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5005 ENDDO
5006 ENDIF
5007
5008 IF (ASSOCIATED(this%dativarattr%d)) THEN
5009 DO i = 1, SIZE(this%dativar%i)
5010 this%dativar%i(i)%d = &
5011 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5012 ENDDO
5013 ENDIF
5014
5015 IF (ASSOCIATED(this%dativarattr%i)) THEN
5016 DO i = 1, SIZE(this%dativar%i)
5017 this%dativar%i(i)%i = &
5018 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5019 ENDDO
5020 ENDIF
5021
5022 IF (ASSOCIATED(this%dativarattr%b)) THEN
5023 DO i = 1, SIZE(this%dativar%i)
5024 this%dativar%i(i)%b = &
5025 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5026 ENDDO
5027 ENDIF
5028
5029 IF (ASSOCIATED(this%dativarattr%c)) THEN
5030 DO i = 1, SIZE(this%dativar%i)
5031 this%dativar%i(i)%c = &
5032 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5033 ENDDO
5034 ENDIF
5035ENDIF
5036! byte
5037IF (ASSOCIATED(this%dativar%b)) THEN
5038 IF (ASSOCIATED(this%dativarattr%r)) THEN
5039 DO i = 1, SIZE(this%dativar%b)
5040 this%dativar%b(i)%r = &
5041 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5042 ENDDO
5043 ENDIF
5044
5045 IF (ASSOCIATED(this%dativarattr%d)) THEN
5046 DO i = 1, SIZE(this%dativar%b)
5047 this%dativar%b(i)%d = &
5048 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5049 ENDDO
5050 ENDIF
5051
5052 IF (ASSOCIATED(this%dativarattr%i)) THEN
5053 DO i = 1, SIZE(this%dativar%b)
5054 this%dativar%b(i)%i = &
5055 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5056 ENDDO
5057 ENDIF
5058
5059 IF (ASSOCIATED(this%dativarattr%b)) THEN
5060 DO i = 1, SIZE(this%dativar%b)
5061 this%dativar%b(i)%b = &
5062 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5063 ENDDO
5064 ENDIF
5065
5066 IF (ASSOCIATED(this%dativarattr%c)) THEN
5067 DO i = 1, SIZE(this%dativar%b)
5068 this%dativar%b(i)%c = &
5069 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5070 ENDDO
5071 ENDIF
5072ENDIF
5073! character
5074IF (ASSOCIATED(this%dativar%c)) THEN
5075 IF (ASSOCIATED(this%dativarattr%r)) THEN
5076 DO i = 1, SIZE(this%dativar%c)
5077 this%dativar%c(i)%r = &
5078 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5079 ENDDO
5080 ENDIF
5081
5082 IF (ASSOCIATED(this%dativarattr%d)) THEN
5083 DO i = 1, SIZE(this%dativar%c)
5084 this%dativar%c(i)%d = &
5085 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5086 ENDDO
5087 ENDIF
5088
5089 IF (ASSOCIATED(this%dativarattr%i)) THEN
5090 DO i = 1, SIZE(this%dativar%c)
5091 this%dativar%c(i)%i = &
5092 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5093 ENDDO
5094 ENDIF
5095
5096 IF (ASSOCIATED(this%dativarattr%b)) THEN
5097 DO i = 1, SIZE(this%dativar%c)
5098 this%dativar%c(i)%b = &
5099 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5100 ENDDO
5101 ENDIF
5102
5103 IF (ASSOCIATED(this%dativarattr%c)) THEN
5104 DO i = 1, SIZE(this%dativar%c)
5105 this%dativar%c(i)%c = &
5106 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5107 ENDDO
5108 ENDIF
5109ENDIF
5110
5111END SUBROUTINE vol7d_set_attr_ind
5112
5113
5114!> Metodo per fondere 2 oggetti vol7d.
5115!! Il secondo volume viene accodato al primo e poi distrutto, si veda
5116!! quindi la descrizione di ::vol7d_append. Se uno degli oggetti \a
5117!! this o \a that sono vuoti non perde tempo inutile,
5118SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5119 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5120TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, alla fine conterrà il risultato della fusione
5121TYPE(vol7d),INTENT(INOUT) :: that !< secondo oggetto in ingresso, alla fine sarà distrutto
5122LOGICAL,INTENT(IN),OPTIONAL :: sort !< se fornito e uguale a \c .TRUE., i descrittori che supportano un ordinamento (operatori > e/o <) risulteranno ordinati in ordine crescente nell'oggetto finale
5123LOGICAL,INTENT(in),OPTIONAL :: bestdata !< if provided and \a .TRUE. in case of overlapping volumes keep valid data where available, or data from the second volume if both valid
5124LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5125
5126TYPE(vol7d) :: v7d_clean
5127
5128
5130 this = that
5132 that = v7d_clean ! destroy that without deallocating
5133ELSE ! Append that to this and destroy that
5135 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5137ENDIF
5138
5139END SUBROUTINE vol7d_merge
5140
5141
5142!> Metodo per accodare un oggetto vol7d ad un altro.
5143!! Si tratta di un metodo molto potente e versatile;
5144!! i descrittori delle dimensioni del volume finale conterranno i valori
5145!! dei corrispondenti descrittori del primo e del secondo volume
5146!! e i volumi di anagrafica e dati conterranno i valori dei due volumi
5147!! ai posti giusti, e valori mancanti per le nuove combinazioni che
5148!! eventualmente si verranno a creare.
5149!! Se i volumi multidimensionali di anagrafica e/o dati dei 2 oggetti
5150!! hanno un'intersezione non nulla, negli elementi comuni il volume finale
5151!! conterrà il corrispondente elemento del \b secondo volume.
5152!! Attenzione che, durante l'esecuzione del metodo, la memoria richiesta è
5153!! pari alla memoria complessiva occupata dai 2 volumi iniziali più
5154!! la memoria complessiva del volume finale, per cui, nel caso di volumi grandi,
5155!! ci potrebbero essere problemi di esaurimento della memoria centrale.
5156!! Se l'oggetto \a that è vuoto non perde tempo inutile,
5157!!
5158!! \todo nel caso di elementi comuni inserire la possibiità (opzionale per
5159!! non penalizzare le prestazioni quando ciò non serve) di effettuare una scelta
5160!! più ragionata dell'elemento da tenere, almeno controllando i dati mancanti
5161!! se non le flag di qualità
5162!!
5163!! \todo "rateizzare" l'allocazione dei volumi per ridurre l'occupazione di
5164!! memoria nel caso siano allocati contemporaneamente volumi di variabili e
5165!! di attributi o più volumi di tipi diversi
5166!!
5167!! \todo il parametro \a that è dichiarato \a INOUT perché la vol7d_alloc_vol
5168!! può modificarlo, bisognerebbe implementare una vol7d_check_vol che restituisca
5169!! errore anziché usare la vol7d_alloc_vol.
5170SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5171 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5172TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, a cui sarà accodato il secondo
5173TYPE(vol7d),INTENT(IN) :: that !< secondo oggetto in ingresso, non viene modificato dal metodo
5174LOGICAL,INTENT(IN),OPTIONAL :: sort !< se fornito e uguale a \c .TRUE., i descrittori che supportano un ordinamento (operatori > e/o <) risulteranno ordinati in ordine crescente nell'oggetto finale
5175! experimental, please do not use outside the library now, they force the use
5176! of a simplified mapping algorithm which is valid only whene the dimension
5177! content is the same in both volumes , or when one of them is empty
5178LOGICAL,INTENT(in),OPTIONAL :: bestdata !< if provided and \a .TRUE. in case of overlapping volumes keep valid data where available, or data from the second volume if both valid
5179LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5180
5181
5182TYPE(vol7d) :: v7dtmp
5183LOGICAL :: lsort, lbestdata
5184INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5185 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5186
5188IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5191 RETURN
5192ENDIF
5193
5194IF (this%time_definition /= that%time_definition) THEN
5195 CALL l4f_log(l4f_fatal, &
5196 'in vol7d_append, cannot append volumes with different &
5197 &time definition')
5198 CALL raise_fatal_error()
5199ENDIF
5200
5201! Completo l'allocazione per avere volumi a norma
5202CALL vol7d_alloc_vol(this)
5203
5207
5208! Calcolo le mappature tra volumi vecchi e volume nuovo
5209! I puntatori remap* vengono tutti o allocati o nullificati
5210IF (optio_log(ltimesimple)) THEN
5211 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5212 lsort, remapt1, remapt2)
5213ELSE
5214 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5215 lsort, remapt1, remapt2)
5216ENDIF
5217IF (optio_log(ltimerangesimple)) THEN
5218 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5219 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5220ELSE
5221 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5222 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5223ENDIF
5224IF (optio_log(llevelsimple)) THEN
5225 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5226 lsort, remapl1, remapl2)
5227ELSE
5228 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5229 lsort, remapl1, remapl2)
5230ENDIF
5231IF (optio_log(lanasimple)) THEN
5232 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5233 .false., remapa1, remapa2)
5234ELSE
5235 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5236 .false., remapa1, remapa2)
5237ENDIF
5238IF (optio_log(lnetworksimple)) THEN
5239 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5240 .false., remapn1, remapn2)
5241ELSE
5242 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5243 .false., remapn1, remapn2)
5244ENDIF
5245
5246! Faccio la fusione fisica dei volumi
5247CALL vol7d_merge_finalr(this, that, v7dtmp, &
5248 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5249 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5250CALL vol7d_merge_finald(this, that, v7dtmp, &
5251 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5252 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5253CALL vol7d_merge_finali(this, that, v7dtmp, &
5254 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5255 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5256CALL vol7d_merge_finalb(this, that, v7dtmp, &
5257 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5258 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5259CALL vol7d_merge_finalc(this, that, v7dtmp, &
5260 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5261 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5262
5263! Dealloco i vettori di rimappatura
5264IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5265IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5266IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5267IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5268IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5269IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5270IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5271IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5272IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5273IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5274
5275! Distruggo il vecchio volume e assegno il nuovo a this
5277this = v7dtmp
5278! Ricreo gli indici var-attr
5279CALL vol7d_set_attr_ind(this)
5280
5281END SUBROUTINE vol7d_append
5282
5283
5284!> Metodo per creare una copia completa e indipendente di un oggetto vol7d.
5285!! Questo metodo crea un duplicato di tutti i membri di un oggetto vol7d,
5286!! con la possibilità di rielaborarlo durante la copia. Se l'oggetto da copiare
5287!! è vuoto non perde tempo inutile.
5288!! Attenzione, il codice:
5289!! \code
5290!! USE vol7d_class
5291!! TYPE(vol7d) :: vol1, vol2
5292!! CALL init(vol1)
5293!! CALL init(vol2)
5294!! ... ! riempio vol1
5295!! vol2 = vol1
5296!! \endcode
5297!! fa una cosa diversa rispetto a:
5298!! \code
5299!! USE vol7d_class
5300!! TYPE(vol7d) :: vol1, vol2
5301!! CALL init(vol1)
5302!! CALL init(vol2)
5303!! ... ! riempio vol1
5304!! CALL vol7d_copy(vol1, vol2)
5305!! \endcode
5306!! nel primo caso, infatti, l'operatore di assegnazione copia solo i componenti
5307!! statici di \a vol1 nei corrispondenti elementi di \a vol2, mentre i componenti che
5308!! sono allocati dinamicamente (cioè quelli che in ::vol7d hanno l'attributo
5309!! \c POINTER, in pratica quasi tutti) non vengono duplicati, ma per essi vol2
5310!! conterrà un puntatore al corrispondente elemento a cui già punta vol1, e quindi
5311!! eventuali cambiamenti al contenuto di uno dei due oggetti influenzerà il
5312!! contenuto dell'altro; nel secondo caso, invece, vol1 e vol2 sono, dopo la
5313!! vol7d_copy, 2 istanze
5314!! completamente indipendenti, ma uguali tra loro per contenuto, della classe
5315!! vol7d, e quindi hanno vita indipendente.
5316SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5317 lsort_time, lsort_timerange, lsort_level, &
5318 ltime, ltimerange, llevel, lana, lnetwork, &
5319 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5320 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5321 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5322 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5323 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5324 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5325TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
5326TYPE(vol7d),INTENT(INOUT) :: that !< oggetto destinazione
5327LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
5328LOGICAL,INTENT(IN),OPTIONAL :: unique !< se fornito e uguale a \c .TRUE., gli eventuali elementi duplicati nei descrittori dell'oggetto iniziale verranno collassati in un unico elemento (con eventuale perdita dei dati relativi agli elementi duplicati)
5329LOGICAL,INTENT(IN),OPTIONAL :: miss !< se fornito e uguale a \c .TRUE., gli eventuali elementi dei descrittori uguali al corrispondente valore mancante verranno eliminati dall'oggetto riformato
5330LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
5331LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
5332LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
5333!> se fornito, deve essere un vettore logico della stessa lunghezza di
5334!! this%time indicante quali elementi della dimensione \a time
5335!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
5336!! nel volume copiato; in alternativa può essere un vettore di
5337!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
5338!! gli elementi (utile principalmente per le variabili); è compatibile
5339!! col parametro \a miss
5340LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5341!> come il precedente per la dimensione \a timerange
5342LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5343!> come il precedente per la dimensione \a level
5344LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5345!> come il precedente per la dimensione \a ana
5346LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5347!> come il precedente per la dimensione \a network
5348LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5349!> come il precedente per tutte le possibili dimensioni variabile
5350LOGICAL,INTENT(in),OPTIONAL :: &
5351 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5352 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5353 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5354 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5355 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5356 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5357
5358LOGICAL :: lsort, lunique, lmiss
5359INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5360
5363IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5364
5368
5369! Calcolo le mappature tra volume vecchio e volume nuovo
5370! I puntatori remap* vengono tutti o allocati o nullificati
5371CALL vol7d_remap1_datetime(this%time, that%time, &
5372 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
5373CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
5374 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
5375CALL vol7d_remap1_vol7d_level(this%level, that%level, &
5376 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
5377CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
5378 lsort, lunique, lmiss, remapa, lana)
5379CALL vol7d_remap1_vol7d_network(this%network, that%network, &
5380 lsort, lunique, lmiss, remapn, lnetwork)
5381
5382! lanavari, lanavarb, lanavarc, &
5383! lanaattri, lanaattrb, lanaattrc, &
5384! lanavarattri, lanavarattrb, lanavarattrc, &
5385! ldativari, ldativarb, ldativarc, &
5386! ldatiattri, ldatiattrb, ldatiattrc, &
5387! ldativarattri, ldativarattrb, ldativarattrc
5388! Faccio la riforma fisica dei volumi
5389CALL vol7d_reform_finalr(this, that, &
5390 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5391 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
5392CALL vol7d_reform_finald(this, that, &
5393 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5394 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
5395CALL vol7d_reform_finali(this, that, &
5396 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5397 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
5398CALL vol7d_reform_finalb(this, that, &
5399 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5400 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
5401CALL vol7d_reform_finalc(this, that, &
5402 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5403 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
5404
5405! Dealloco i vettori di rimappatura
5406IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
5407IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
5408IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
5409IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
5410IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
5411
5412! Ricreo gli indici var-attr
5413CALL vol7d_set_attr_ind(that)
5414that%time_definition = this%time_definition
5415
5416END SUBROUTINE vol7d_copy
5417
5418
5419!> Metodo per riformare in varie maniere un oggetto vol7d.
5420!! Equivale ad una copia (vedi ::vol7d_copy)
5421!! seguita dalla distruzione del volume iniziale e alla
5422!! sua riassegnazione al volume copiato. Ha senso se almeno uno dei parametri
5423!! \a sort, \a uniq o \a miss è fornito uguale a \c .TRUE., altrimenti
5424!! è solo una perdita di tempo.
5425!! Può essere utile, ad esempio, per eliminare stazioni
5426!! o istanti temporali indesiderati, basta assegnare il loro corrispondente
5427!! elemento del descrittore a valore mancante e chiamare vol7d_reform
5428!! con miss=.TRUE. .
5429SUBROUTINE vol7d_reform(this, sort, unique, miss, &
5430 lsort_time, lsort_timerange, lsort_level, &
5431 ltime, ltimerange, llevel, lana, lnetwork, &
5432 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5433 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5434 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5435 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5436 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5437 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
5438 ,purgeana)
5439TYPE(vol7d),INTENT(INOUT) :: this !< oggetto da riformare
5440LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
5441LOGICAL,INTENT(IN),OPTIONAL :: unique !< se fornito e uguale a \c .TRUE., gli eventuali elementi duplicati nei descrittori dell'oggetto iniziale verranno collassati in un unico elemento (con eventuale perdita dei dati relativi agli elementi duplicati)
5442LOGICAL,INTENT(IN),OPTIONAL :: miss !< se fornito e uguale a \c .TRUE., gli eventuali elementi dei descrittori uguali al corrispondente valore mancante verranno eliminati dall'oggetto riformato
5443LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
5444LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
5445LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
5446!> se fornito, deve essere un vettore logico della stessa lunghezza di
5447!! this%time indicante quali elementi della dimensione \a time
5448!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
5449!! nel volume copiato; in alternativa può essere un vettore di
5450!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
5451!! gli elementi (utile principalmente per le variabili); è compatibile
5452!! col parametro \a miss
5453LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5454LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:) !< come il precedente per la dimensione \a timerange
5455LOGICAL,INTENT(IN),OPTIONAL :: llevel(:) !< come il precedente per la dimensione \a level
5456LOGICAL,INTENT(IN),OPTIONAL :: lana(:) !< come il precedente per la dimensione \a ana
5457LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:) !< come il precedente per la dimensione \a network
5458!> come il precedente per tutte le possibili dimensioni variabile
5459LOGICAL,INTENT(in),OPTIONAL :: &
5460 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5461 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5462 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5463 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5464 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5465 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5466LOGICAL,INTENT(IN),OPTIONAL :: purgeana !< if true remove ana with all data missing
5467
5468TYPE(vol7d) :: v7dtmp
5469logical,allocatable :: llana(:)
5470integer :: i
5471
5473 lsort_time, lsort_timerange, lsort_level, &
5474 ltime, ltimerange, llevel, lana, lnetwork, &
5475 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5476 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5477 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5478 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5479 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5480 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5481
5482! destroy old volume
5484
5485if (optio_log(purgeana)) then
5486 allocate(llana(size(v7dtmp%ana)))
5487 llana =.false.
5488 do i =1,size(v7dtmp%ana)
5489 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
5490 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
5491 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
5492 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
5493 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
5494 end do
5495 CALL vol7d_copy(v7dtmp, this,lana=llana)
5497 deallocate(llana)
5498else
5499 this=v7dtmp
5500end if
5501
5502END SUBROUTINE vol7d_reform
5503
5504
5505!> Sorts the sortable dimensions in the volume \a this only when necessary.
5506!! Most of the times, the time, timerange and level dimensions in a
5507!! vol7d object are correctly sorted; on the other side many methods
5508!! strictly rely on this fact in order to work correctly. This method
5509!! performs a quick check and sorts the required dimensions only if
5510!! they are not sorted in ascending order yet, improving safety
5511!! without impairing much performance.
5512SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
5513TYPE(vol7d),INTENT(INOUT) :: this !< object to be sorted
5514LOGICAL,OPTIONAL,INTENT(in) :: lsort_time !< if present and \a .TRUE., sort time dimension if it is not sorted in ascending order
5515LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange !< if present and \a .TRUE., sort timerange dimension if it is not sorted in ascending order
5516LOGICAL,OPTIONAL,INTENT(in) :: lsort_level !< if present and \a .TRUE., sort vertical level dimension if it is not sorted in ascending order
5517
5518INTEGER :: i
5519LOGICAL :: to_be_sorted
5520
5521to_be_sorted = .false.
5522CALL vol7d_alloc_vol(this) ! usual safety check
5523
5524IF (optio_log(lsort_time)) THEN
5525 DO i = 2, SIZE(this%time)
5526 IF (this%time(i) < this%time(i-1)) THEN
5527 to_be_sorted = .true.
5528 EXIT
5529 ENDIF
5530 ENDDO
5531ENDIF
5532IF (optio_log(lsort_timerange)) THEN
5533 DO i = 2, SIZE(this%timerange)
5534 IF (this%timerange(i) < this%timerange(i-1)) THEN
5535 to_be_sorted = .true.
5536 EXIT
5537 ENDIF
5538 ENDDO
5539ENDIF
5540IF (optio_log(lsort_level)) THEN
5541 DO i = 2, SIZE(this%level)
5542 IF (this%level(i) < this%level(i-1)) THEN
5543 to_be_sorted = .true.
5544 EXIT
5545 ENDIF
5546 ENDDO
5547ENDIF
5548
5549IF (to_be_sorted) CALL vol7d_reform(this, &
5550 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
5551
5552END SUBROUTINE vol7d_smart_sort
5553
5554!> Filter the contents of a volume keeping only desired data.
5555!! This subroutine filters a vol7d object by keeping only a subset of
5556!! the data contained. It can keep only times within a specified
5557!! interval, only station networks contained in a list and only
5558!! specified station or data variables. If a filter parameter is not
5559!! provided, no filtering will take place according to that criterion.
5560!! The volume is reallocated keeping only the desired data.
5561SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
5562TYPE(vol7d),INTENT(inout) :: this !< volume to be filtered
5563CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:) !< list of station variables to be kept, if not provided or of zero length, all variables are kept
5564CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:) !< list of data variables to be kept, if not provided or of zero length, all variables are kept
5565TYPE(vol7d_network),OPTIONAL :: nl(:) !< list of station networks to be kept, if not provided or of zero length, all networks are kept
5566TYPE(datetime),INTENT(in),OPTIONAL :: s_d !< initial time interval for time filtering, if not provided or equal to missing data no lower limit is imposed
5567TYPE(datetime),INTENT(in),OPTIONAL :: e_d !< final time interval for time filtering, if not provided or equal to missing data no upper limit is imposed
5568
5569INTEGER :: i
5570
5571IF (PRESENT(avl)) THEN
5572 IF (SIZE(avl) > 0) THEN
5573
5574 IF (ASSOCIATED(this%anavar%r)) THEN
5575 DO i = 1, SIZE(this%anavar%r)
5576 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
5577 ENDDO
5578 ENDIF
5579
5580 IF (ASSOCIATED(this%anavar%i)) THEN
5581 DO i = 1, SIZE(this%anavar%i)
5582 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
5583 ENDDO
5584 ENDIF
5585
5586 IF (ASSOCIATED(this%anavar%b)) THEN
5587 DO i = 1, SIZE(this%anavar%b)
5588 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
5589 ENDDO
5590 ENDIF
5591
5592 IF (ASSOCIATED(this%anavar%d)) THEN
5593 DO i = 1, SIZE(this%anavar%d)
5594 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
5595 ENDDO
5596 ENDIF
5597
5598 IF (ASSOCIATED(this%anavar%c)) THEN
5599 DO i = 1, SIZE(this%anavar%c)
5600 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
5601 ENDDO
5602 ENDIF
5603
5604 ENDIF
5605ENDIF
5606
5607
5608IF (PRESENT(vl)) THEN
5609 IF (size(vl) > 0) THEN
5610 IF (ASSOCIATED(this%dativar%r)) THEN
5611 DO i = 1, SIZE(this%dativar%r)
5612 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
5613 ENDDO
5614 ENDIF
5615
5616 IF (ASSOCIATED(this%dativar%i)) THEN
5617 DO i = 1, SIZE(this%dativar%i)
5618 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
5619 ENDDO
5620 ENDIF
5621
5622 IF (ASSOCIATED(this%dativar%b)) THEN
5623 DO i = 1, SIZE(this%dativar%b)
5624 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
5625 ENDDO
5626 ENDIF
5627
5628 IF (ASSOCIATED(this%dativar%d)) THEN
5629 DO i = 1, SIZE(this%dativar%d)
5630 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
5631 ENDDO
5632 ENDIF
5633
5634 IF (ASSOCIATED(this%dativar%c)) THEN
5635 DO i = 1, SIZE(this%dativar%c)
5636 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5637 ENDDO
5638 ENDIF
5639
5640 IF (ASSOCIATED(this%dativar%c)) THEN
5641 DO i = 1, SIZE(this%dativar%c)
5642 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5643 ENDDO
5644 ENDIF
5645
5646 ENDIF
5647ENDIF
5648
5649IF (PRESENT(nl)) THEN
5650 IF (SIZE(nl) > 0) THEN
5651 DO i = 1, SIZE(this%network)
5652 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
5653 ENDDO
5654 ENDIF
5655ENDIF
5656
5657IF (PRESENT(s_d)) THEN
5659 WHERE (this%time < s_d)
5660 this%time = datetime_miss
5661 END WHERE
5662 ENDIF
5663ENDIF
5664
5665IF (PRESENT(e_d)) THEN
5667 WHERE (this%time > e_d)
5668 this%time = datetime_miss
5669 END WHERE
5670 ENDIF
5671ENDIF
5672
5673CALL vol7d_reform(this, miss=.true.)
5674
5675END SUBROUTINE vol7d_filter
5676
5677
5678!> Metodo per convertire i volumi di dati di un oggetto vol7d in dati
5679!! reali dove possibile. L'oggetto convertito è una copia completa
5680!! dell'originale che può essere quindi distrutto dopo la chiamata.
5681!! Per i dati di anagrafica, al momento sono convertiti solo
5682!! i dati CHARACTER se è passato \a anaconv=.TRUE.
5683!! Gli attributi non sono toccati.
5684SUBROUTINE vol7d_convr(this, that, anaconv)
5685TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
5686TYPE(vol7d),INTENT(INOUT) :: that !< oggetto convertito
5687LOGICAL,OPTIONAL,INTENT(in) :: anaconv !< converti anche anagrafica
5688INTEGER :: i
5689LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
5690TYPE(vol7d) :: v7d_tmp
5691
5692IF (optio_log(anaconv)) THEN
5693 acp=fv
5694 acn=tv
5695ELSE
5696 acp=tv
5697 acn=fv
5698ENDIF
5699
5700! Volume con solo i dati reali e tutti gli attributi
5701! l'anagrafica e` copiata interamente se necessario
5702CALL vol7d_copy(this, that, &
5703 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
5704 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
5705
5706! Volume solo di dati double
5707CALL vol7d_copy(this, v7d_tmp, &
5708 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
5709 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5710 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5711 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
5712 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5713 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5714
5715! converto a dati reali
5716IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
5717
5718 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
5719! alloco i dati reali e vi trasferisco i double
5720 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
5721 SIZE(v7d_tmp%volanad, 3)))
5722 DO i = 1, SIZE(v7d_tmp%anavar%d)
5723 v7d_tmp%volanar(:,i,:) = &
5724 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
5725 ENDDO
5726 DEALLOCATE(v7d_tmp%volanad)
5727! trasferisco le variabili
5728 v7d_tmp%anavar%r => v7d_tmp%anavar%d
5729 NULLIFY(v7d_tmp%anavar%d)
5730 ENDIF
5731
5732 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
5733! alloco i dati reali e vi trasferisco i double
5734 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
5735 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
5736 SIZE(v7d_tmp%voldatid, 6)))
5737 DO i = 1, SIZE(v7d_tmp%dativar%d)
5738 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5739 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
5740 ENDDO
5741 DEALLOCATE(v7d_tmp%voldatid)
5742! trasferisco le variabili
5743 v7d_tmp%dativar%r => v7d_tmp%dativar%d
5744 NULLIFY(v7d_tmp%dativar%d)
5745 ENDIF
5746
5747! fondo con il volume definitivo
5748 CALL vol7d_merge(that, v7d_tmp)
5749ELSE
5751ENDIF
5752
5753
5754! Volume solo di dati interi
5755CALL vol7d_copy(this, v7d_tmp, &
5756 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
5757 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5758 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5759 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
5760 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5761 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5762
5763! converto a dati reali
5764IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
5765
5766 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
5767! alloco i dati reali e vi trasferisco gli interi
5768 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
5769 SIZE(v7d_tmp%volanai, 3)))
5770 DO i = 1, SIZE(v7d_tmp%anavar%i)
5771 v7d_tmp%volanar(:,i,:) = &
5772 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
5773 ENDDO
5774 DEALLOCATE(v7d_tmp%volanai)
5775! trasferisco le variabili
5776 v7d_tmp%anavar%r => v7d_tmp%anavar%i
5777 NULLIFY(v7d_tmp%anavar%i)
5778 ENDIF
5779
5780 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
5781! alloco i dati reali e vi trasferisco gli interi
5782 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
5783 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
5784 SIZE(v7d_tmp%voldatii, 6)))
5785 DO i = 1, SIZE(v7d_tmp%dativar%i)
5786 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5787 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
5788 ENDDO
5789 DEALLOCATE(v7d_tmp%voldatii)
5790! trasferisco le variabili
5791 v7d_tmp%dativar%r => v7d_tmp%dativar%i
5792 NULLIFY(v7d_tmp%dativar%i)
5793 ENDIF
5794
5795! fondo con il volume definitivo
5796 CALL vol7d_merge(that, v7d_tmp)
5797ELSE
5799ENDIF
5800
5801
5802! Volume solo di dati byte
5803CALL vol7d_copy(this, v7d_tmp, &
5804 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
5805 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5806 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5807 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
5808 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5809 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5810
5811! converto a dati reali
5812IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
5813
5814 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
5815! alloco i dati reali e vi trasferisco i byte
5816 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
5817 SIZE(v7d_tmp%volanab, 3)))
5818 DO i = 1, SIZE(v7d_tmp%anavar%b)
5819 v7d_tmp%volanar(:,i,:) = &
5820 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
5821 ENDDO
5822 DEALLOCATE(v7d_tmp%volanab)
5823! trasferisco le variabili
5824 v7d_tmp%anavar%r => v7d_tmp%anavar%b
5825 NULLIFY(v7d_tmp%anavar%b)
5826 ENDIF
5827
5828 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
5829! alloco i dati reali e vi trasferisco i byte
5830 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
5831 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
5832 SIZE(v7d_tmp%voldatib, 6)))
5833 DO i = 1, SIZE(v7d_tmp%dativar%b)
5834 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5835 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
5836 ENDDO
5837 DEALLOCATE(v7d_tmp%voldatib)
5838! trasferisco le variabili
5839 v7d_tmp%dativar%r => v7d_tmp%dativar%b
5840 NULLIFY(v7d_tmp%dativar%b)
5841 ENDIF
5842
5843! fondo con il volume definitivo
5844 CALL vol7d_merge(that, v7d_tmp)
5845ELSE
5847ENDIF
5848
5849
5850! Volume solo di dati character
5851CALL vol7d_copy(this, v7d_tmp, &
5852 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
5853 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5854 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5855 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
5856 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5857 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5858
5859! converto a dati reali
5860IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
5861
5862 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
5863! alloco i dati reali e vi trasferisco i character
5864 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
5865 SIZE(v7d_tmp%volanac, 3)))
5866 DO i = 1, SIZE(v7d_tmp%anavar%c)
5867 v7d_tmp%volanar(:,i,:) = &
5868 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
5869 ENDDO
5870 DEALLOCATE(v7d_tmp%volanac)
5871! trasferisco le variabili
5872 v7d_tmp%anavar%r => v7d_tmp%anavar%c
5873 NULLIFY(v7d_tmp%anavar%c)
5874 ENDIF
5875
5876 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
5877! alloco i dati reali e vi trasferisco i character
5878 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
5879 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
5880 SIZE(v7d_tmp%voldatic, 6)))
5881 DO i = 1, SIZE(v7d_tmp%dativar%c)
5882 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5883 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
5884 ENDDO
5885 DEALLOCATE(v7d_tmp%voldatic)
5886! trasferisco le variabili
5887 v7d_tmp%dativar%r => v7d_tmp%dativar%c
5888 NULLIFY(v7d_tmp%dativar%c)
5889 ENDIF
5890
5891! fondo con il volume definitivo
5892 CALL vol7d_merge(that, v7d_tmp)
5893ELSE
5895ENDIF
5896
5897END SUBROUTINE vol7d_convr
5898
5899
5900!> Metodo per ottenere solo le differenze tra due oggetti vol7d.
5901!! Il primo volume viene confrontato col secondo; nel secondo volume ovunque
5902!! i dati confrontati siano coincidenti viene impostato valore mancante.
5903SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
5904TYPE(vol7d),INTENT(IN) :: this !< primo volume da confrontare
5905TYPE(vol7d),INTENT(OUT) :: that !< secondo volume da confrontare in cui eliminare i dati coincidenti
5906logical , optional, intent(in) :: data_only !< attiva l'elaborazione dei soli dati e non dell'anagrafica (default: .false.)
5907logical , optional, intent(in) :: ana !< attiva l'elaborazione dell'anagrafica (coordinate e ident) (default: .false.)
5908logical :: ldata_only,lana
5909
5910IF (PRESENT(data_only)) THEN
5911 ldata_only = data_only
5912ELSE
5913 ldata_only = .false.
5914ENDIF
5915
5916IF (PRESENT(ana)) THEN
5917 lana = ana
5918ELSE
5919 lana = .false.
5920ENDIF
5921
5922
5923#undef VOL7D_POLY_ARRAY
5924#define VOL7D_POLY_ARRAY voldati
5925#include "vol7d_class_diff.F90"
5926#undef VOL7D_POLY_ARRAY
5927#define VOL7D_POLY_ARRAY voldatiattr
5928#include "vol7d_class_diff.F90"
5929#undef VOL7D_POLY_ARRAY
5930
5931if ( .not. ldata_only) then
5932
5933#define VOL7D_POLY_ARRAY volana
5934#include "vol7d_class_diff.F90"
5935#undef VOL7D_POLY_ARRAY
5936#define VOL7D_POLY_ARRAY volanaattr
5937#include "vol7d_class_diff.F90"
5938#undef VOL7D_POLY_ARRAY
5939
5940 if(lana)then
5941 where ( this%ana == that%ana )
5942 that%ana = vol7d_ana_miss
5943 end where
5944 end if
5945
5946end if
5947
5948
5949
5950END SUBROUTINE vol7d_diff_only
5951
5952
5953
5954! Creo le routine da ripetere per i vari tipi di dati di v7d
5955! tramite un template e il preprocessore
5956#undef VOL7D_POLY_TYPE
5957#undef VOL7D_POLY_TYPES
5958#define VOL7D_POLY_TYPE REAL
5959#define VOL7D_POLY_TYPES r
5960#include "vol7d_class_type_templ.F90"
5961#undef VOL7D_POLY_TYPE
5962#undef VOL7D_POLY_TYPES
5963#define VOL7D_POLY_TYPE DOUBLE PRECISION
5964#define VOL7D_POLY_TYPES d
5965#include "vol7d_class_type_templ.F90"
5966#undef VOL7D_POLY_TYPE
5967#undef VOL7D_POLY_TYPES
5968#define VOL7D_POLY_TYPE INTEGER
5969#define VOL7D_POLY_TYPES i
5970#include "vol7d_class_type_templ.F90"
5971#undef VOL7D_POLY_TYPE
5972#undef VOL7D_POLY_TYPES
5973#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
5974#define VOL7D_POLY_TYPES b
5975#include "vol7d_class_type_templ.F90"
5976#undef VOL7D_POLY_TYPE
5977#undef VOL7D_POLY_TYPES
5978#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
5979#define VOL7D_POLY_TYPES c
5980#include "vol7d_class_type_templ.F90"
5981
5982! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
5983! tramite un template e il preprocessore
5984#define VOL7D_SORT
5985#undef VOL7D_NO_ZERO_ALLOC
5986#undef VOL7D_POLY_TYPE
5987#define VOL7D_POLY_TYPE datetime
5988#include "vol7d_class_desc_templ.F90"
5989#undef VOL7D_POLY_TYPE
5990#define VOL7D_POLY_TYPE vol7d_timerange
5991#include "vol7d_class_desc_templ.F90"
5992#undef VOL7D_POLY_TYPE
5993#define VOL7D_POLY_TYPE vol7d_level
5994#include "vol7d_class_desc_templ.F90"
5995#undef VOL7D_SORT
5996#undef VOL7D_POLY_TYPE
5997#define VOL7D_POLY_TYPE vol7d_network
5998#include "vol7d_class_desc_templ.F90"
5999#undef VOL7D_POLY_TYPE
6000#define VOL7D_POLY_TYPE vol7d_ana
6001#include "vol7d_class_desc_templ.F90"
6002#define VOL7D_NO_ZERO_ALLOC
6003#undef VOL7D_POLY_TYPE
6004#define VOL7D_POLY_TYPE vol7d_var
6005#include "vol7d_class_desc_templ.F90"
6006
6007!>\brief Scrittura su file di un volume Vol7d.
6008!! Scrittura su file unformatted di un intero volume Vol7d.
6009!! Il volume viene serializzato e scritto su file.
6010!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
6011!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
6012!! tali parametri saranno in output.
6013!! Se non viene fornito il nome file viene utilizzato un file di default con nome pari al nome del programma in
6014!! esecuzione con postfisso ".v7d".
6015!! Come parametro opzionale c'è la description che insieme alla data corrente viene inserita nell'header del file.
6016subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6017
6018TYPE(vol7d),INTENT(IN) :: this !< volume vol7d da scrivere
6019integer,optional,intent(inout) :: unit !< unità su cui scrivere; se passata =0 ritorna il valore rielaborato (default =rielaborato internamente con getlun )
6020character(len=*),intent(in),optional :: filename !< nome del file su cui scrivere
6021character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
6022character(len=*),INTENT(IN),optional :: description !< descrizione del volume
6023
6024integer :: lunit
6025character(len=254) :: ldescription,arg,lfilename
6026integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6027 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6028 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6029 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6030 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6031 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6032 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6033!integer :: im,id,iy
6034integer :: tarray(8)
6035logical :: opened,exist
6036
6037 nana=0
6038 ntime=0
6039 ntimerange=0
6040 nlevel=0
6041 nnetwork=0
6042 ndativarr=0
6043 ndativari=0
6044 ndativarb=0
6045 ndativard=0
6046 ndativarc=0
6047 ndatiattrr=0
6048 ndatiattri=0
6049 ndatiattrb=0
6050 ndatiattrd=0
6051 ndatiattrc=0
6052 ndativarattrr=0
6053 ndativarattri=0
6054 ndativarattrb=0
6055 ndativarattrd=0
6056 ndativarattrc=0
6057 nanavarr=0
6058 nanavari=0
6059 nanavarb=0
6060 nanavard=0
6061 nanavarc=0
6062 nanaattrr=0
6063 nanaattri=0
6064 nanaattrb=0
6065 nanaattrd=0
6066 nanaattrc=0
6067 nanavarattrr=0
6068 nanavarattri=0
6069 nanavarattrb=0
6070 nanavarattrd=0
6071 nanavarattrc=0
6072
6073
6074!call idate(im,id,iy)
6075call date_and_time(values=tarray)
6076call getarg(0,arg)
6077
6078if (present(description))then
6079 ldescription=description
6080else
6081 ldescription="Vol7d generated by: "//trim(arg)
6082end if
6083
6084if (.not. present(unit))then
6085 lunit=getunit()
6086else
6087 if (unit==0)then
6088 lunit=getunit()
6089 unit=lunit
6090 else
6091 lunit=unit
6092 end if
6093end if
6094
6095lfilename=trim(arg)//".v7d"
6097
6098if (present(filename))then
6099 if (filename /= "")then
6100 lfilename=filename
6101 end if
6102end if
6103
6104if (present(filename_auto))filename_auto=lfilename
6105
6106
6107inquire(unit=lunit,opened=opened)
6108if (.not. opened) then
6109! inquire(file=lfilename, EXIST=exist)
6110! IF (exist) THEN
6111! CALL l4f_log(L4F_FATAL, &
6112! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6113! CALL raise_fatal_error()
6114! ENDIF
6115 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6116 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6117end if
6118
6119if (associated(this%ana)) nana=size(this%ana)
6120if (associated(this%time)) ntime=size(this%time)
6121if (associated(this%timerange)) ntimerange=size(this%timerange)
6122if (associated(this%level)) nlevel=size(this%level)
6123if (associated(this%network)) nnetwork=size(this%network)
6124
6125if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6126if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6127if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6128if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6129if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6130
6131if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6132if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6133if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6134if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6135if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6136
6137if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6138if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6139if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6140if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6141if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6142
6143if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6144if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6145if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6146if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6147if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6148
6149if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6150if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6151if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6152if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6153if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6154
6155if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6156if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6157if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6158if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6159if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6160
6161write(unit=lunit)ldescription
6162write(unit=lunit)tarray
6163
6164write(unit=lunit)&
6165 nana, ntime, ntimerange, nlevel, nnetwork, &
6166 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6167 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6168 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6169 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6170 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6171 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6172 this%time_definition
6173
6174
6175!write(unit=lunit)this
6176
6177
6178!! prime 5 dimensioni
6181if (associated(this%level)) write(unit=lunit)this%level
6182if (associated(this%timerange)) write(unit=lunit)this%timerange
6183if (associated(this%network)) write(unit=lunit)this%network
6184
6185 !! 6a dimensione: variabile dell'anagrafica e dei dati
6186 !! con relativi attributi e in 5 tipi diversi
6187
6188if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6189if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6190if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6191if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6192if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6193
6194if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6195if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6196if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6197if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6198if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6199
6200if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6201if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6202if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6203if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6204if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6205
6206if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6207if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6208if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6209if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6210if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6211
6212if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6213if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6214if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6215if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6216if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6217
6218if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6219if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6220if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6221if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6222if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6223
6224!! Volumi di valori e attributi per anagrafica e dati
6225
6226if (associated(this%volanar)) write(unit=lunit)this%volanar
6227if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6228if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6229if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6230
6231if (associated(this%volanai)) write(unit=lunit)this%volanai
6232if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6233if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6234if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6235
6236if (associated(this%volanab)) write(unit=lunit)this%volanab
6237if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6238if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6239if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6240
6241if (associated(this%volanad)) write(unit=lunit)this%volanad
6242if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6243if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6244if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6245
6246if (associated(this%volanac)) write(unit=lunit)this%volanac
6247if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6248if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6249if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6250
6251if (.not. present(unit)) close(unit=lunit)
6252
6253end subroutine vol7d_write_on_file
6254
6255
6256!>\brief Lettura da file di un volume Vol7d.
6257!! Lettura da file unformatted di un intero volume Vol7d.
6258!! Questa subroutine comprende vol7d_alloc e vol7d_alloc_vol.
6259!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
6260!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
6261!! tali parametri saranno in output.
6262
6263
6264subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6265
6266TYPE(vol7d),INTENT(OUT) :: this !< Volume vol7d da leggere
6267integer,intent(inout),optional :: unit !< unità su cui è stato aperto un file; se =0 rielaborato internamente (default = elaborato internamente con getunit)
6268character(len=*),INTENT(in),optional :: filename !< nome del file eventualmente da aprire (default = (nome dell'eseguibile)//.v7d )
6269character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
6270character(len=*),INTENT(out),optional :: description !< descrizione del volume letto
6271integer,intent(out),optional :: tarray(8) !< vettore come definito da "date_and_time" della data di scrittura del volume
6272
6273
6274integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6275 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6276 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6277 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6278 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6279 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6280 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6281
6282character(len=254) :: ldescription,lfilename,arg
6283integer :: ltarray(8),lunit,ios
6284logical :: opened,exist
6285
6286
6287call getarg(0,arg)
6288
6289if (.not. present(unit))then
6290 lunit=getunit()
6291else
6292 if (unit==0)then
6293 lunit=getunit()
6294 unit=lunit
6295 else
6296 lunit=unit
6297 end if
6298end if
6299
6300lfilename=trim(arg)//".v7d"
6302
6303if (present(filename))then
6304 if (filename /= "")then
6305 lfilename=filename
6306 end if
6307end if
6308
6309if (present(filename_auto))filename_auto=lfilename
6310
6311
6312inquire(unit=lunit,opened=opened)
6313IF (.NOT. opened) THEN
6314 inquire(file=lfilename,exist=exist)
6315 IF (.NOT.exist) THEN
6316 CALL l4f_log(l4f_fatal, &
6317 'in vol7d_read_from_file, file does not exists, cannot open')
6318 CALL raise_fatal_error()
6319 ENDIF
6320 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6321 status='OLD', action='READ')
6322 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6323end if
6324
6325
6327read(unit=lunit,iostat=ios)ldescription
6328
6329if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6330 call vol7d_alloc (this)
6331 call vol7d_alloc_vol (this)
6332 if (present(description))description=ldescription
6333 if (present(tarray))tarray=ltarray
6334 if (.not. present(unit)) close(unit=lunit)
6335end if
6336
6337read(unit=lunit)ltarray
6338
6339CALL l4f_log(l4f_info, 'Reading vol7d from file')
6340CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6343
6344if (present(description))description=ldescription
6345if (present(tarray))tarray=ltarray
6346
6347read(unit=lunit)&
6348 nana, ntime, ntimerange, nlevel, nnetwork, &
6349 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6350 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6351 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6352 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6353 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6354 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6355 this%time_definition
6356
6357call vol7d_alloc (this, &
6358 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6359 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6360 ndativard=ndativard, ndativarc=ndativarc,&
6361 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6362 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6363 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6364 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6365 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6366 nanavard=nanavard, nanavarc=nanavarc,&
6367 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6368 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6369 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
6370 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
6371
6372
6375if (associated(this%level)) read(unit=lunit)this%level
6376if (associated(this%timerange)) read(unit=lunit)this%timerange
6377if (associated(this%network)) read(unit=lunit)this%network
6378
6379if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
6380if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
6381if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
6382if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
6383if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
6384
6385if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
6386if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
6387if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
6388if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
6389if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
6390
6391if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
6392if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
6393if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
6394if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
6395if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
6396
6397if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
6398if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
6399if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
6400if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
6401if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
6402
6403if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
6404if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
6405if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
6406if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
6407if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
6408
6409if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
6410if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
6411if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
6412if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
6413if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
6414
6415call vol7d_alloc_vol (this)
6416
6417!! Volumi di valori e attributi per anagrafica e dati
6418
6419if (associated(this%volanar)) read(unit=lunit)this%volanar
6420if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
6421if (associated(this%voldatir)) read(unit=lunit)this%voldatir
6422if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
6423
6424if (associated(this%volanai)) read(unit=lunit)this%volanai
6425if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
6426if (associated(this%voldatii)) read(unit=lunit)this%voldatii
6427if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
6428
6429if (associated(this%volanab)) read(unit=lunit)this%volanab
6430if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
6431if (associated(this%voldatib)) read(unit=lunit)this%voldatib
6432if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
6433
6434if (associated(this%volanad)) read(unit=lunit)this%volanad
6435if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
6436if (associated(this%voldatid)) read(unit=lunit)this%voldatid
6437if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
6438
6439if (associated(this%volanac)) read(unit=lunit)this%volanac
6440if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
6441if (associated(this%voldatic)) read(unit=lunit)this%voldatic
6442if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
6443
6444if (.not. present(unit)) close(unit=lunit)
6445
6446end subroutine vol7d_read_from_file
6447
6448
6449! to double precision
6450elemental doubleprecision function doubledatd(voldat,var)
6451doubleprecision,intent(in) :: voldat
6452type(vol7d_var),intent(in) :: var
6453
6454doubledatd=voldat
6455
6456end function doubledatd
6457
6458
6459elemental doubleprecision function doubledatr(voldat,var)
6460real,intent(in) :: voldat
6461type(vol7d_var),intent(in) :: var
6462
6464 doubledatr=dble(voldat)
6465else
6466 doubledatr=dmiss
6467end if
6468
6469end function doubledatr
6470
6471
6472elemental doubleprecision function doubledati(voldat,var)
6473integer,intent(in) :: voldat
6474type(vol7d_var),intent(in) :: var
6475
6478 doubledati=dble(voldat)/10.d0**var%scalefactor
6479 else
6480 doubledati=dble(voldat)
6481 endif
6482else
6483 doubledati=dmiss
6484end if
6485
6486end function doubledati
6487
6488
6489elemental doubleprecision function doubledatb(voldat,var)
6490integer(kind=int_b),intent(in) :: voldat
6491type(vol7d_var),intent(in) :: var
6492
6495 doubledatb=dble(voldat)/10.d0**var%scalefactor
6496 else
6497 doubledatb=dble(voldat)
6498 endif
6499else
6500 doubledatb=dmiss
6501end if
6502
6503end function doubledatb
6504
6505
6506elemental doubleprecision function doubledatc(voldat,var)
6507CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6508type(vol7d_var),intent(in) :: var
6509
6510doubledatc = c2d(voldat)
6512 doubledatc=doubledatc/10.d0**var%scalefactor
6513end if
6514
6515end function doubledatc
6516
6517
6518! to integer
6519elemental integer function integerdatd(voldat,var)
6520doubleprecision,intent(in) :: voldat
6521type(vol7d_var),intent(in) :: var
6522
6525 integerdatd=nint(voldat*10d0**var%scalefactor)
6526 else
6527 integerdatd=nint(voldat)
6528 endif
6529else
6530 integerdatd=imiss
6531end if
6532
6533end function integerdatd
6534
6535
6536elemental integer function integerdatr(voldat,var)
6537real,intent(in) :: voldat
6538type(vol7d_var),intent(in) :: var
6539
6542 integerdatr=nint(voldat*10d0**var%scalefactor)
6543 else
6544 integerdatr=nint(voldat)
6545 endif
6546else
6547 integerdatr=imiss
6548end if
6549
6550end function integerdatr
6551
6552
6553elemental integer function integerdati(voldat,var)
6554integer,intent(in) :: voldat
6555type(vol7d_var),intent(in) :: var
6556
6557integerdati=voldat
6558
6559end function integerdati
6560
6561
6562elemental integer function integerdatb(voldat,var)
6563integer(kind=int_b),intent(in) :: voldat
6564type(vol7d_var),intent(in) :: var
6565
6567 integerdatb=voldat
6568else
6569 integerdatb=imiss
6570end if
6571
6572end function integerdatb
6573
6574
6575elemental integer function integerdatc(voldat,var)
6576CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6577type(vol7d_var),intent(in) :: var
6578
6579integerdatc=c2i(voldat)
6580
6581end function integerdatc
6582
6583
6584! to real
6585elemental real function realdatd(voldat,var)
6586doubleprecision,intent(in) :: voldat
6587type(vol7d_var),intent(in) :: var
6588
6590 realdatd=real(voldat)
6591else
6592 realdatd=rmiss
6593end if
6594
6595end function realdatd
6596
6597
6598elemental real function realdatr(voldat,var)
6599real,intent(in) :: voldat
6600type(vol7d_var),intent(in) :: var
6601
6602realdatr=voldat
6603
6604end function realdatr
6605
6606
6607elemental real function realdati(voldat,var)
6608integer,intent(in) :: voldat
6609type(vol7d_var),intent(in) :: var
6610
6613 realdati=float(voldat)/10.**var%scalefactor
6614 else
6615 realdati=float(voldat)
6616 endif
6617else
6618 realdati=rmiss
6619end if
6620
6621end function realdati
6622
6623
6624elemental real function realdatb(voldat,var)
6625integer(kind=int_b),intent(in) :: voldat
6626type(vol7d_var),intent(in) :: var
6627
6630 realdatb=float(voldat)/10**var%scalefactor
6631 else
6632 realdatb=float(voldat)
6633 endif
6634else
6635 realdatb=rmiss
6636end if
6637
6638end function realdatb
6639
6640
6641elemental real function realdatc(voldat,var)
6642CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6643type(vol7d_var),intent(in) :: var
6644
6645realdatc=c2r(voldat)
6647 realdatc=realdatc/10.**var%scalefactor
6648end if
6649
6650end function realdatc
6651
6652
6653!> Return an ana volume of a requested variable as real data.
6654!! It returns a 2-d array of the proper shape (ana x network) for the
6655!! ana variable requested, converted to real type. If the conversion
6656!! fails or if the variable is not contained in the ana volume,
6657!! missing data are returned.
6658FUNCTION realanavol(this, var) RESULT(vol)
6659TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
6660TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
6661REAL :: vol(SIZE(this%ana),size(this%network))
6662
6663CHARACTER(len=1) :: dtype
6664INTEGER :: indvar
6665
6666dtype = cmiss
6667indvar = index(this%anavar, var, type=dtype)
6668
6669IF (indvar > 0) THEN
6670 SELECT CASE (dtype)
6671 CASE("d")
6672 vol = realdat(this%volanad(:,indvar,:), var)
6673 CASE("r")
6674 vol = this%volanar(:,indvar,:)
6675 CASE("i")
6676 vol = realdat(this%volanai(:,indvar,:), var)
6677 CASE("b")
6678 vol = realdat(this%volanab(:,indvar,:), var)
6679 CASE("c")
6680 vol = realdat(this%volanac(:,indvar,:), var)
6681 CASE default
6682 vol = rmiss
6683 END SELECT
6684ELSE
6685 vol = rmiss
6686ENDIF
6687
6688END FUNCTION realanavol
6689
6690
6691!> Return an ana volume of a requested variable as integer data.
6692!! It returns a 2-d array of the proper shape (ana x network) for the
6693!! ana variable requested, converted to integer type. If the conversion
6694!! fails or if the variable is not contained in the ana volume,
6695!! missing data are returned.
6696FUNCTION integeranavol(this, var) RESULT(vol)
6697TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
6698TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
6699INTEGER :: vol(SIZE(this%ana),size(this%network))
6700
6701CHARACTER(len=1) :: dtype
6702INTEGER :: indvar
6703
6704dtype = cmiss
6705indvar = index(this%anavar, var, type=dtype)
6706
6707IF (indvar > 0) THEN
6708 SELECT CASE (dtype)
6709 CASE("d")
6710 vol = integerdat(this%volanad(:,indvar,:), var)
6711 CASE("r")
6712 vol = integerdat(this%volanar(:,indvar,:), var)
6713 CASE("i")
6714 vol = this%volanai(:,indvar,:)
6715 CASE("b")
6716 vol = integerdat(this%volanab(:,indvar,:), var)
6717 CASE("c")
6718 vol = integerdat(this%volanac(:,indvar,:), var)
6719 CASE default
6720 vol = imiss
6721 END SELECT
6722ELSE
6723 vol = imiss
6724ENDIF
6725
6726END FUNCTION integeranavol
6727
6728
6729!> Move data for all variables from one coordinate in the character volume to other.
6730!! Only not missing data will be copyed and all attributes will be moved together.
6731!! Usefull to colapse data spread in more indices (level or time or ....).
6732!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
6733!! to obtain a new vol7d with less data shape.
6734subroutine move_datac (v7d,&
6735 indana,indtime,indlevel,indtimerange,indnetwork,&
6736 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6737
6738TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
6739
6740integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
6741integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
6742integer :: inddativar,inddativarattr
6743
6744
6745do inddativar=1,size(v7d%dativar%c)
6746
6748 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6749 ) then
6750
6751 ! dati
6752 v7d%voldatic &
6753 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6754 v7d%voldatic &
6755 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6756
6757
6758 ! attributi
6759 if (associated (v7d%dativarattr%i)) then
6760 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
6761 if (inddativarattr > 0 ) then
6762 v7d%voldatiattri &
6763 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6764 v7d%voldatiattri &
6765 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6766 end if
6767 end if
6768
6769 if (associated (v7d%dativarattr%r)) then
6770 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
6771 if (inddativarattr > 0 ) then
6772 v7d%voldatiattrr &
6773 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6774 v7d%voldatiattrr &
6775 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6776 end if
6777 end if
6778
6779 if (associated (v7d%dativarattr%d)) then
6780 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
6781 if (inddativarattr > 0 ) then
6782 v7d%voldatiattrd &
6783 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6784 v7d%voldatiattrd &
6785 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6786 end if
6787 end if
6788
6789 if (associated (v7d%dativarattr%b)) then
6790 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
6791 if (inddativarattr > 0 ) then
6792 v7d%voldatiattrb &
6793 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6794 v7d%voldatiattrb &
6795 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6796 end if
6797 end if
6798
6799 if (associated (v7d%dativarattr%c)) then
6800 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
6801 if (inddativarattr > 0 ) then
6802 v7d%voldatiattrc &
6803 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6804 v7d%voldatiattrc &
6805 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6806 end if
6807 end if
6808
6809 end if
6810
6811end do
6812
6813end subroutine move_datac
6814
6815!> Move data for all variables from one coordinate in the real volume to other.
6816!! Only not missing data will be copyed and all attributes will be moved together.
6817!! Usefull to colapse data spread in more indices (level or time or ....).
6818!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
6819!! to obtain a new vol7d with less data shape.
6820subroutine move_datar (v7d,&
6821 indana,indtime,indlevel,indtimerange,indnetwork,&
6822 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6823
6824TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
6825
6826integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
6827integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
6828integer :: inddativar,inddativarattr
6829
6830
6831do inddativar=1,size(v7d%dativar%r)
6832
6834 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6835 ) then
6836
6837 ! dati
6838 v7d%voldatir &
6839 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6840 v7d%voldatir &
6841 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6842
6843
6844 ! attributi
6845 if (associated (v7d%dativarattr%i)) then
6846 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
6847 if (inddativarattr > 0 ) then
6848 v7d%voldatiattri &
6849 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6850 v7d%voldatiattri &
6851 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6852 end if
6853 end if
6854
6855 if (associated (v7d%dativarattr%r)) then
6856 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
6857 if (inddativarattr > 0 ) then
6858 v7d%voldatiattrr &
6859 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6860 v7d%voldatiattrr &
6861 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6862 end if
6863 end if
6864
6865 if (associated (v7d%dativarattr%d)) then
6866 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
6867 if (inddativarattr > 0 ) then
6868 v7d%voldatiattrd &
6869 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6870 v7d%voldatiattrd &
6871 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6872 end if
6873 end if
6874
6875 if (associated (v7d%dativarattr%b)) then
6876 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
6877 if (inddativarattr > 0 ) then
6878 v7d%voldatiattrb &
6879 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6880 v7d%voldatiattrb &
6881 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6882 end if
6883 end if
6884
6885 if (associated (v7d%dativarattr%c)) then
6886 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
6887 if (inddativarattr > 0 ) then
6888 v7d%voldatiattrc &
6889 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6890 v7d%voldatiattrc &
6891 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6892 end if
6893 end if
6894
6895 end if
6896
6897end do
6898
6899end subroutine move_datar
6900
6901
6902!> Reduce some dimensions (level and timerage) for semplification (rounding).
6903!! You can use this for simplify and use variables in computation like alchimia
6904!! where fields have to be on the same coordinate
6905!! It return real or character data only: if input is charcter data only it return character otherwise il return
6906!! all the data converted to real.
6907!! examples:
6908!! means in time for short periods and istantaneous values
6909!! 2 meter and surface levels
6910!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
6911!! will be taken (order is by icreasing var index).
6912!! You can use predefined values for classic semplification
6913!! almost_equal_levels and almost_equal_timeranges
6914!! The level or timerange in output will be defined by the first element of level and timerange list
6915subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
6916type(vol7d),intent(inout) :: v7din !< input volume
6917type(vol7d),intent(out) :: v7dout !> output volume
6918type(vol7d_level),intent(in),optional :: level(:) !< almost equal level list
6919type(vol7d_timerange),intent(in),optional :: timerange(:) !< almost equal timerange list
6920!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
6921!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
6922logical,intent(in),optional :: nostatproc !< do not take in account statistical processing code in timerange and P2
6923
6924integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
6925integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
6926type(vol7d_level) :: roundlevel(size(v7din%level))
6927type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
6928type(vol7d) :: v7d_tmp
6929
6930
6931nbin=0
6932
6933if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
6934if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
6935if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
6936if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
6937
6939
6940roundlevel=v7din%level
6941
6942if (present(level))then
6943 do ilevel = 1, size(v7din%level)
6944 if ((any(v7din%level(ilevel) .almosteq. level))) then
6945 roundlevel(ilevel)=level(1)
6946 end if
6947 end do
6948end if
6949
6950roundtimerange=v7din%timerange
6951
6952if (present(timerange))then
6953 do itimerange = 1, size(v7din%timerange)
6954 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
6955 roundtimerange(itimerange)=timerange(1)
6956 end if
6957 end do
6958end if
6959
6960!set istantaneous values everywere
6961!preserve p1 for forecast time
6962if (optio_log(nostatproc)) then
6963 roundtimerange(:)%timerange=254
6964 roundtimerange(:)%p2=0
6965end if
6966
6967
6968nana=size(v7din%ana)
6969nlevel=count_distinct(roundlevel,back=.true.)
6970ntime=size(v7din%time)
6971ntimerange=count_distinct(roundtimerange,back=.true.)
6972nnetwork=size(v7din%network)
6973
6975
6976if (nbin == 0) then
6978else
6979 call vol7d_convr(v7din,v7d_tmp)
6980end if
6981
6982v7d_tmp%level=roundlevel
6983v7d_tmp%timerange=roundtimerange
6984
6985do ilevel=1, size(v7d_tmp%level)
6986 indl=index(v7d_tmp%level,roundlevel(ilevel))
6987 do itimerange=1,size(v7d_tmp%timerange)
6988 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
6989
6990 if (indl /= ilevel .or. indt /= itimerange) then
6991
6992 do iana=1, nana
6993 do itime=1,ntime
6994 do inetwork=1,nnetwork
6995
6996 if (nbin > 0) then
6997 call move_datar (v7d_tmp,&
6998 iana,itime,ilevel,itimerange,inetwork,&
6999 iana,itime,indl,indt,inetwork)
7000 else
7001 call move_datac (v7d_tmp,&
7002 iana,itime,ilevel,itimerange,inetwork,&
7003 iana,itime,indl,indt,inetwork)
7004 end if
7005
7006 end do
7007 end do
7008 end do
7009
7010 end if
7011
7012 end do
7013end do
7014
7015! set to missing level and time > nlevel
7016do ilevel=nlevel+1,size(v7d_tmp%level)
7018end do
7019
7020do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7022end do
7023
7024!copy with remove
7027
7028!call display(v7dout)
7029
7030end subroutine v7d_rounding
7031
7032
7034
7035!>\example esempio_qc_convert.f90
7036!!\brief Programma esempio semplice per la scrittura su file di un volume vol7d
7037!!
7038!!Programma che scrive su file un volume vol7d letto da una serie di file ASCII.
7039!!Questo programma scrive i dati del clima che poi verranno letti da modqccli
7040
7041
7042!>\example esempio_v7ddballe_move_and_collapse.f90
7043!!\brief ! Example program to reduce to one the dimensions of levels and time without loss of data
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition char_utilities.F90:278 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition datetime_class.F90:478 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition datetime_class.F90:485 Generic subroutine for checking OPTIONAL parameters. Definition optional_values.f90:36 Check for problems return 0 if all check passed print diagnostics with log4f. Definition vol7d_class.F90:445 Reduce some dimensions (level and timerage) for semplification (rounding). Definition vol7d_class.F90:462 This module defines usefull general purpose function and subroutine. Definition array_utilities.F90:212 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition optional_values.f90:28 Classe per la gestione dell'anagrafica di stazioni meteo e affini. Definition vol7d_ana_class.F90:212 Classe per la gestione di un volume completo di dati osservati. Definition vol7d_class.F90:273 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition vol7d_level_class.F90:213 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition vol7d_network_class.F90:214 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition vol7d_timerange_class.F90:215 Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var. Definition vol7d_varvect_class.f90:22 Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension... Definition vol7d_class.F90:312 |