libsim Versione 7.2.1
|
◆ vol7d_get_volanar()
Crea una vista a dimensione ridotta di un volume 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_volanar(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 3540 del file vol7d_class.F90. 3542! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3543! authors:
3544! Davide Cesari <dcesari@arpa.emr.it>
3545! Paolo Patruno <ppatruno@arpa.emr.it>
3546
3547! This program is free software; you can redistribute it and/or
3548! modify it under the terms of the GNU General Public License as
3549! published by the Free Software Foundation; either version 2 of
3550! the License, or (at your option) any later version.
3551
3552! This program is distributed in the hope that it will be useful,
3553! but WITHOUT ANY WARRANTY; without even the implied warranty of
3554! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3555! GNU General Public License for more details.
3556
3557! You should have received a copy of the GNU General Public License
3558! along with this program. If not, see <http://www.gnu.org/licenses/>.
3559#include "config.h"
3560
3572
3640IMPLICIT NONE
3641
3642
3643INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
3644 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
3645
3646INTEGER, PARAMETER :: vol7d_ana_a=1
3647INTEGER, PARAMETER :: vol7d_var_a=2
3648INTEGER, PARAMETER :: vol7d_network_a=3
3649INTEGER, PARAMETER :: vol7d_attr_a=4
3650INTEGER, PARAMETER :: vol7d_ana_d=1
3651INTEGER, PARAMETER :: vol7d_time_d=2
3652INTEGER, PARAMETER :: vol7d_level_d=3
3653INTEGER, PARAMETER :: vol7d_timerange_d=4
3654INTEGER, PARAMETER :: vol7d_var_d=5
3655INTEGER, PARAMETER :: vol7d_network_d=6
3656INTEGER, PARAMETER :: vol7d_attr_d=7
3657INTEGER, PARAMETER :: vol7d_cdatalen=32
3658
3659TYPE vol7d_varmap
3660 INTEGER :: r, d, i, b, c
3661END TYPE vol7d_varmap
3662
3667 TYPE(vol7d_ana),POINTER :: ana(:)
3669 TYPE(datetime),POINTER :: time(:)
3671 TYPE(vol7d_level),POINTER :: level(:)
3673 TYPE(vol7d_timerange),POINTER :: timerange(:)
3675 TYPE(vol7d_network),POINTER :: network(:)
3677 TYPE(vol7d_varvect) :: anavar
3679 TYPE(vol7d_varvect) :: anaattr
3681 TYPE(vol7d_varvect) :: anavarattr
3683 TYPE(vol7d_varvect) :: dativar
3685 TYPE(vol7d_varvect) :: datiattr
3687 TYPE(vol7d_varvect) :: dativarattr
3688
3690 REAL,POINTER :: volanar(:,:,:)
3692 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
3694 INTEGER,POINTER :: volanai(:,:,:)
3696 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
3698 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
3699
3701 REAL,POINTER :: volanaattrr(:,:,:,:)
3703 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
3705 INTEGER,POINTER :: volanaattri(:,:,:,:)
3707 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
3709 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
3710
3712 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
3714 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
3716 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
3718 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
3720 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
3721
3723 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
3725 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
3727 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
3729 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
3731 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
3732
3734 integer :: time_definition
3735
3737
3742 MODULE PROCEDURE vol7d_init
3743END INTERFACE
3744
3747 MODULE PROCEDURE vol7d_delete
3748END INTERFACE
3749
3752 MODULE PROCEDURE vol7d_write_on_file
3753END INTERFACE
3754
3756INTERFACE import
3757 MODULE PROCEDURE vol7d_read_from_file
3758END INTERFACE
3759
3762 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
3763END INTERFACE
3764
3767 MODULE PROCEDURE to_char_dat
3768END INTERFACE
3769
3772 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3773END INTERFACE
3774
3777 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
3778END INTERFACE
3779
3782 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
3783END INTERFACE
3784
3787 MODULE PROCEDURE vol7d_copy
3788END INTERFACE
3789
3792 MODULE PROCEDURE vol7d_c_e
3793END INTERFACE
3794
3799 MODULE PROCEDURE vol7d_check
3800END INTERFACE
3801
3816 MODULE PROCEDURE v7d_rounding
3817END INTERFACE
3818
3819!!$INTERFACE get_volana
3820!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
3821!!$ vol7d_get_volanab, vol7d_get_volanac
3822!!$END INTERFACE
3823!!$
3824!!$INTERFACE get_voldati
3825!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
3826!!$ vol7d_get_voldatib, vol7d_get_voldatic
3827!!$END INTERFACE
3828!!$
3829!!$INTERFACE get_volanaattr
3830!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
3831!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
3832!!$END INTERFACE
3833!!$
3834!!$INTERFACE get_voldatiattr
3835!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
3836!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
3837!!$END INTERFACE
3838
3839PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
3840 vol7d_get_volc, &
3841 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
3842 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
3843 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
3844 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
3845 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
3846 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
3847 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
3848 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
3849 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
3850 vol7d_display, dat_display, dat_vect_display, &
3851 to_char_dat, vol7d_check
3852
3853PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3854
3855PRIVATE vol7d_c_e
3856
3857CONTAINS
3858
3859
3864SUBROUTINE vol7d_init(this,time_definition)
3865TYPE(vol7d),intent(out) :: this
3866integer,INTENT(IN),OPTIONAL :: time_definition
3867
3874CALL vol7d_var_features_init() ! initialise var features table once
3875
3876NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
3877
3878NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
3879NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
3880NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
3881NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
3882NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
3883
3884if(present(time_definition)) then
3885 this%time_definition=time_definition
3886else
3887 this%time_definition=1 !default to validity time
3888end if
3889
3890END SUBROUTINE vol7d_init
3891
3892
3896ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
3897TYPE(vol7d),intent(inout) :: this
3898LOGICAL, INTENT(in), OPTIONAL :: dataonly
3899
3900
3901IF (.NOT. optio_log(dataonly)) THEN
3902 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
3903 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
3904 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
3905 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
3906 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
3907 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
3908 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
3909 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
3910 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
3911 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
3912ENDIF
3913IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
3914IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
3915IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
3916IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
3917IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
3918IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
3919IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
3920IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
3921IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
3922IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
3923
3924IF (.NOT. optio_log(dataonly)) THEN
3925 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
3926 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
3927ENDIF
3928IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
3929IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
3930IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
3931
3932IF (.NOT. optio_log(dataonly)) THEN
3936ENDIF
3940
3941END SUBROUTINE vol7d_delete
3942
3943
3944
3945integer function vol7d_check(this)
3946TYPE(vol7d),intent(in) :: this
3947integer :: i,j,k,l,m,n
3948
3949vol7d_check=0
3950
3951if (associated(this%voldatii)) then
3952do i = 1,size(this%voldatii,1)
3953 do j = 1,size(this%voldatii,2)
3954 do k = 1,size(this%voldatii,3)
3955 do l = 1,size(this%voldatii,4)
3956 do m = 1,size(this%voldatii,5)
3957 do n = 1,size(this%voldatii,6)
3958 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
3959 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
3961 vol7d_check=1
3962 end if
3963 end do
3964 end do
3965 end do
3966 end do
3967 end do
3968end do
3969end if
3970
3971
3972if (associated(this%voldatir)) then
3973do i = 1,size(this%voldatir,1)
3974 do j = 1,size(this%voldatir,2)
3975 do k = 1,size(this%voldatir,3)
3976 do l = 1,size(this%voldatir,4)
3977 do m = 1,size(this%voldatir,5)
3978 do n = 1,size(this%voldatir,6)
3979 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
3980 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
3982 vol7d_check=2
3983 end if
3984 end do
3985 end do
3986 end do
3987 end do
3988 end do
3989end do
3990end if
3991
3992if (associated(this%voldatid)) then
3993do i = 1,size(this%voldatid,1)
3994 do j = 1,size(this%voldatid,2)
3995 do k = 1,size(this%voldatid,3)
3996 do l = 1,size(this%voldatid,4)
3997 do m = 1,size(this%voldatid,5)
3998 do n = 1,size(this%voldatid,6)
3999 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4000 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4002 vol7d_check=3
4003 end if
4004 end do
4005 end do
4006 end do
4007 end do
4008 end do
4009end do
4010end if
4011
4012if (associated(this%voldatib)) then
4013do i = 1,size(this%voldatib,1)
4014 do j = 1,size(this%voldatib,2)
4015 do k = 1,size(this%voldatib,3)
4016 do l = 1,size(this%voldatib,4)
4017 do m = 1,size(this%voldatib,5)
4018 do n = 1,size(this%voldatib,6)
4019 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4020 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4022 vol7d_check=4
4023 end if
4024 end do
4025 end do
4026 end do
4027 end do
4028 end do
4029end do
4030end if
4031
4032end function vol7d_check
4033
4034
4035
4036!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4038SUBROUTINE vol7d_display(this)
4039TYPE(vol7d),intent(in) :: this
4040integer :: i
4041
4042REAL :: rdat
4043DOUBLE PRECISION :: ddat
4044INTEGER :: idat
4045INTEGER(kind=int_b) :: bdat
4046CHARACTER(len=vol7d_cdatalen) :: cdat
4047
4048
4049print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4050if (this%time_definition == 0) then
4051 print*,"TIME DEFINITION: time is reference time"
4052else if (this%time_definition == 1) then
4053 print*,"TIME DEFINITION: time is validity time"
4054else
4055 print*,"Time definition have a wrong walue:", this%time_definition
4056end if
4057
4058IF (ASSOCIATED(this%network))then
4059 print*,"---- network vector ----"
4060 print*,"elements=",size(this%network)
4061 do i=1, size(this%network)
4063 end do
4064end IF
4065
4066IF (ASSOCIATED(this%ana))then
4067 print*,"---- ana vector ----"
4068 print*,"elements=",size(this%ana)
4069 do i=1, size(this%ana)
4071 end do
4072end IF
4073
4074IF (ASSOCIATED(this%time))then
4075 print*,"---- time vector ----"
4076 print*,"elements=",size(this%time)
4077 do i=1, size(this%time)
4079 end do
4080end if
4081
4082IF (ASSOCIATED(this%level)) then
4083 print*,"---- level vector ----"
4084 print*,"elements=",size(this%level)
4085 do i =1,size(this%level)
4087 end do
4088end if
4089
4090IF (ASSOCIATED(this%timerange))then
4091 print*,"---- timerange vector ----"
4092 print*,"elements=",size(this%timerange)
4093 do i =1,size(this%timerange)
4095 end do
4096end if
4097
4098
4099print*,"---- ana vector ----"
4100print*,""
4101print*,"->>>>>>>>> anavar -"
4103print*,""
4104print*,"->>>>>>>>> anaattr -"
4106print*,""
4107print*,"->>>>>>>>> anavarattr -"
4109
4110print*,"-- ana data section (first point) --"
4111
4112idat=imiss
4113rdat=rmiss
4114ddat=dmiss
4115bdat=ibmiss
4116cdat=cmiss
4117
4118!ntime = MIN(SIZE(this%time),nprint)
4119!ntimerange = MIN(SIZE(this%timerange),nprint)
4120!nlevel = MIN(SIZE(this%level),nprint)
4121!nnetwork = MIN(SIZE(this%network),nprint)
4122!nana = MIN(SIZE(this%ana),nprint)
4123
4124IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4125if (associated(this%volanai)) then
4126 do i=1,size(this%anavar%i)
4127 idat=this%volanai(1,i,1)
4129 end do
4130end if
4131idat=imiss
4132
4133if (associated(this%volanar)) then
4134 do i=1,size(this%anavar%r)
4135 rdat=this%volanar(1,i,1)
4137 end do
4138end if
4139rdat=rmiss
4140
4141if (associated(this%volanad)) then
4142 do i=1,size(this%anavar%d)
4143 ddat=this%volanad(1,i,1)
4145 end do
4146end if
4147ddat=dmiss
4148
4149if (associated(this%volanab)) then
4150 do i=1,size(this%anavar%b)
4151 bdat=this%volanab(1,i,1)
4153 end do
4154end if
4155bdat=ibmiss
4156
4157if (associated(this%volanac)) then
4158 do i=1,size(this%anavar%c)
4159 cdat=this%volanac(1,i,1)
4161 end do
4162end if
4163cdat=cmiss
4164ENDIF
4165
4166print*,"---- data vector ----"
4167print*,""
4168print*,"->>>>>>>>> dativar -"
4170print*,""
4171print*,"->>>>>>>>> datiattr -"
4173print*,""
4174print*,"->>>>>>>>> dativarattr -"
4176
4177print*,"-- data data section (first point) --"
4178
4179idat=imiss
4180rdat=rmiss
4181ddat=dmiss
4182bdat=ibmiss
4183cdat=cmiss
4184
4185IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4186 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4187if (associated(this%voldatii)) then
4188 do i=1,size(this%dativar%i)
4189 idat=this%voldatii(1,1,1,1,i,1)
4191 end do
4192end if
4193idat=imiss
4194
4195if (associated(this%voldatir)) then
4196 do i=1,size(this%dativar%r)
4197 rdat=this%voldatir(1,1,1,1,i,1)
4199 end do
4200end if
4201rdat=rmiss
4202
4203if (associated(this%voldatid)) then
4204 do i=1,size(this%dativar%d)
4205 ddat=this%voldatid(1,1,1,1,i,1)
4207 end do
4208end if
4209ddat=dmiss
4210
4211if (associated(this%voldatib)) then
4212 do i=1,size(this%dativar%b)
4213 bdat=this%voldatib(1,1,1,1,i,1)
4215 end do
4216end if
4217bdat=ibmiss
4218
4219if (associated(this%voldatic)) then
4220 do i=1,size(this%dativar%c)
4221 cdat=this%voldatic(1,1,1,1,i,1)
4223 end do
4224end if
4225cdat=cmiss
4226ENDIF
4227
4228print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4229
4230END SUBROUTINE vol7d_display
4231
4232
4234SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4235TYPE(vol7d_var),intent(in) :: this
4237REAL :: rdat
4239DOUBLE PRECISION :: ddat
4241INTEGER :: idat
4243INTEGER(kind=int_b) :: bdat
4245CHARACTER(len=*) :: cdat
4246
4247print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4248
4249end SUBROUTINE dat_display
4250
4252SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4253
4254TYPE(vol7d_var),intent(in) :: this(:)
4256REAL :: rdat(:)
4258DOUBLE PRECISION :: ddat(:)
4260INTEGER :: idat(:)
4262INTEGER(kind=int_b) :: bdat(:)
4264CHARACTER(len=*):: cdat(:)
4265
4266integer :: i
4267
4268do i =1,size(this)
4270end do
4271
4272end SUBROUTINE dat_vect_display
4273
4274
4275FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4276#ifdef HAVE_DBALLE
4277USE dballef
4278#endif
4279TYPE(vol7d_var),INTENT(in) :: this
4281REAL :: rdat
4283DOUBLE PRECISION :: ddat
4285INTEGER :: idat
4287INTEGER(kind=int_b) :: bdat
4289CHARACTER(len=*) :: cdat
4290CHARACTER(len=80) :: to_char_dat
4291
4292CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4293
4294
4295#ifdef HAVE_DBALLE
4296INTEGER :: handle, ier
4297
4298handle = 0
4299to_char_dat="VALUE: "
4300
4305
4307 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4308 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4309 ier = idba_fatto(handle)
4310 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4311endif
4312
4313#else
4314
4315to_char_dat="VALUE: "
4321
4322#endif
4323
4324END FUNCTION to_char_dat
4325
4326
4329FUNCTION vol7d_c_e(this) RESULT(c_e)
4330TYPE(vol7d), INTENT(in) :: this
4331
4332LOGICAL :: c_e
4333
4335 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
4336 ASSOCIATED(this%network) .OR. &
4337 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4338 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4339 ASSOCIATED(this%anavar%c) .OR. &
4340 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
4341 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
4342 ASSOCIATED(this%anaattr%c) .OR. &
4343 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4344 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4345 ASSOCIATED(this%dativar%c) .OR. &
4346 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
4347 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
4348 ASSOCIATED(this%datiattr%c)
4349
4350END FUNCTION vol7d_c_e
4351
4352
4391SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
4392 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4393 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4394 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4395 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4396 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4397 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
4398 ini)
4399TYPE(vol7d),INTENT(inout) :: this
4400INTEGER,INTENT(in),OPTIONAL :: nana
4401INTEGER,INTENT(in),OPTIONAL :: ntime
4402INTEGER,INTENT(in),OPTIONAL :: nlevel
4403INTEGER,INTENT(in),OPTIONAL :: ntimerange
4404INTEGER,INTENT(in),OPTIONAL :: nnetwork
4406INTEGER,INTENT(in),OPTIONAL :: &
4407 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4408 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4409 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4410 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4411 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4412 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
4413LOGICAL,INTENT(in),OPTIONAL :: ini
4414
4415INTEGER :: i
4416LOGICAL :: linit
4417
4418IF (PRESENT(ini)) THEN
4419 linit = ini
4420ELSE
4421 linit = .false.
4422ENDIF
4423
4424! Dimensioni principali
4425IF (PRESENT(nana)) THEN
4426 IF (nana >= 0) THEN
4427 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4428 ALLOCATE(this%ana(nana))
4429 IF (linit) THEN
4430 DO i = 1, nana
4432 ENDDO
4433 ENDIF
4434 ENDIF
4435ENDIF
4436IF (PRESENT(ntime)) THEN
4437 IF (ntime >= 0) THEN
4438 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4439 ALLOCATE(this%time(ntime))
4440 IF (linit) THEN
4441 DO i = 1, ntime
4443 ENDDO
4444 ENDIF
4445 ENDIF
4446ENDIF
4447IF (PRESENT(nlevel)) THEN
4448 IF (nlevel >= 0) THEN
4449 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4450 ALLOCATE(this%level(nlevel))
4451 IF (linit) THEN
4452 DO i = 1, nlevel
4454 ENDDO
4455 ENDIF
4456 ENDIF
4457ENDIF
4458IF (PRESENT(ntimerange)) THEN
4459 IF (ntimerange >= 0) THEN
4460 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4461 ALLOCATE(this%timerange(ntimerange))
4462 IF (linit) THEN
4463 DO i = 1, ntimerange
4465 ENDDO
4466 ENDIF
4467 ENDIF
4468ENDIF
4469IF (PRESENT(nnetwork)) THEN
4470 IF (nnetwork >= 0) THEN
4471 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4472 ALLOCATE(this%network(nnetwork))
4473 IF (linit) THEN
4474 DO i = 1, nnetwork
4476 ENDDO
4477 ENDIF
4478 ENDIF
4479ENDIF
4480! Dimensioni dei tipi delle variabili
4481CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
4482 nanavari, nanavarb, nanavarc, ini)
4483CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
4484 nanaattri, nanaattrb, nanaattrc, ini)
4485CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
4486 nanavarattri, nanavarattrb, nanavarattrc, ini)
4487CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
4488 ndativari, ndativarb, ndativarc, ini)
4489CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
4490 ndatiattri, ndatiattrb, ndatiattrc, ini)
4491CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
4492 ndativarattri, ndativarattrb, ndativarattrc, ini)
4493
4494END SUBROUTINE vol7d_alloc
4495
4496
4497FUNCTION vol7d_check_alloc_ana(this)
4498TYPE(vol7d),INTENT(in) :: this
4499LOGICAL :: vol7d_check_alloc_ana
4500
4501vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
4502
4503END FUNCTION vol7d_check_alloc_ana
4504
4505SUBROUTINE vol7d_force_alloc_ana(this, ini)
4506TYPE(vol7d),INTENT(inout) :: this
4507LOGICAL,INTENT(in),OPTIONAL :: ini
4508
4509! Alloco i descrittori minimi per avere un volume di anagrafica
4510IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
4511IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
4512
4513END SUBROUTINE vol7d_force_alloc_ana
4514
4515
4516FUNCTION vol7d_check_alloc_dati(this)
4517TYPE(vol7d),INTENT(in) :: this
4518LOGICAL :: vol7d_check_alloc_dati
4519
4520vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
4521 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
4522 ASSOCIATED(this%timerange)
4523
4524END FUNCTION vol7d_check_alloc_dati
4525
4526SUBROUTINE vol7d_force_alloc_dati(this, ini)
4527TYPE(vol7d),INTENT(inout) :: this
4528LOGICAL,INTENT(in),OPTIONAL :: ini
4529
4530! Alloco i descrittori minimi per avere un volume di dati
4531CALL vol7d_force_alloc_ana(this, ini)
4532IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
4533IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
4534IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
4535
4536END SUBROUTINE vol7d_force_alloc_dati
4537
4538
4539SUBROUTINE vol7d_force_alloc(this)
4540TYPE(vol7d),INTENT(inout) :: this
4541
4542! If anything really not allocated yet, allocate with size 0
4543IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
4544IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
4545IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
4546IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
4547IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
4548
4549END SUBROUTINE vol7d_force_alloc
4550
4551
4552FUNCTION vol7d_check_vol(this)
4553TYPE(vol7d),INTENT(in) :: this
4554LOGICAL :: vol7d_check_vol
4555
4556vol7d_check_vol = c_e(this)
4557
4558! Anagrafica
4559IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4560 vol7d_check_vol = .false.
4561ENDIF
4562
4563IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4564 vol7d_check_vol = .false.
4565ENDIF
4566
4567IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4568 vol7d_check_vol = .false.
4569ENDIF
4570
4571IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4572 vol7d_check_vol = .false.
4573ENDIF
4574
4575IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4576 vol7d_check_vol = .false.
4577ENDIF
4578IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4579 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4580 ASSOCIATED(this%anavar%c)) THEN
4581 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
4582ENDIF
4583
4584! Attributi dell'anagrafica
4585IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4586 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4587 vol7d_check_vol = .false.
4588ENDIF
4589
4590IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4591 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4592 vol7d_check_vol = .false.
4593ENDIF
4594
4595IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4596 .NOT.ASSOCIATED(this%volanaattri)) THEN
4597 vol7d_check_vol = .false.
4598ENDIF
4599
4600IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4601 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4602 vol7d_check_vol = .false.
4603ENDIF
4604
4605IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4606 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4607 vol7d_check_vol = .false.
4608ENDIF
4609
4610! Dati
4611IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4612 vol7d_check_vol = .false.
4613ENDIF
4614
4615IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4616 vol7d_check_vol = .false.
4617ENDIF
4618
4619IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4620 vol7d_check_vol = .false.
4621ENDIF
4622
4623IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4624 vol7d_check_vol = .false.
4625ENDIF
4626
4627IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4628 vol7d_check_vol = .false.
4629ENDIF
4630
4631! Attributi dei dati
4632IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4633 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4634 vol7d_check_vol = .false.
4635ENDIF
4636
4637IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4638 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4639 vol7d_check_vol = .false.
4640ENDIF
4641
4642IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4643 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4644 vol7d_check_vol = .false.
4645ENDIF
4646
4647IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4648 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4649 vol7d_check_vol = .false.
4650ENDIF
4651
4652IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4653 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4654 vol7d_check_vol = .false.
4655ENDIF
4656IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4657 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4658 ASSOCIATED(this%dativar%c)) THEN
4659 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
4660ENDIF
4661
4662END FUNCTION vol7d_check_vol
4663
4664
4679SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
4680TYPE(vol7d),INTENT(inout) :: this
4681LOGICAL,INTENT(in),OPTIONAL :: ini
4682LOGICAL,INTENT(in),OPTIONAL :: inivol
4683
4684LOGICAL :: linivol
4685
4686IF (PRESENT(inivol)) THEN
4687 linivol = inivol
4688ELSE
4689 linivol = .true.
4690ENDIF
4691
4692! Anagrafica
4693IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4694 CALL vol7d_force_alloc_ana(this, ini)
4695 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
4696 IF (linivol) this%volanar(:,:,:) = rmiss
4697ENDIF
4698
4699IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4700 CALL vol7d_force_alloc_ana(this, ini)
4701 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
4702 IF (linivol) this%volanad(:,:,:) = rdmiss
4703ENDIF
4704
4705IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4706 CALL vol7d_force_alloc_ana(this, ini)
4707 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
4708 IF (linivol) this%volanai(:,:,:) = imiss
4709ENDIF
4710
4711IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4712 CALL vol7d_force_alloc_ana(this, ini)
4713 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
4714 IF (linivol) this%volanab(:,:,:) = ibmiss
4715ENDIF
4716
4717IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4718 CALL vol7d_force_alloc_ana(this, ini)
4719 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
4720 IF (linivol) this%volanac(:,:,:) = cmiss
4721ENDIF
4722
4723! Attributi dell'anagrafica
4724IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4725 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4726 CALL vol7d_force_alloc_ana(this, ini)
4727 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
4728 SIZE(this%network), SIZE(this%anaattr%r)))
4729 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
4730ENDIF
4731
4732IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4733 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4734 CALL vol7d_force_alloc_ana(this, ini)
4735 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
4736 SIZE(this%network), SIZE(this%anaattr%d)))
4737 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
4738ENDIF
4739
4740IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4741 .NOT.ASSOCIATED(this%volanaattri)) THEN
4742 CALL vol7d_force_alloc_ana(this, ini)
4743 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
4744 SIZE(this%network), SIZE(this%anaattr%i)))
4745 IF (linivol) this%volanaattri(:,:,:,:) = imiss
4746ENDIF
4747
4748IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4749 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4750 CALL vol7d_force_alloc_ana(this, ini)
4751 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
4752 SIZE(this%network), SIZE(this%anaattr%b)))
4753 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
4754ENDIF
4755
4756IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4757 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4758 CALL vol7d_force_alloc_ana(this, ini)
4759 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
4760 SIZE(this%network), SIZE(this%anaattr%c)))
4761 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
4762ENDIF
4763
4764! Dati
4765IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4766 CALL vol7d_force_alloc_dati(this, ini)
4767 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4768 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
4769 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
4770ENDIF
4771
4772IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4773 CALL vol7d_force_alloc_dati(this, ini)
4774 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4775 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
4776 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
4777ENDIF
4778
4779IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4780 CALL vol7d_force_alloc_dati(this, ini)
4781 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4782 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
4783 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
4784ENDIF
4785
4786IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4787 CALL vol7d_force_alloc_dati(this, ini)
4788 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4789 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
4790 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
4791ENDIF
4792
4793IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4794 CALL vol7d_force_alloc_dati(this, ini)
4795 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4796 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
4797 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
4798ENDIF
4799
4800! Attributi dei dati
4801IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4802 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4803 CALL vol7d_force_alloc_dati(this, ini)
4804 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4805 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
4806 SIZE(this%datiattr%r)))
4807 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
4808ENDIF
4809
4810IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4811 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4812 CALL vol7d_force_alloc_dati(this, ini)
4813 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4814 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
4815 SIZE(this%datiattr%d)))
4816 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
4817ENDIF
4818
4819IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4820 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4821 CALL vol7d_force_alloc_dati(this, ini)
4822 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4823 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
4824 SIZE(this%datiattr%i)))
4825 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
4826ENDIF
4827
4828IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4829 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4830 CALL vol7d_force_alloc_dati(this, ini)
4831 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4832 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
4833 SIZE(this%datiattr%b)))
4834 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
4835ENDIF
4836
4837IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4838 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4839 CALL vol7d_force_alloc_dati(this, ini)
4840 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4841 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
4842 SIZE(this%datiattr%c)))
4843 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
4844ENDIF
4845
4846! Catch-all method
4847CALL vol7d_force_alloc(this)
4848
4849! Creo gli indici var-attr
4850
4851#ifdef DEBUG
4852CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
4853#endif
4854
4855CALL vol7d_set_attr_ind(this)
4856
4857
4858
4859END SUBROUTINE vol7d_alloc_vol
4860
4861
4868SUBROUTINE vol7d_set_attr_ind(this)
4869TYPE(vol7d),INTENT(inout) :: this
4870
4871INTEGER :: i
4872
4873! real
4874IF (ASSOCIATED(this%dativar%r)) THEN
4875 IF (ASSOCIATED(this%dativarattr%r)) THEN
4876 DO i = 1, SIZE(this%dativar%r)
4877 this%dativar%r(i)%r = &
4878 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
4879 ENDDO
4880 ENDIF
4881
4882 IF (ASSOCIATED(this%dativarattr%d)) THEN
4883 DO i = 1, SIZE(this%dativar%r)
4884 this%dativar%r(i)%d = &
4885 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
4886 ENDDO
4887 ENDIF
4888
4889 IF (ASSOCIATED(this%dativarattr%i)) THEN
4890 DO i = 1, SIZE(this%dativar%r)
4891 this%dativar%r(i)%i = &
4892 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
4893 ENDDO
4894 ENDIF
4895
4896 IF (ASSOCIATED(this%dativarattr%b)) THEN
4897 DO i = 1, SIZE(this%dativar%r)
4898 this%dativar%r(i)%b = &
4899 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
4900 ENDDO
4901 ENDIF
4902
4903 IF (ASSOCIATED(this%dativarattr%c)) THEN
4904 DO i = 1, SIZE(this%dativar%r)
4905 this%dativar%r(i)%c = &
4906 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
4907 ENDDO
4908 ENDIF
4909ENDIF
4910! double
4911IF (ASSOCIATED(this%dativar%d)) THEN
4912 IF (ASSOCIATED(this%dativarattr%r)) THEN
4913 DO i = 1, SIZE(this%dativar%d)
4914 this%dativar%d(i)%r = &
4915 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
4916 ENDDO
4917 ENDIF
4918
4919 IF (ASSOCIATED(this%dativarattr%d)) THEN
4920 DO i = 1, SIZE(this%dativar%d)
4921 this%dativar%d(i)%d = &
4922 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
4923 ENDDO
4924 ENDIF
4925
4926 IF (ASSOCIATED(this%dativarattr%i)) THEN
4927 DO i = 1, SIZE(this%dativar%d)
4928 this%dativar%d(i)%i = &
4929 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
4930 ENDDO
4931 ENDIF
4932
4933 IF (ASSOCIATED(this%dativarattr%b)) THEN
4934 DO i = 1, SIZE(this%dativar%d)
4935 this%dativar%d(i)%b = &
4936 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
4937 ENDDO
4938 ENDIF
4939
4940 IF (ASSOCIATED(this%dativarattr%c)) THEN
4941 DO i = 1, SIZE(this%dativar%d)
4942 this%dativar%d(i)%c = &
4943 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
4944 ENDDO
4945 ENDIF
4946ENDIF
4947! integer
4948IF (ASSOCIATED(this%dativar%i)) THEN
4949 IF (ASSOCIATED(this%dativarattr%r)) THEN
4950 DO i = 1, SIZE(this%dativar%i)
4951 this%dativar%i(i)%r = &
4952 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
4953 ENDDO
4954 ENDIF
4955
4956 IF (ASSOCIATED(this%dativarattr%d)) THEN
4957 DO i = 1, SIZE(this%dativar%i)
4958 this%dativar%i(i)%d = &
4959 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
4960 ENDDO
4961 ENDIF
4962
4963 IF (ASSOCIATED(this%dativarattr%i)) THEN
4964 DO i = 1, SIZE(this%dativar%i)
4965 this%dativar%i(i)%i = &
4966 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
4967 ENDDO
4968 ENDIF
4969
4970 IF (ASSOCIATED(this%dativarattr%b)) THEN
4971 DO i = 1, SIZE(this%dativar%i)
4972 this%dativar%i(i)%b = &
4973 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
4974 ENDDO
4975 ENDIF
4976
4977 IF (ASSOCIATED(this%dativarattr%c)) THEN
4978 DO i = 1, SIZE(this%dativar%i)
4979 this%dativar%i(i)%c = &
4980 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
4981 ENDDO
4982 ENDIF
4983ENDIF
4984! byte
4985IF (ASSOCIATED(this%dativar%b)) THEN
4986 IF (ASSOCIATED(this%dativarattr%r)) THEN
4987 DO i = 1, SIZE(this%dativar%b)
4988 this%dativar%b(i)%r = &
4989 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
4990 ENDDO
4991 ENDIF
4992
4993 IF (ASSOCIATED(this%dativarattr%d)) THEN
4994 DO i = 1, SIZE(this%dativar%b)
4995 this%dativar%b(i)%d = &
4996 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
4997 ENDDO
4998 ENDIF
4999
5000 IF (ASSOCIATED(this%dativarattr%i)) THEN
5001 DO i = 1, SIZE(this%dativar%b)
5002 this%dativar%b(i)%i = &
5003 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5004 ENDDO
5005 ENDIF
5006
5007 IF (ASSOCIATED(this%dativarattr%b)) THEN
5008 DO i = 1, SIZE(this%dativar%b)
5009 this%dativar%b(i)%b = &
5010 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5011 ENDDO
5012 ENDIF
5013
5014 IF (ASSOCIATED(this%dativarattr%c)) THEN
5015 DO i = 1, SIZE(this%dativar%b)
5016 this%dativar%b(i)%c = &
5017 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5018 ENDDO
5019 ENDIF
5020ENDIF
5021! character
5022IF (ASSOCIATED(this%dativar%c)) THEN
5023 IF (ASSOCIATED(this%dativarattr%r)) THEN
5024 DO i = 1, SIZE(this%dativar%c)
5025 this%dativar%c(i)%r = &
5026 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5027 ENDDO
5028 ENDIF
5029
5030 IF (ASSOCIATED(this%dativarattr%d)) THEN
5031 DO i = 1, SIZE(this%dativar%c)
5032 this%dativar%c(i)%d = &
5033 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5034 ENDDO
5035 ENDIF
5036
5037 IF (ASSOCIATED(this%dativarattr%i)) THEN
5038 DO i = 1, SIZE(this%dativar%c)
5039 this%dativar%c(i)%i = &
5040 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5041 ENDDO
5042 ENDIF
5043
5044 IF (ASSOCIATED(this%dativarattr%b)) THEN
5045 DO i = 1, SIZE(this%dativar%c)
5046 this%dativar%c(i)%b = &
5047 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5048 ENDDO
5049 ENDIF
5050
5051 IF (ASSOCIATED(this%dativarattr%c)) THEN
5052 DO i = 1, SIZE(this%dativar%c)
5053 this%dativar%c(i)%c = &
5054 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5055 ENDDO
5056 ENDIF
5057ENDIF
5058
5059END SUBROUTINE vol7d_set_attr_ind
5060
5061
5066SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5067 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5068TYPE(vol7d),INTENT(INOUT) :: this
5069TYPE(vol7d),INTENT(INOUT) :: that
5070LOGICAL,INTENT(IN),OPTIONAL :: sort
5071LOGICAL,INTENT(in),OPTIONAL :: bestdata
5072LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5073
5074TYPE(vol7d) :: v7d_clean
5075
5076
5078 this = that
5080 that = v7d_clean ! destroy that without deallocating
5081ELSE ! Append that to this and destroy that
5083 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5085ENDIF
5086
5087END SUBROUTINE vol7d_merge
5088
5089
5118SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5119 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5120TYPE(vol7d),INTENT(INOUT) :: this
5121TYPE(vol7d),INTENT(IN) :: that
5122LOGICAL,INTENT(IN),OPTIONAL :: sort
5123! experimental, please do not use outside the library now, they force the use
5124! of a simplified mapping algorithm which is valid only whene the dimension
5125! content is the same in both volumes , or when one of them is empty
5126LOGICAL,INTENT(in),OPTIONAL :: bestdata
5127LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5128
5129
5130TYPE(vol7d) :: v7dtmp
5131LOGICAL :: lsort, lbestdata
5132INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5133 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5134
5136IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5139 RETURN
5140ENDIF
5141
5142IF (this%time_definition /= that%time_definition) THEN
5143 CALL l4f_log(l4f_fatal, &
5144 'in vol7d_append, cannot append volumes with different &
5145 &time definition')
5146 CALL raise_fatal_error()
5147ENDIF
5148
5149! Completo l'allocazione per avere volumi a norma
5150CALL vol7d_alloc_vol(this)
5151
5155
5156! Calcolo le mappature tra volumi vecchi e volume nuovo
5157! I puntatori remap* vengono tutti o allocati o nullificati
5158IF (optio_log(ltimesimple)) THEN
5159 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5160 lsort, remapt1, remapt2)
5161ELSE
5162 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5163 lsort, remapt1, remapt2)
5164ENDIF
5165IF (optio_log(ltimerangesimple)) THEN
5166 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5167 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5168ELSE
5169 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5170 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5171ENDIF
5172IF (optio_log(llevelsimple)) THEN
5173 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5174 lsort, remapl1, remapl2)
5175ELSE
5176 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5177 lsort, remapl1, remapl2)
5178ENDIF
5179IF (optio_log(lanasimple)) THEN
5180 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5181 .false., remapa1, remapa2)
5182ELSE
5183 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5184 .false., remapa1, remapa2)
5185ENDIF
5186IF (optio_log(lnetworksimple)) THEN
5187 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5188 .false., remapn1, remapn2)
5189ELSE
5190 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5191 .false., remapn1, remapn2)
5192ENDIF
5193
5194! Faccio la fusione fisica dei volumi
5195CALL vol7d_merge_finalr(this, that, v7dtmp, &
5196 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5197 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5198CALL vol7d_merge_finald(this, that, v7dtmp, &
5199 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5200 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5201CALL vol7d_merge_finali(this, that, v7dtmp, &
5202 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5203 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5204CALL vol7d_merge_finalb(this, that, v7dtmp, &
5205 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5206 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5207CALL vol7d_merge_finalc(this, that, v7dtmp, &
5208 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5209 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5210
5211! Dealloco i vettori di rimappatura
5212IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5213IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5214IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5215IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5216IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5217IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5218IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5219IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5220IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5221IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5222
5223! Distruggo il vecchio volume e assegno il nuovo a this
5225this = v7dtmp
5226! Ricreo gli indici var-attr
5227CALL vol7d_set_attr_ind(this)
5228
5229END SUBROUTINE vol7d_append
5230
5231
5264SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5265 lsort_time, lsort_timerange, lsort_level, &
5266 ltime, ltimerange, llevel, lana, lnetwork, &
5267 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5268 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5269 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5270 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5271 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5272 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5273TYPE(vol7d),INTENT(IN) :: this
5274TYPE(vol7d),INTENT(INOUT) :: that
5275LOGICAL,INTENT(IN),OPTIONAL :: sort
5276LOGICAL,INTENT(IN),OPTIONAL :: unique
5277LOGICAL,INTENT(IN),OPTIONAL :: miss
5278LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5279LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5280LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5288LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5290LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5292LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5294LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5296LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5298LOGICAL,INTENT(in),OPTIONAL :: &
5299 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5300 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5301 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5302 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5303 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5304 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5305
5306LOGICAL :: lsort, lunique, lmiss
5307INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5308
5311IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5312
5316
5317! Calcolo le mappature tra volume vecchio e volume nuovo
5318! I puntatori remap* vengono tutti o allocati o nullificati
5319CALL vol7d_remap1_datetime(this%time, that%time, &
5320 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
5321CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
5322 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
5323CALL vol7d_remap1_vol7d_level(this%level, that%level, &
5324 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
5325CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
5326 lsort, lunique, lmiss, remapa, lana)
5327CALL vol7d_remap1_vol7d_network(this%network, that%network, &
5328 lsort, lunique, lmiss, remapn, lnetwork)
5329
5330! lanavari, lanavarb, lanavarc, &
5331! lanaattri, lanaattrb, lanaattrc, &
5332! lanavarattri, lanavarattrb, lanavarattrc, &
5333! ldativari, ldativarb, ldativarc, &
5334! ldatiattri, ldatiattrb, ldatiattrc, &
5335! ldativarattri, ldativarattrb, ldativarattrc
5336! Faccio la riforma fisica dei volumi
5337CALL vol7d_reform_finalr(this, that, &
5338 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5339 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
5340CALL vol7d_reform_finald(this, that, &
5341 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5342 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
5343CALL vol7d_reform_finali(this, that, &
5344 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5345 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
5346CALL vol7d_reform_finalb(this, that, &
5347 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5348 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
5349CALL vol7d_reform_finalc(this, that, &
5350 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5351 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
5352
5353! Dealloco i vettori di rimappatura
5354IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
5355IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
5356IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
5357IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
5358IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
5359
5360! Ricreo gli indici var-attr
5361CALL vol7d_set_attr_ind(that)
5362that%time_definition = this%time_definition
5363
5364END SUBROUTINE vol7d_copy
5365
5366
5377SUBROUTINE vol7d_reform(this, sort, unique, miss, &
5378 lsort_time, lsort_timerange, lsort_level, &
5379 ltime, ltimerange, llevel, lana, lnetwork, &
5380 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5381 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5382 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5383 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5384 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5385 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
5386 ,purgeana)
5387TYPE(vol7d),INTENT(INOUT) :: this
5388LOGICAL,INTENT(IN),OPTIONAL :: sort
5389LOGICAL,INTENT(IN),OPTIONAL :: unique
5390LOGICAL,INTENT(IN),OPTIONAL :: miss
5391LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5392LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5393LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5401LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5402LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5403LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5404LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5405LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5407LOGICAL,INTENT(in),OPTIONAL :: &
5408 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5409 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5410 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5411 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5412 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5413 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5414LOGICAL,INTENT(IN),OPTIONAL :: purgeana
5415
5416TYPE(vol7d) :: v7dtmp
5417logical,allocatable :: llana(:)
5418integer :: i
5419
5421 lsort_time, lsort_timerange, lsort_level, &
5422 ltime, ltimerange, llevel, lana, lnetwork, &
5423 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5424 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5425 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5426 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5427 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5428 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5429
5430! destroy old volume
5432
5433if (optio_log(purgeana)) then
5434 allocate(llana(size(v7dtmp%ana)))
5435 llana =.false.
5436 do i =1,size(v7dtmp%ana)
5437 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
5438 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
5439 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
5440 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
5441 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
5442 end do
5443 CALL vol7d_copy(v7dtmp, this,lana=llana)
5445 deallocate(llana)
5446else
5447 this=v7dtmp
5448end if
5449
5450END SUBROUTINE vol7d_reform
5451
5452
5460SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
5461TYPE(vol7d),INTENT(INOUT) :: this
5462LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
5463LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
5464LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
5465
5466INTEGER :: i
5467LOGICAL :: to_be_sorted
5468
5469to_be_sorted = .false.
5470CALL vol7d_alloc_vol(this) ! usual safety check
5471
5472IF (optio_log(lsort_time)) THEN
5473 DO i = 2, SIZE(this%time)
5474 IF (this%time(i) < this%time(i-1)) THEN
5475 to_be_sorted = .true.
5476 EXIT
5477 ENDIF
5478 ENDDO
5479ENDIF
5480IF (optio_log(lsort_timerange)) THEN
5481 DO i = 2, SIZE(this%timerange)
5482 IF (this%timerange(i) < this%timerange(i-1)) THEN
5483 to_be_sorted = .true.
5484 EXIT
5485 ENDIF
5486 ENDDO
5487ENDIF
5488IF (optio_log(lsort_level)) THEN
5489 DO i = 2, SIZE(this%level)
5490 IF (this%level(i) < this%level(i-1)) THEN
5491 to_be_sorted = .true.
5492 EXIT
5493 ENDIF
5494 ENDDO
5495ENDIF
5496
5497IF (to_be_sorted) CALL vol7d_reform(this, &
5498 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
5499
5500END SUBROUTINE vol7d_smart_sort
5501
5509SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
5510TYPE(vol7d),INTENT(inout) :: this
5511CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
5512CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
5513TYPE(vol7d_network),OPTIONAL :: nl(:)
5514TYPE(datetime),INTENT(in),OPTIONAL :: s_d
5515TYPE(datetime),INTENT(in),OPTIONAL :: e_d
5516
5517INTEGER :: i
5518
5519IF (PRESENT(avl)) THEN
5520 IF (SIZE(avl) > 0) THEN
5521
5522 IF (ASSOCIATED(this%anavar%r)) THEN
5523 DO i = 1, SIZE(this%anavar%r)
5524 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
5525 ENDDO
5526 ENDIF
5527
5528 IF (ASSOCIATED(this%anavar%i)) THEN
5529 DO i = 1, SIZE(this%anavar%i)
5530 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
5531 ENDDO
5532 ENDIF
5533
5534 IF (ASSOCIATED(this%anavar%b)) THEN
5535 DO i = 1, SIZE(this%anavar%b)
5536 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
5537 ENDDO
5538 ENDIF
5539
5540 IF (ASSOCIATED(this%anavar%d)) THEN
5541 DO i = 1, SIZE(this%anavar%d)
5542 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
5543 ENDDO
5544 ENDIF
5545
5546 IF (ASSOCIATED(this%anavar%c)) THEN
5547 DO i = 1, SIZE(this%anavar%c)
5548 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
5549 ENDDO
5550 ENDIF
5551
5552 ENDIF
5553ENDIF
5554
5555
5556IF (PRESENT(vl)) THEN
5557 IF (size(vl) > 0) THEN
5558 IF (ASSOCIATED(this%dativar%r)) THEN
5559 DO i = 1, SIZE(this%dativar%r)
5560 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
5561 ENDDO
5562 ENDIF
5563
5564 IF (ASSOCIATED(this%dativar%i)) THEN
5565 DO i = 1, SIZE(this%dativar%i)
5566 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
5567 ENDDO
5568 ENDIF
5569
5570 IF (ASSOCIATED(this%dativar%b)) THEN
5571 DO i = 1, SIZE(this%dativar%b)
5572 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
5573 ENDDO
5574 ENDIF
5575
5576 IF (ASSOCIATED(this%dativar%d)) THEN
5577 DO i = 1, SIZE(this%dativar%d)
5578 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
5579 ENDDO
5580 ENDIF
5581
5582 IF (ASSOCIATED(this%dativar%c)) THEN
5583 DO i = 1, SIZE(this%dativar%c)
5584 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5585 ENDDO
5586 ENDIF
5587
5588 IF (ASSOCIATED(this%dativar%c)) THEN
5589 DO i = 1, SIZE(this%dativar%c)
5590 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5591 ENDDO
5592 ENDIF
5593
5594 ENDIF
5595ENDIF
5596
5597IF (PRESENT(nl)) THEN
5598 IF (SIZE(nl) > 0) THEN
5599 DO i = 1, SIZE(this%network)
5600 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
5601 ENDDO
5602 ENDIF
5603ENDIF
5604
5605IF (PRESENT(s_d)) THEN
5607 WHERE (this%time < s_d)
5608 this%time = datetime_miss
5609 END WHERE
5610 ENDIF
5611ENDIF
5612
5613IF (PRESENT(e_d)) THEN
5615 WHERE (this%time > e_d)
5616 this%time = datetime_miss
5617 END WHERE
5618 ENDIF
5619ENDIF
5620
5621CALL vol7d_reform(this, miss=.true.)
5622
5623END SUBROUTINE vol7d_filter
5624
5625
5632SUBROUTINE vol7d_convr(this, that, anaconv)
5633TYPE(vol7d),INTENT(IN) :: this
5634TYPE(vol7d),INTENT(INOUT) :: that
5635LOGICAL,OPTIONAL,INTENT(in) :: anaconv
5636INTEGER :: i
5637LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
5638TYPE(vol7d) :: v7d_tmp
5639
5640IF (optio_log(anaconv)) THEN
5641 acp=fv
5642 acn=tv
5643ELSE
5644 acp=tv
5645 acn=fv
5646ENDIF
5647
5648! Volume con solo i dati reali e tutti gli attributi
5649! l'anagrafica e` copiata interamente se necessario
5650CALL vol7d_copy(this, that, &
5651 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
5652 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
5653
5654! Volume solo di dati double
5655CALL vol7d_copy(this, v7d_tmp, &
5656 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
5657 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5658 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5659 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
5660 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5661 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5662
5663! converto a dati reali
5664IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
5665
5666 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
5667! alloco i dati reali e vi trasferisco i double
5668 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
5669 SIZE(v7d_tmp%volanad, 3)))
5670 DO i = 1, SIZE(v7d_tmp%anavar%d)
5671 v7d_tmp%volanar(:,i,:) = &
5672 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
5673 ENDDO
5674 DEALLOCATE(v7d_tmp%volanad)
5675! trasferisco le variabili
5676 v7d_tmp%anavar%r => v7d_tmp%anavar%d
5677 NULLIFY(v7d_tmp%anavar%d)
5678 ENDIF
5679
5680 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
5681! alloco i dati reali e vi trasferisco i double
5682 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
5683 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
5684 SIZE(v7d_tmp%voldatid, 6)))
5685 DO i = 1, SIZE(v7d_tmp%dativar%d)
5686 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5687 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
5688 ENDDO
5689 DEALLOCATE(v7d_tmp%voldatid)
5690! trasferisco le variabili
5691 v7d_tmp%dativar%r => v7d_tmp%dativar%d
5692 NULLIFY(v7d_tmp%dativar%d)
5693 ENDIF
5694
5695! fondo con il volume definitivo
5696 CALL vol7d_merge(that, v7d_tmp)
5697ELSE
5699ENDIF
5700
5701
5702! Volume solo di dati interi
5703CALL vol7d_copy(this, v7d_tmp, &
5704 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
5705 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5706 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5707 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
5708 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5709 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5710
5711! converto a dati reali
5712IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
5713
5714 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
5715! alloco i dati reali e vi trasferisco gli interi
5716 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
5717 SIZE(v7d_tmp%volanai, 3)))
5718 DO i = 1, SIZE(v7d_tmp%anavar%i)
5719 v7d_tmp%volanar(:,i,:) = &
5720 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
5721 ENDDO
5722 DEALLOCATE(v7d_tmp%volanai)
5723! trasferisco le variabili
5724 v7d_tmp%anavar%r => v7d_tmp%anavar%i
5725 NULLIFY(v7d_tmp%anavar%i)
5726 ENDIF
5727
5728 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
5729! alloco i dati reali e vi trasferisco gli interi
5730 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
5731 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
5732 SIZE(v7d_tmp%voldatii, 6)))
5733 DO i = 1, SIZE(v7d_tmp%dativar%i)
5734 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5735 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
5736 ENDDO
5737 DEALLOCATE(v7d_tmp%voldatii)
5738! trasferisco le variabili
5739 v7d_tmp%dativar%r => v7d_tmp%dativar%i
5740 NULLIFY(v7d_tmp%dativar%i)
5741 ENDIF
5742
5743! fondo con il volume definitivo
5744 CALL vol7d_merge(that, v7d_tmp)
5745ELSE
5747ENDIF
5748
5749
5750! Volume solo di dati byte
5751CALL vol7d_copy(this, v7d_tmp, &
5752 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
5753 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5754 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5755 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
5756 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5757 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5758
5759! converto a dati reali
5760IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
5761
5762 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
5763! alloco i dati reali e vi trasferisco i byte
5764 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
5765 SIZE(v7d_tmp%volanab, 3)))
5766 DO i = 1, SIZE(v7d_tmp%anavar%b)
5767 v7d_tmp%volanar(:,i,:) = &
5768 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
5769 ENDDO
5770 DEALLOCATE(v7d_tmp%volanab)
5771! trasferisco le variabili
5772 v7d_tmp%anavar%r => v7d_tmp%anavar%b
5773 NULLIFY(v7d_tmp%anavar%b)
5774 ENDIF
5775
5776 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
5777! alloco i dati reali e vi trasferisco i byte
5778 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
5779 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
5780 SIZE(v7d_tmp%voldatib, 6)))
5781 DO i = 1, SIZE(v7d_tmp%dativar%b)
5782 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5783 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
5784 ENDDO
5785 DEALLOCATE(v7d_tmp%voldatib)
5786! trasferisco le variabili
5787 v7d_tmp%dativar%r => v7d_tmp%dativar%b
5788 NULLIFY(v7d_tmp%dativar%b)
5789 ENDIF
5790
5791! fondo con il volume definitivo
5792 CALL vol7d_merge(that, v7d_tmp)
5793ELSE
5795ENDIF
5796
5797
5798! Volume solo di dati character
5799CALL vol7d_copy(this, v7d_tmp, &
5800 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
5801 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5802 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5803 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
5804 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5805 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5806
5807! converto a dati reali
5808IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
5809
5810 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
5811! alloco i dati reali e vi trasferisco i character
5812 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
5813 SIZE(v7d_tmp%volanac, 3)))
5814 DO i = 1, SIZE(v7d_tmp%anavar%c)
5815 v7d_tmp%volanar(:,i,:) = &
5816 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
5817 ENDDO
5818 DEALLOCATE(v7d_tmp%volanac)
5819! trasferisco le variabili
5820 v7d_tmp%anavar%r => v7d_tmp%anavar%c
5821 NULLIFY(v7d_tmp%anavar%c)
5822 ENDIF
5823
5824 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
5825! alloco i dati reali e vi trasferisco i character
5826 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
5827 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
5828 SIZE(v7d_tmp%voldatic, 6)))
5829 DO i = 1, SIZE(v7d_tmp%dativar%c)
5830 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5831 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
5832 ENDDO
5833 DEALLOCATE(v7d_tmp%voldatic)
5834! trasferisco le variabili
5835 v7d_tmp%dativar%r => v7d_tmp%dativar%c
5836 NULLIFY(v7d_tmp%dativar%c)
5837 ENDIF
5838
5839! fondo con il volume definitivo
5840 CALL vol7d_merge(that, v7d_tmp)
5841ELSE
5843ENDIF
5844
5845END SUBROUTINE vol7d_convr
5846
5847
5851SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
5852TYPE(vol7d),INTENT(IN) :: this
5853TYPE(vol7d),INTENT(OUT) :: that
5854logical , optional, intent(in) :: data_only
5855logical , optional, intent(in) :: ana
5856logical :: ldata_only,lana
5857
5858IF (PRESENT(data_only)) THEN
5859 ldata_only = data_only
5860ELSE
5861 ldata_only = .false.
5862ENDIF
5863
5864IF (PRESENT(ana)) THEN
5865 lana = ana
5866ELSE
5867 lana = .false.
5868ENDIF
5869
5870
5871#undef VOL7D_POLY_ARRAY
5872#define VOL7D_POLY_ARRAY voldati
5873#include "vol7d_class_diff.F90"
5874#undef VOL7D_POLY_ARRAY
5875#define VOL7D_POLY_ARRAY voldatiattr
5876#include "vol7d_class_diff.F90"
5877#undef VOL7D_POLY_ARRAY
5878
5879if ( .not. ldata_only) then
5880
5881#define VOL7D_POLY_ARRAY volana
5882#include "vol7d_class_diff.F90"
5883#undef VOL7D_POLY_ARRAY
5884#define VOL7D_POLY_ARRAY volanaattr
5885#include "vol7d_class_diff.F90"
5886#undef VOL7D_POLY_ARRAY
5887
5888 if(lana)then
5889 where ( this%ana == that%ana )
5890 that%ana = vol7d_ana_miss
5891 end where
5892 end if
5893
5894end if
5895
5896
5897
5898END SUBROUTINE vol7d_diff_only
5899
5900
5901
5902! Creo le routine da ripetere per i vari tipi di dati di v7d
5903! tramite un template e il preprocessore
5904#undef VOL7D_POLY_TYPE
5905#undef VOL7D_POLY_TYPES
5906#define VOL7D_POLY_TYPE REAL
5907#define VOL7D_POLY_TYPES r
5908#include "vol7d_class_type_templ.F90"
5909#undef VOL7D_POLY_TYPE
5910#undef VOL7D_POLY_TYPES
5911#define VOL7D_POLY_TYPE DOUBLE PRECISION
5912#define VOL7D_POLY_TYPES d
5913#include "vol7d_class_type_templ.F90"
5914#undef VOL7D_POLY_TYPE
5915#undef VOL7D_POLY_TYPES
5916#define VOL7D_POLY_TYPE INTEGER
5917#define VOL7D_POLY_TYPES i
5918#include "vol7d_class_type_templ.F90"
5919#undef VOL7D_POLY_TYPE
5920#undef VOL7D_POLY_TYPES
5921#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
5922#define VOL7D_POLY_TYPES b
5923#include "vol7d_class_type_templ.F90"
5924#undef VOL7D_POLY_TYPE
5925#undef VOL7D_POLY_TYPES
5926#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
5927#define VOL7D_POLY_TYPES c
5928#include "vol7d_class_type_templ.F90"
5929
5930! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
5931! tramite un template e il preprocessore
5932#define VOL7D_SORT
5933#undef VOL7D_NO_ZERO_ALLOC
5934#undef VOL7D_POLY_TYPE
5935#define VOL7D_POLY_TYPE datetime
5936#include "vol7d_class_desc_templ.F90"
5937#undef VOL7D_POLY_TYPE
5938#define VOL7D_POLY_TYPE vol7d_timerange
5939#include "vol7d_class_desc_templ.F90"
5940#undef VOL7D_POLY_TYPE
5941#define VOL7D_POLY_TYPE vol7d_level
5942#include "vol7d_class_desc_templ.F90"
5943#undef VOL7D_SORT
5944#undef VOL7D_POLY_TYPE
5945#define VOL7D_POLY_TYPE vol7d_network
5946#include "vol7d_class_desc_templ.F90"
5947#undef VOL7D_POLY_TYPE
5948#define VOL7D_POLY_TYPE vol7d_ana
5949#include "vol7d_class_desc_templ.F90"
5950#define VOL7D_NO_ZERO_ALLOC
5951#undef VOL7D_POLY_TYPE
5952#define VOL7D_POLY_TYPE vol7d_var
5953#include "vol7d_class_desc_templ.F90"
5954
5964subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
5965
5966TYPE(vol7d),INTENT(IN) :: this
5967integer,optional,intent(inout) :: unit
5968character(len=*),intent(in),optional :: filename
5969character(len=*),intent(out),optional :: filename_auto
5970character(len=*),INTENT(IN),optional :: description
5971
5972integer :: lunit
5973character(len=254) :: ldescription,arg,lfilename
5974integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
5975 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
5976 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
5977 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
5978 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
5979 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
5980 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
5981!integer :: im,id,iy
5982integer :: tarray(8)
5983logical :: opened,exist
5984
5985 nana=0
5986 ntime=0
5987 ntimerange=0
5988 nlevel=0
5989 nnetwork=0
5990 ndativarr=0
5991 ndativari=0
5992 ndativarb=0
5993 ndativard=0
5994 ndativarc=0
5995 ndatiattrr=0
5996 ndatiattri=0
5997 ndatiattrb=0
5998 ndatiattrd=0
5999 ndatiattrc=0
6000 ndativarattrr=0
6001 ndativarattri=0
6002 ndativarattrb=0
6003 ndativarattrd=0
6004 ndativarattrc=0
6005 nanavarr=0
6006 nanavari=0
6007 nanavarb=0
6008 nanavard=0
6009 nanavarc=0
6010 nanaattrr=0
6011 nanaattri=0
6012 nanaattrb=0
6013 nanaattrd=0
6014 nanaattrc=0
6015 nanavarattrr=0
6016 nanavarattri=0
6017 nanavarattrb=0
6018 nanavarattrd=0
6019 nanavarattrc=0
6020
6021
6022!call idate(im,id,iy)
6023call date_and_time(values=tarray)
6024call getarg(0,arg)
6025
6026if (present(description))then
6027 ldescription=description
6028else
6029 ldescription="Vol7d generated by: "//trim(arg)
6030end if
6031
6032if (.not. present(unit))then
6033 lunit=getunit()
6034else
6035 if (unit==0)then
6036 lunit=getunit()
6037 unit=lunit
6038 else
6039 lunit=unit
6040 end if
6041end if
6042
6043lfilename=trim(arg)//".v7d"
6045
6046if (present(filename))then
6047 if (filename /= "")then
6048 lfilename=filename
6049 end if
6050end if
6051
6052if (present(filename_auto))filename_auto=lfilename
6053
6054
6055inquire(unit=lunit,opened=opened)
6056if (.not. opened) then
6057! inquire(file=lfilename, EXIST=exist)
6058! IF (exist) THEN
6059! CALL l4f_log(L4F_FATAL, &
6060! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6061! CALL raise_fatal_error()
6062! ENDIF
6063 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6064 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6065end if
6066
6067if (associated(this%ana)) nana=size(this%ana)
6068if (associated(this%time)) ntime=size(this%time)
6069if (associated(this%timerange)) ntimerange=size(this%timerange)
6070if (associated(this%level)) nlevel=size(this%level)
6071if (associated(this%network)) nnetwork=size(this%network)
6072
6073if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6074if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6075if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6076if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6077if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6078
6079if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6080if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6081if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6082if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6083if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6084
6085if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6086if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6087if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6088if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6089if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6090
6091if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6092if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6093if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6094if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6095if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6096
6097if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6098if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6099if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6100if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6101if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6102
6103if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6104if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6105if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6106if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6107if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6108
6109write(unit=lunit)ldescription
6110write(unit=lunit)tarray
6111
6112write(unit=lunit)&
6113 nana, ntime, ntimerange, nlevel, nnetwork, &
6114 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6115 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6116 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6117 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6118 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6119 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6120 this%time_definition
6121
6122
6123!write(unit=lunit)this
6124
6125
6126!! prime 5 dimensioni
6129if (associated(this%level)) write(unit=lunit)this%level
6130if (associated(this%timerange)) write(unit=lunit)this%timerange
6131if (associated(this%network)) write(unit=lunit)this%network
6132
6133 !! 6a dimensione: variabile dell'anagrafica e dei dati
6134 !! con relativi attributi e in 5 tipi diversi
6135
6136if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6137if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6138if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6139if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6140if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6141
6142if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6143if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6144if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6145if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6146if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6147
6148if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6149if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6150if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6151if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6152if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6153
6154if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6155if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6156if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6157if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6158if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6159
6160if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6161if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6162if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6163if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6164if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6165
6166if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6167if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6168if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6169if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6170if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6171
6172!! Volumi di valori e attributi per anagrafica e dati
6173
6174if (associated(this%volanar)) write(unit=lunit)this%volanar
6175if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6176if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6177if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6178
6179if (associated(this%volanai)) write(unit=lunit)this%volanai
6180if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6181if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6182if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6183
6184if (associated(this%volanab)) write(unit=lunit)this%volanab
6185if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6186if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6187if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6188
6189if (associated(this%volanad)) write(unit=lunit)this%volanad
6190if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6191if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6192if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6193
6194if (associated(this%volanac)) write(unit=lunit)this%volanac
6195if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6196if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6197if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6198
6199if (.not. present(unit)) close(unit=lunit)
6200
6201end subroutine vol7d_write_on_file
6202
6203
6210
6211
6212subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6213
6214TYPE(vol7d),INTENT(OUT) :: this
6215integer,intent(inout),optional :: unit
6216character(len=*),INTENT(in),optional :: filename
6217character(len=*),intent(out),optional :: filename_auto
6218character(len=*),INTENT(out),optional :: description
6219integer,intent(out),optional :: tarray(8)
6220
6221
6222integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6223 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6224 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6225 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6226 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6227 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6228 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6229
6230character(len=254) :: ldescription,lfilename,arg
6231integer :: ltarray(8),lunit,ios
6232logical :: opened,exist
6233
6234
6235call getarg(0,arg)
6236
6237if (.not. present(unit))then
6238 lunit=getunit()
6239else
6240 if (unit==0)then
6241 lunit=getunit()
6242 unit=lunit
6243 else
6244 lunit=unit
6245 end if
6246end if
6247
6248lfilename=trim(arg)//".v7d"
6250
6251if (present(filename))then
6252 if (filename /= "")then
6253 lfilename=filename
6254 end if
6255end if
6256
6257if (present(filename_auto))filename_auto=lfilename
6258
6259
6260inquire(unit=lunit,opened=opened)
6261IF (.NOT. opened) THEN
6262 inquire(file=lfilename,exist=exist)
6263 IF (.NOT.exist) THEN
6264 CALL l4f_log(l4f_fatal, &
6265 'in vol7d_read_from_file, file does not exists, cannot open')
6266 CALL raise_fatal_error()
6267 ENDIF
6268 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6269 status='OLD', action='READ')
6270 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6271end if
6272
6273
6275read(unit=lunit,iostat=ios)ldescription
6276
6277if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6278 call vol7d_alloc (this)
6279 call vol7d_alloc_vol (this)
6280 if (present(description))description=ldescription
6281 if (present(tarray))tarray=ltarray
6282 if (.not. present(unit)) close(unit=lunit)
6283end if
6284
6285read(unit=lunit)ltarray
6286
6287CALL l4f_log(l4f_info, 'Reading vol7d from file')
6288CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6291
6292if (present(description))description=ldescription
6293if (present(tarray))tarray=ltarray
6294
6295read(unit=lunit)&
6296 nana, ntime, ntimerange, nlevel, nnetwork, &
6297 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6298 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6299 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6300 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6301 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6302 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6303 this%time_definition
6304
6305call vol7d_alloc (this, &
6306 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6307 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6308 ndativard=ndativard, ndativarc=ndativarc,&
6309 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6310 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6311 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6312 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6313 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6314 nanavard=nanavard, nanavarc=nanavarc,&
6315 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6316 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6317 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
6318 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
6319
6320
6323if (associated(this%level)) read(unit=lunit)this%level
6324if (associated(this%timerange)) read(unit=lunit)this%timerange
6325if (associated(this%network)) read(unit=lunit)this%network
6326
6327if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
6328if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
6329if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
6330if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
6331if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
6332
6333if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
6334if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
6335if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
6336if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
6337if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
6338
6339if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
6340if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
6341if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
6342if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
6343if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
6344
6345if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
6346if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
6347if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
6348if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
6349if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
6350
6351if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
6352if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
6353if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
6354if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
6355if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
6356
6357if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
6358if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
6359if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
6360if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
6361if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
6362
6363call vol7d_alloc_vol (this)
6364
6365!! Volumi di valori e attributi per anagrafica e dati
6366
6367if (associated(this%volanar)) read(unit=lunit)this%volanar
6368if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
6369if (associated(this%voldatir)) read(unit=lunit)this%voldatir
6370if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
6371
6372if (associated(this%volanai)) read(unit=lunit)this%volanai
6373if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
6374if (associated(this%voldatii)) read(unit=lunit)this%voldatii
6375if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
6376
6377if (associated(this%volanab)) read(unit=lunit)this%volanab
6378if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
6379if (associated(this%voldatib)) read(unit=lunit)this%voldatib
6380if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
6381
6382if (associated(this%volanad)) read(unit=lunit)this%volanad
6383if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
6384if (associated(this%voldatid)) read(unit=lunit)this%voldatid
6385if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
6386
6387if (associated(this%volanac)) read(unit=lunit)this%volanac
6388if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
6389if (associated(this%voldatic)) read(unit=lunit)this%voldatic
6390if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
6391
6392if (.not. present(unit)) close(unit=lunit)
6393
6394end subroutine vol7d_read_from_file
6395
6396
6397! to double precision
6398elemental doubleprecision function doubledatd(voldat,var)
6399doubleprecision,intent(in) :: voldat
6400type(vol7d_var),intent(in) :: var
6401
6402doubledatd=voldat
6403
6404end function doubledatd
6405
6406
6407elemental doubleprecision function doubledatr(voldat,var)
6408real,intent(in) :: voldat
6409type(vol7d_var),intent(in) :: var
6410
6412 doubledatr=dble(voldat)
6413else
6414 doubledatr=dmiss
6415end if
6416
6417end function doubledatr
6418
6419
6420elemental doubleprecision function doubledati(voldat,var)
6421integer,intent(in) :: voldat
6422type(vol7d_var),intent(in) :: var
6423
6426 doubledati=dble(voldat)/10.d0**var%scalefactor
6427 else
6428 doubledati=dble(voldat)
6429 endif
6430else
6431 doubledati=dmiss
6432end if
6433
6434end function doubledati
6435
6436
6437elemental doubleprecision function doubledatb(voldat,var)
6438integer(kind=int_b),intent(in) :: voldat
6439type(vol7d_var),intent(in) :: var
6440
6443 doubledatb=dble(voldat)/10.d0**var%scalefactor
6444 else
6445 doubledatb=dble(voldat)
6446 endif
6447else
6448 doubledatb=dmiss
6449end if
6450
6451end function doubledatb
6452
6453
6454elemental doubleprecision function doubledatc(voldat,var)
6455CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6456type(vol7d_var),intent(in) :: var
6457
6458doubledatc = c2d(voldat)
6460 doubledatc=doubledatc/10.d0**var%scalefactor
6461end if
6462
6463end function doubledatc
6464
6465
6466! to integer
6467elemental integer function integerdatd(voldat,var)
6468doubleprecision,intent(in) :: voldat
6469type(vol7d_var),intent(in) :: var
6470
6473 integerdatd=nint(voldat*10d0**var%scalefactor)
6474 else
6475 integerdatd=nint(voldat)
6476 endif
6477else
6478 integerdatd=imiss
6479end if
6480
6481end function integerdatd
6482
6483
6484elemental integer function integerdatr(voldat,var)
6485real,intent(in) :: voldat
6486type(vol7d_var),intent(in) :: var
6487
6490 integerdatr=nint(voldat*10d0**var%scalefactor)
6491 else
6492 integerdatr=nint(voldat)
6493 endif
6494else
6495 integerdatr=imiss
6496end if
6497
6498end function integerdatr
6499
6500
6501elemental integer function integerdati(voldat,var)
6502integer,intent(in) :: voldat
6503type(vol7d_var),intent(in) :: var
6504
6505integerdati=voldat
6506
6507end function integerdati
6508
6509
6510elemental integer function integerdatb(voldat,var)
6511integer(kind=int_b),intent(in) :: voldat
6512type(vol7d_var),intent(in) :: var
6513
6515 integerdatb=voldat
6516else
6517 integerdatb=imiss
6518end if
6519
6520end function integerdatb
6521
6522
6523elemental integer function integerdatc(voldat,var)
6524CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6525type(vol7d_var),intent(in) :: var
6526
6527integerdatc=c2i(voldat)
6528
6529end function integerdatc
6530
6531
6532! to real
6533elemental real function realdatd(voldat,var)
6534doubleprecision,intent(in) :: voldat
6535type(vol7d_var),intent(in) :: var
6536
6538 realdatd=real(voldat)
6539else
6540 realdatd=rmiss
6541end if
6542
6543end function realdatd
6544
6545
6546elemental real function realdatr(voldat,var)
6547real,intent(in) :: voldat
6548type(vol7d_var),intent(in) :: var
6549
6550realdatr=voldat
6551
6552end function realdatr
6553
6554
6555elemental real function realdati(voldat,var)
6556integer,intent(in) :: voldat
6557type(vol7d_var),intent(in) :: var
6558
6561 realdati=float(voldat)/10.**var%scalefactor
6562 else
6563 realdati=float(voldat)
6564 endif
6565else
6566 realdati=rmiss
6567end if
6568
6569end function realdati
6570
6571
6572elemental real function realdatb(voldat,var)
6573integer(kind=int_b),intent(in) :: voldat
6574type(vol7d_var),intent(in) :: var
6575
6578 realdatb=float(voldat)/10**var%scalefactor
6579 else
6580 realdatb=float(voldat)
6581 endif
6582else
6583 realdatb=rmiss
6584end if
6585
6586end function realdatb
6587
6588
6589elemental real function realdatc(voldat,var)
6590CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6591type(vol7d_var),intent(in) :: var
6592
6593realdatc=c2r(voldat)
6595 realdatc=realdatc/10.**var%scalefactor
6596end if
6597
6598end function realdatc
6599
6600
6606FUNCTION realanavol(this, var) RESULT(vol)
6607TYPE(vol7d),INTENT(in) :: this
6608TYPE(vol7d_var),INTENT(in) :: var
6609REAL :: vol(SIZE(this%ana),size(this%network))
6610
6611CHARACTER(len=1) :: dtype
6612INTEGER :: indvar
6613
6614dtype = cmiss
6615indvar = index(this%anavar, var, type=dtype)
6616
6617IF (indvar > 0) THEN
6618 SELECT CASE (dtype)
6619 CASE("d")
6620 vol = realdat(this%volanad(:,indvar,:), var)
6621 CASE("r")
6622 vol = this%volanar(:,indvar,:)
6623 CASE("i")
6624 vol = realdat(this%volanai(:,indvar,:), var)
6625 CASE("b")
6626 vol = realdat(this%volanab(:,indvar,:), var)
6627 CASE("c")
6628 vol = realdat(this%volanac(:,indvar,:), var)
6629 CASE default
6630 vol = rmiss
6631 END SELECT
6632ELSE
6633 vol = rmiss
6634ENDIF
6635
6636END FUNCTION realanavol
6637
6638
6644FUNCTION integeranavol(this, var) RESULT(vol)
6645TYPE(vol7d),INTENT(in) :: this
6646TYPE(vol7d_var),INTENT(in) :: var
6647INTEGER :: vol(SIZE(this%ana),size(this%network))
6648
6649CHARACTER(len=1) :: dtype
6650INTEGER :: indvar
6651
6652dtype = cmiss
6653indvar = index(this%anavar, var, type=dtype)
6654
6655IF (indvar > 0) THEN
6656 SELECT CASE (dtype)
6657 CASE("d")
6658 vol = integerdat(this%volanad(:,indvar,:), var)
6659 CASE("r")
6660 vol = integerdat(this%volanar(:,indvar,:), var)
6661 CASE("i")
6662 vol = this%volanai(:,indvar,:)
6663 CASE("b")
6664 vol = integerdat(this%volanab(:,indvar,:), var)
6665 CASE("c")
6666 vol = integerdat(this%volanac(:,indvar,:), var)
6667 CASE default
6668 vol = imiss
6669 END SELECT
6670ELSE
6671 vol = imiss
6672ENDIF
6673
6674END FUNCTION integeranavol
6675
6676
6682subroutine move_datac (v7d,&
6683 indana,indtime,indlevel,indtimerange,indnetwork,&
6684 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6685
6686TYPE(vol7d),intent(inout) :: v7d
6687
6688integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6689integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6690integer :: inddativar,inddativarattr
6691
6692
6693do inddativar=1,size(v7d%dativar%c)
6694
6696 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6697 ) then
6698
6699 ! dati
6700 v7d%voldatic &
6701 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6702 v7d%voldatic &
6703 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6704
6705
6706 ! attributi
6707 if (associated (v7d%dativarattr%i)) then
6708 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
6709 if (inddativarattr > 0 ) then
6710 v7d%voldatiattri &
6711 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6712 v7d%voldatiattri &
6713 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6714 end if
6715 end if
6716
6717 if (associated (v7d%dativarattr%r)) then
6718 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
6719 if (inddativarattr > 0 ) then
6720 v7d%voldatiattrr &
6721 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6722 v7d%voldatiattrr &
6723 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6724 end if
6725 end if
6726
6727 if (associated (v7d%dativarattr%d)) then
6728 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
6729 if (inddativarattr > 0 ) then
6730 v7d%voldatiattrd &
6731 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6732 v7d%voldatiattrd &
6733 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6734 end if
6735 end if
6736
6737 if (associated (v7d%dativarattr%b)) then
6738 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
6739 if (inddativarattr > 0 ) then
6740 v7d%voldatiattrb &
6741 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6742 v7d%voldatiattrb &
6743 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6744 end if
6745 end if
6746
6747 if (associated (v7d%dativarattr%c)) then
6748 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
6749 if (inddativarattr > 0 ) then
6750 v7d%voldatiattrc &
6751 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6752 v7d%voldatiattrc &
6753 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6754 end if
6755 end if
6756
6757 end if
6758
6759end do
6760
6761end subroutine move_datac
6762
6768subroutine move_datar (v7d,&
6769 indana,indtime,indlevel,indtimerange,indnetwork,&
6770 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6771
6772TYPE(vol7d),intent(inout) :: v7d
6773
6774integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6775integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6776integer :: inddativar,inddativarattr
6777
6778
6779do inddativar=1,size(v7d%dativar%r)
6780
6782 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6783 ) then
6784
6785 ! dati
6786 v7d%voldatir &
6787 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6788 v7d%voldatir &
6789 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6790
6791
6792 ! attributi
6793 if (associated (v7d%dativarattr%i)) then
6794 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
6795 if (inddativarattr > 0 ) then
6796 v7d%voldatiattri &
6797 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6798 v7d%voldatiattri &
6799 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6800 end if
6801 end if
6802
6803 if (associated (v7d%dativarattr%r)) then
6804 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
6805 if (inddativarattr > 0 ) then
6806 v7d%voldatiattrr &
6807 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6808 v7d%voldatiattrr &
6809 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6810 end if
6811 end if
6812
6813 if (associated (v7d%dativarattr%d)) then
6814 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
6815 if (inddativarattr > 0 ) then
6816 v7d%voldatiattrd &
6817 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6818 v7d%voldatiattrd &
6819 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6820 end if
6821 end if
6822
6823 if (associated (v7d%dativarattr%b)) then
6824 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
6825 if (inddativarattr > 0 ) then
6826 v7d%voldatiattrb &
6827 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6828 v7d%voldatiattrb &
6829 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6830 end if
6831 end if
6832
6833 if (associated (v7d%dativarattr%c)) then
6834 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
6835 if (inddativarattr > 0 ) then
6836 v7d%voldatiattrc &
6837 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6838 v7d%voldatiattrc &
6839 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6840 end if
6841 end if
6842
6843 end if
6844
6845end do
6846
6847end subroutine move_datar
6848
6849
6863subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
6864type(vol7d),intent(inout) :: v7din
6865type(vol7d),intent(out) :: v7dout
6866type(vol7d_level),intent(in),optional :: level(:)
6867type(vol7d_timerange),intent(in),optional :: timerange(:)
6868!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
6869!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
6870logical,intent(in),optional :: nostatproc
6871
6872integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
6873integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
6874type(vol7d_level) :: roundlevel(size(v7din%level))
6875type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
6876type(vol7d) :: v7d_tmp
6877
6878
6879nbin=0
6880
6881if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
6882if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
6883if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
6884if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
6885
6887
6888roundlevel=v7din%level
6889
6890if (present(level))then
6891 do ilevel = 1, size(v7din%level)
6892 if ((any(v7din%level(ilevel) .almosteq. level))) then
6893 roundlevel(ilevel)=level(1)
6894 end if
6895 end do
6896end if
6897
6898roundtimerange=v7din%timerange
6899
6900if (present(timerange))then
6901 do itimerange = 1, size(v7din%timerange)
6902 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
6903 roundtimerange(itimerange)=timerange(1)
6904 end if
6905 end do
6906end if
6907
6908!set istantaneous values everywere
6909!preserve p1 for forecast time
6910if (optio_log(nostatproc)) then
6911 roundtimerange(:)%timerange=254
6912 roundtimerange(:)%p2=0
6913end if
6914
6915
6916nana=size(v7din%ana)
6917nlevel=count_distinct(roundlevel,back=.true.)
6918ntime=size(v7din%time)
6919ntimerange=count_distinct(roundtimerange,back=.true.)
6920nnetwork=size(v7din%network)
6921
6923
6924if (nbin == 0) then
6926else
6927 call vol7d_convr(v7din,v7d_tmp)
6928end if
6929
6930v7d_tmp%level=roundlevel
6931v7d_tmp%timerange=roundtimerange
6932
6933do ilevel=1, size(v7d_tmp%level)
6934 indl=index(v7d_tmp%level,roundlevel(ilevel))
6935 do itimerange=1,size(v7d_tmp%timerange)
6936 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
6937
6938 if (indl /= ilevel .or. indt /= itimerange) then
6939
6940 do iana=1, nana
6941 do itime=1,ntime
6942 do inetwork=1,nnetwork
6943
6944 if (nbin > 0) then
6945 call move_datar (v7d_tmp,&
6946 iana,itime,ilevel,itimerange,inetwork,&
6947 iana,itime,indl,indt,inetwork)
6948 else
6949 call move_datac (v7d_tmp,&
6950 iana,itime,ilevel,itimerange,inetwork,&
6951 iana,itime,indl,indt,inetwork)
6952 end if
6953
6954 end do
6955 end do
6956 end do
6957
6958 end if
6959
6960 end do
6961end do
6962
6963! set to missing level and time > nlevel
6964do ilevel=nlevel+1,size(v7d_tmp%level)
6966end do
6967
6968do itimerange=ntimerange+1,size(v7d_tmp%timerange)
6970end do
6971
6972!copy with remove
6975
6976!call display(v7dout)
6977
6978end subroutine v7d_rounding
6979
6980
6982
6988
6989
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 |