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