libsim Versione 7.2.1
|
◆ vol7d_get_volanaattrr()
Crea una vista a dimensione ridotta di un volume di attributi di anagrafica di tipo REAL. È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio: REAL, POINTER :: vol1d(:)
...
CALL vol7d_get_volanaattrr(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 3592 del file vol7d_class.F90. 3594! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3595! authors:
3596! Davide Cesari <dcesari@arpa.emr.it>
3597! Paolo Patruno <ppatruno@arpa.emr.it>
3598
3599! This program is free software; you can redistribute it and/or
3600! modify it under the terms of the GNU General Public License as
3601! published by the Free Software Foundation; either version 2 of
3602! the License, or (at your option) any later version.
3603
3604! This program is distributed in the hope that it will be useful,
3605! but WITHOUT ANY WARRANTY; without even the implied warranty of
3606! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3607! GNU General Public License for more details.
3608
3609! You should have received a copy of the GNU General Public License
3610! along with this program. If not, see <http://www.gnu.org/licenses/>.
3611#include "config.h"
3612
3624
3692IMPLICIT NONE
3693
3694
3695INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
3696 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
3697
3698INTEGER, PARAMETER :: vol7d_ana_a=1
3699INTEGER, PARAMETER :: vol7d_var_a=2
3700INTEGER, PARAMETER :: vol7d_network_a=3
3701INTEGER, PARAMETER :: vol7d_attr_a=4
3702INTEGER, PARAMETER :: vol7d_ana_d=1
3703INTEGER, PARAMETER :: vol7d_time_d=2
3704INTEGER, PARAMETER :: vol7d_level_d=3
3705INTEGER, PARAMETER :: vol7d_timerange_d=4
3706INTEGER, PARAMETER :: vol7d_var_d=5
3707INTEGER, PARAMETER :: vol7d_network_d=6
3708INTEGER, PARAMETER :: vol7d_attr_d=7
3709INTEGER, PARAMETER :: vol7d_cdatalen=32
3710
3711TYPE vol7d_varmap
3712 INTEGER :: r, d, i, b, c
3713END TYPE vol7d_varmap
3714
3719 TYPE(vol7d_ana),POINTER :: ana(:)
3721 TYPE(datetime),POINTER :: time(:)
3723 TYPE(vol7d_level),POINTER :: level(:)
3725 TYPE(vol7d_timerange),POINTER :: timerange(:)
3727 TYPE(vol7d_network),POINTER :: network(:)
3729 TYPE(vol7d_varvect) :: anavar
3731 TYPE(vol7d_varvect) :: anaattr
3733 TYPE(vol7d_varvect) :: anavarattr
3735 TYPE(vol7d_varvect) :: dativar
3737 TYPE(vol7d_varvect) :: datiattr
3739 TYPE(vol7d_varvect) :: dativarattr
3740
3742 REAL,POINTER :: volanar(:,:,:)
3744 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
3746 INTEGER,POINTER :: volanai(:,:,:)
3748 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
3750 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
3751
3753 REAL,POINTER :: volanaattrr(:,:,:,:)
3755 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
3757 INTEGER,POINTER :: volanaattri(:,:,:,:)
3759 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
3761 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
3762
3764 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
3766 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
3768 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
3770 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
3772 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
3773
3775 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
3777 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
3779 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
3781 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
3783 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
3784
3786 integer :: time_definition
3787
3789
3794 MODULE PROCEDURE vol7d_init
3795END INTERFACE
3796
3799 MODULE PROCEDURE vol7d_delete
3800END INTERFACE
3801
3804 MODULE PROCEDURE vol7d_write_on_file
3805END INTERFACE
3806
3808INTERFACE import
3809 MODULE PROCEDURE vol7d_read_from_file
3810END INTERFACE
3811
3814 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
3815END INTERFACE
3816
3819 MODULE PROCEDURE to_char_dat
3820END INTERFACE
3821
3824 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3825END INTERFACE
3826
3829 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
3830END INTERFACE
3831
3834 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
3835END INTERFACE
3836
3839 MODULE PROCEDURE vol7d_copy
3840END INTERFACE
3841
3844 MODULE PROCEDURE vol7d_c_e
3845END INTERFACE
3846
3851 MODULE PROCEDURE vol7d_check
3852END INTERFACE
3853
3868 MODULE PROCEDURE v7d_rounding
3869END INTERFACE
3870
3871!!$INTERFACE get_volana
3872!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
3873!!$ vol7d_get_volanab, vol7d_get_volanac
3874!!$END INTERFACE
3875!!$
3876!!$INTERFACE get_voldati
3877!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
3878!!$ vol7d_get_voldatib, vol7d_get_voldatic
3879!!$END INTERFACE
3880!!$
3881!!$INTERFACE get_volanaattr
3882!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
3883!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
3884!!$END INTERFACE
3885!!$
3886!!$INTERFACE get_voldatiattr
3887!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
3888!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
3889!!$END INTERFACE
3890
3891PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
3892 vol7d_get_volc, &
3893 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
3894 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
3895 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
3896 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
3897 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
3898 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
3899 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
3900 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
3901 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
3902 vol7d_display, dat_display, dat_vect_display, &
3903 to_char_dat, vol7d_check
3904
3905PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3906
3907PRIVATE vol7d_c_e
3908
3909CONTAINS
3910
3911
3916SUBROUTINE vol7d_init(this,time_definition)
3917TYPE(vol7d),intent(out) :: this
3918integer,INTENT(IN),OPTIONAL :: time_definition
3919
3926CALL vol7d_var_features_init() ! initialise var features table once
3927
3928NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
3929
3930NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
3931NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
3932NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
3933NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
3934NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
3935
3936if(present(time_definition)) then
3937 this%time_definition=time_definition
3938else
3939 this%time_definition=1 !default to validity time
3940end if
3941
3942END SUBROUTINE vol7d_init
3943
3944
3948ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
3949TYPE(vol7d),intent(inout) :: this
3950LOGICAL, INTENT(in), OPTIONAL :: dataonly
3951
3952
3953IF (.NOT. optio_log(dataonly)) THEN
3954 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
3955 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
3956 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
3957 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
3958 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
3959 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
3960 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
3961 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
3962 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
3963 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
3964ENDIF
3965IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
3966IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
3967IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
3968IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
3969IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
3970IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
3971IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
3972IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
3973IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
3974IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
3975
3976IF (.NOT. optio_log(dataonly)) THEN
3977 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
3978 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
3979ENDIF
3980IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
3981IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
3982IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
3983
3984IF (.NOT. optio_log(dataonly)) THEN
3988ENDIF
3992
3993END SUBROUTINE vol7d_delete
3994
3995
3996
3997integer function vol7d_check(this)
3998TYPE(vol7d),intent(in) :: this
3999integer :: i,j,k,l,m,n
4000
4001vol7d_check=0
4002
4003if (associated(this%voldatii)) then
4004do i = 1,size(this%voldatii,1)
4005 do j = 1,size(this%voldatii,2)
4006 do k = 1,size(this%voldatii,3)
4007 do l = 1,size(this%voldatii,4)
4008 do m = 1,size(this%voldatii,5)
4009 do n = 1,size(this%voldatii,6)
4010 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4011 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4013 vol7d_check=1
4014 end if
4015 end do
4016 end do
4017 end do
4018 end do
4019 end do
4020end do
4021end if
4022
4023
4024if (associated(this%voldatir)) then
4025do i = 1,size(this%voldatir,1)
4026 do j = 1,size(this%voldatir,2)
4027 do k = 1,size(this%voldatir,3)
4028 do l = 1,size(this%voldatir,4)
4029 do m = 1,size(this%voldatir,5)
4030 do n = 1,size(this%voldatir,6)
4031 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4032 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4034 vol7d_check=2
4035 end if
4036 end do
4037 end do
4038 end do
4039 end do
4040 end do
4041end do
4042end if
4043
4044if (associated(this%voldatid)) then
4045do i = 1,size(this%voldatid,1)
4046 do j = 1,size(this%voldatid,2)
4047 do k = 1,size(this%voldatid,3)
4048 do l = 1,size(this%voldatid,4)
4049 do m = 1,size(this%voldatid,5)
4050 do n = 1,size(this%voldatid,6)
4051 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4052 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4054 vol7d_check=3
4055 end if
4056 end do
4057 end do
4058 end do
4059 end do
4060 end do
4061end do
4062end if
4063
4064if (associated(this%voldatib)) then
4065do i = 1,size(this%voldatib,1)
4066 do j = 1,size(this%voldatib,2)
4067 do k = 1,size(this%voldatib,3)
4068 do l = 1,size(this%voldatib,4)
4069 do m = 1,size(this%voldatib,5)
4070 do n = 1,size(this%voldatib,6)
4071 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4072 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4074 vol7d_check=4
4075 end if
4076 end do
4077 end do
4078 end do
4079 end do
4080 end do
4081end do
4082end if
4083
4084end function vol7d_check
4085
4086
4087
4088!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4090SUBROUTINE vol7d_display(this)
4091TYPE(vol7d),intent(in) :: this
4092integer :: i
4093
4094REAL :: rdat
4095DOUBLE PRECISION :: ddat
4096INTEGER :: idat
4097INTEGER(kind=int_b) :: bdat
4098CHARACTER(len=vol7d_cdatalen) :: cdat
4099
4100
4101print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4102if (this%time_definition == 0) then
4103 print*,"TIME DEFINITION: time is reference time"
4104else if (this%time_definition == 1) then
4105 print*,"TIME DEFINITION: time is validity time"
4106else
4107 print*,"Time definition have a wrong walue:", this%time_definition
4108end if
4109
4110IF (ASSOCIATED(this%network))then
4111 print*,"---- network vector ----"
4112 print*,"elements=",size(this%network)
4113 do i=1, size(this%network)
4115 end do
4116end IF
4117
4118IF (ASSOCIATED(this%ana))then
4119 print*,"---- ana vector ----"
4120 print*,"elements=",size(this%ana)
4121 do i=1, size(this%ana)
4123 end do
4124end IF
4125
4126IF (ASSOCIATED(this%time))then
4127 print*,"---- time vector ----"
4128 print*,"elements=",size(this%time)
4129 do i=1, size(this%time)
4131 end do
4132end if
4133
4134IF (ASSOCIATED(this%level)) then
4135 print*,"---- level vector ----"
4136 print*,"elements=",size(this%level)
4137 do i =1,size(this%level)
4139 end do
4140end if
4141
4142IF (ASSOCIATED(this%timerange))then
4143 print*,"---- timerange vector ----"
4144 print*,"elements=",size(this%timerange)
4145 do i =1,size(this%timerange)
4147 end do
4148end if
4149
4150
4151print*,"---- ana vector ----"
4152print*,""
4153print*,"->>>>>>>>> anavar -"
4155print*,""
4156print*,"->>>>>>>>> anaattr -"
4158print*,""
4159print*,"->>>>>>>>> anavarattr -"
4161
4162print*,"-- ana data section (first point) --"
4163
4164idat=imiss
4165rdat=rmiss
4166ddat=dmiss
4167bdat=ibmiss
4168cdat=cmiss
4169
4170!ntime = MIN(SIZE(this%time),nprint)
4171!ntimerange = MIN(SIZE(this%timerange),nprint)
4172!nlevel = MIN(SIZE(this%level),nprint)
4173!nnetwork = MIN(SIZE(this%network),nprint)
4174!nana = MIN(SIZE(this%ana),nprint)
4175
4176IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4177if (associated(this%volanai)) then
4178 do i=1,size(this%anavar%i)
4179 idat=this%volanai(1,i,1)
4181 end do
4182end if
4183idat=imiss
4184
4185if (associated(this%volanar)) then
4186 do i=1,size(this%anavar%r)
4187 rdat=this%volanar(1,i,1)
4189 end do
4190end if
4191rdat=rmiss
4192
4193if (associated(this%volanad)) then
4194 do i=1,size(this%anavar%d)
4195 ddat=this%volanad(1,i,1)
4197 end do
4198end if
4199ddat=dmiss
4200
4201if (associated(this%volanab)) then
4202 do i=1,size(this%anavar%b)
4203 bdat=this%volanab(1,i,1)
4205 end do
4206end if
4207bdat=ibmiss
4208
4209if (associated(this%volanac)) then
4210 do i=1,size(this%anavar%c)
4211 cdat=this%volanac(1,i,1)
4213 end do
4214end if
4215cdat=cmiss
4216ENDIF
4217
4218print*,"---- data vector ----"
4219print*,""
4220print*,"->>>>>>>>> dativar -"
4222print*,""
4223print*,"->>>>>>>>> datiattr -"
4225print*,""
4226print*,"->>>>>>>>> dativarattr -"
4228
4229print*,"-- data data section (first point) --"
4230
4231idat=imiss
4232rdat=rmiss
4233ddat=dmiss
4234bdat=ibmiss
4235cdat=cmiss
4236
4237IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4238 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4239if (associated(this%voldatii)) then
4240 do i=1,size(this%dativar%i)
4241 idat=this%voldatii(1,1,1,1,i,1)
4243 end do
4244end if
4245idat=imiss
4246
4247if (associated(this%voldatir)) then
4248 do i=1,size(this%dativar%r)
4249 rdat=this%voldatir(1,1,1,1,i,1)
4251 end do
4252end if
4253rdat=rmiss
4254
4255if (associated(this%voldatid)) then
4256 do i=1,size(this%dativar%d)
4257 ddat=this%voldatid(1,1,1,1,i,1)
4259 end do
4260end if
4261ddat=dmiss
4262
4263if (associated(this%voldatib)) then
4264 do i=1,size(this%dativar%b)
4265 bdat=this%voldatib(1,1,1,1,i,1)
4267 end do
4268end if
4269bdat=ibmiss
4270
4271if (associated(this%voldatic)) then
4272 do i=1,size(this%dativar%c)
4273 cdat=this%voldatic(1,1,1,1,i,1)
4275 end do
4276end if
4277cdat=cmiss
4278ENDIF
4279
4280print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4281
4282END SUBROUTINE vol7d_display
4283
4284
4286SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4287TYPE(vol7d_var),intent(in) :: this
4289REAL :: rdat
4291DOUBLE PRECISION :: ddat
4293INTEGER :: idat
4295INTEGER(kind=int_b) :: bdat
4297CHARACTER(len=*) :: cdat
4298
4299print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4300
4301end SUBROUTINE dat_display
4302
4304SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4305
4306TYPE(vol7d_var),intent(in) :: this(:)
4308REAL :: rdat(:)
4310DOUBLE PRECISION :: ddat(:)
4312INTEGER :: idat(:)
4314INTEGER(kind=int_b) :: bdat(:)
4316CHARACTER(len=*):: cdat(:)
4317
4318integer :: i
4319
4320do i =1,size(this)
4322end do
4323
4324end SUBROUTINE dat_vect_display
4325
4326
4327FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4328#ifdef HAVE_DBALLE
4329USE dballef
4330#endif
4331TYPE(vol7d_var),INTENT(in) :: this
4333REAL :: rdat
4335DOUBLE PRECISION :: ddat
4337INTEGER :: idat
4339INTEGER(kind=int_b) :: bdat
4341CHARACTER(len=*) :: cdat
4342CHARACTER(len=80) :: to_char_dat
4343
4344CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4345
4346
4347#ifdef HAVE_DBALLE
4348INTEGER :: handle, ier
4349
4350handle = 0
4351to_char_dat="VALUE: "
4352
4357
4359 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4360 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4361 ier = idba_fatto(handle)
4362 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4363endif
4364
4365#else
4366
4367to_char_dat="VALUE: "
4373
4374#endif
4375
4376END FUNCTION to_char_dat
4377
4378
4381FUNCTION vol7d_c_e(this) RESULT(c_e)
4382TYPE(vol7d), INTENT(in) :: this
4383
4384LOGICAL :: c_e
4385
4387 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
4388 ASSOCIATED(this%network) .OR. &
4389 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4390 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4391 ASSOCIATED(this%anavar%c) .OR. &
4392 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
4393 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
4394 ASSOCIATED(this%anaattr%c) .OR. &
4395 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4396 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4397 ASSOCIATED(this%dativar%c) .OR. &
4398 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
4399 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
4400 ASSOCIATED(this%datiattr%c)
4401
4402END FUNCTION vol7d_c_e
4403
4404
4443SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
4444 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4445 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4446 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4447 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4448 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4449 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
4450 ini)
4451TYPE(vol7d),INTENT(inout) :: this
4452INTEGER,INTENT(in),OPTIONAL :: nana
4453INTEGER,INTENT(in),OPTIONAL :: ntime
4454INTEGER,INTENT(in),OPTIONAL :: nlevel
4455INTEGER,INTENT(in),OPTIONAL :: ntimerange
4456INTEGER,INTENT(in),OPTIONAL :: nnetwork
4458INTEGER,INTENT(in),OPTIONAL :: &
4459 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4460 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4461 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4462 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4463 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4464 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
4465LOGICAL,INTENT(in),OPTIONAL :: ini
4466
4467INTEGER :: i
4468LOGICAL :: linit
4469
4470IF (PRESENT(ini)) THEN
4471 linit = ini
4472ELSE
4473 linit = .false.
4474ENDIF
4475
4476! Dimensioni principali
4477IF (PRESENT(nana)) THEN
4478 IF (nana >= 0) THEN
4479 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4480 ALLOCATE(this%ana(nana))
4481 IF (linit) THEN
4482 DO i = 1, nana
4484 ENDDO
4485 ENDIF
4486 ENDIF
4487ENDIF
4488IF (PRESENT(ntime)) THEN
4489 IF (ntime >= 0) THEN
4490 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4491 ALLOCATE(this%time(ntime))
4492 IF (linit) THEN
4493 DO i = 1, ntime
4495 ENDDO
4496 ENDIF
4497 ENDIF
4498ENDIF
4499IF (PRESENT(nlevel)) THEN
4500 IF (nlevel >= 0) THEN
4501 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4502 ALLOCATE(this%level(nlevel))
4503 IF (linit) THEN
4504 DO i = 1, nlevel
4506 ENDDO
4507 ENDIF
4508 ENDIF
4509ENDIF
4510IF (PRESENT(ntimerange)) THEN
4511 IF (ntimerange >= 0) THEN
4512 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4513 ALLOCATE(this%timerange(ntimerange))
4514 IF (linit) THEN
4515 DO i = 1, ntimerange
4517 ENDDO
4518 ENDIF
4519 ENDIF
4520ENDIF
4521IF (PRESENT(nnetwork)) THEN
4522 IF (nnetwork >= 0) THEN
4523 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4524 ALLOCATE(this%network(nnetwork))
4525 IF (linit) THEN
4526 DO i = 1, nnetwork
4528 ENDDO
4529 ENDIF
4530 ENDIF
4531ENDIF
4532! Dimensioni dei tipi delle variabili
4533CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
4534 nanavari, nanavarb, nanavarc, ini)
4535CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
4536 nanaattri, nanaattrb, nanaattrc, ini)
4537CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
4538 nanavarattri, nanavarattrb, nanavarattrc, ini)
4539CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
4540 ndativari, ndativarb, ndativarc, ini)
4541CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
4542 ndatiattri, ndatiattrb, ndatiattrc, ini)
4543CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
4544 ndativarattri, ndativarattrb, ndativarattrc, ini)
4545
4546END SUBROUTINE vol7d_alloc
4547
4548
4549FUNCTION vol7d_check_alloc_ana(this)
4550TYPE(vol7d),INTENT(in) :: this
4551LOGICAL :: vol7d_check_alloc_ana
4552
4553vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
4554
4555END FUNCTION vol7d_check_alloc_ana
4556
4557SUBROUTINE vol7d_force_alloc_ana(this, ini)
4558TYPE(vol7d),INTENT(inout) :: this
4559LOGICAL,INTENT(in),OPTIONAL :: ini
4560
4561! Alloco i descrittori minimi per avere un volume di anagrafica
4562IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
4563IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
4564
4565END SUBROUTINE vol7d_force_alloc_ana
4566
4567
4568FUNCTION vol7d_check_alloc_dati(this)
4569TYPE(vol7d),INTENT(in) :: this
4570LOGICAL :: vol7d_check_alloc_dati
4571
4572vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
4573 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
4574 ASSOCIATED(this%timerange)
4575
4576END FUNCTION vol7d_check_alloc_dati
4577
4578SUBROUTINE vol7d_force_alloc_dati(this, ini)
4579TYPE(vol7d),INTENT(inout) :: this
4580LOGICAL,INTENT(in),OPTIONAL :: ini
4581
4582! Alloco i descrittori minimi per avere un volume di dati
4583CALL vol7d_force_alloc_ana(this, ini)
4584IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
4585IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
4586IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
4587
4588END SUBROUTINE vol7d_force_alloc_dati
4589
4590
4591SUBROUTINE vol7d_force_alloc(this)
4592TYPE(vol7d),INTENT(inout) :: this
4593
4594! If anything really not allocated yet, allocate with size 0
4595IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
4596IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
4597IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
4598IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
4599IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
4600
4601END SUBROUTINE vol7d_force_alloc
4602
4603
4604FUNCTION vol7d_check_vol(this)
4605TYPE(vol7d),INTENT(in) :: this
4606LOGICAL :: vol7d_check_vol
4607
4608vol7d_check_vol = c_e(this)
4609
4610! Anagrafica
4611IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4612 vol7d_check_vol = .false.
4613ENDIF
4614
4615IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4616 vol7d_check_vol = .false.
4617ENDIF
4618
4619IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4620 vol7d_check_vol = .false.
4621ENDIF
4622
4623IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4624 vol7d_check_vol = .false.
4625ENDIF
4626
4627IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4628 vol7d_check_vol = .false.
4629ENDIF
4630IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4631 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4632 ASSOCIATED(this%anavar%c)) THEN
4633 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
4634ENDIF
4635
4636! Attributi dell'anagrafica
4637IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4638 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4639 vol7d_check_vol = .false.
4640ENDIF
4641
4642IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4643 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4644 vol7d_check_vol = .false.
4645ENDIF
4646
4647IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4648 .NOT.ASSOCIATED(this%volanaattri)) THEN
4649 vol7d_check_vol = .false.
4650ENDIF
4651
4652IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4653 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4654 vol7d_check_vol = .false.
4655ENDIF
4656
4657IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4658 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4659 vol7d_check_vol = .false.
4660ENDIF
4661
4662! Dati
4663IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4664 vol7d_check_vol = .false.
4665ENDIF
4666
4667IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4668 vol7d_check_vol = .false.
4669ENDIF
4670
4671IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4672 vol7d_check_vol = .false.
4673ENDIF
4674
4675IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4676 vol7d_check_vol = .false.
4677ENDIF
4678
4679IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4680 vol7d_check_vol = .false.
4681ENDIF
4682
4683! Attributi dei dati
4684IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4685 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4686 vol7d_check_vol = .false.
4687ENDIF
4688
4689IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4690 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4691 vol7d_check_vol = .false.
4692ENDIF
4693
4694IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4695 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4696 vol7d_check_vol = .false.
4697ENDIF
4698
4699IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4700 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4701 vol7d_check_vol = .false.
4702ENDIF
4703
4704IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4705 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4706 vol7d_check_vol = .false.
4707ENDIF
4708IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4709 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4710 ASSOCIATED(this%dativar%c)) THEN
4711 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
4712ENDIF
4713
4714END FUNCTION vol7d_check_vol
4715
4716
4731SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
4732TYPE(vol7d),INTENT(inout) :: this
4733LOGICAL,INTENT(in),OPTIONAL :: ini
4734LOGICAL,INTENT(in),OPTIONAL :: inivol
4735
4736LOGICAL :: linivol
4737
4738IF (PRESENT(inivol)) THEN
4739 linivol = inivol
4740ELSE
4741 linivol = .true.
4742ENDIF
4743
4744! Anagrafica
4745IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4746 CALL vol7d_force_alloc_ana(this, ini)
4747 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
4748 IF (linivol) this%volanar(:,:,:) = rmiss
4749ENDIF
4750
4751IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4752 CALL vol7d_force_alloc_ana(this, ini)
4753 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
4754 IF (linivol) this%volanad(:,:,:) = rdmiss
4755ENDIF
4756
4757IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4758 CALL vol7d_force_alloc_ana(this, ini)
4759 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
4760 IF (linivol) this%volanai(:,:,:) = imiss
4761ENDIF
4762
4763IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4764 CALL vol7d_force_alloc_ana(this, ini)
4765 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
4766 IF (linivol) this%volanab(:,:,:) = ibmiss
4767ENDIF
4768
4769IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4770 CALL vol7d_force_alloc_ana(this, ini)
4771 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
4772 IF (linivol) this%volanac(:,:,:) = cmiss
4773ENDIF
4774
4775! Attributi dell'anagrafica
4776IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4777 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4778 CALL vol7d_force_alloc_ana(this, ini)
4779 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
4780 SIZE(this%network), SIZE(this%anaattr%r)))
4781 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
4782ENDIF
4783
4784IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4785 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4786 CALL vol7d_force_alloc_ana(this, ini)
4787 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
4788 SIZE(this%network), SIZE(this%anaattr%d)))
4789 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
4790ENDIF
4791
4792IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4793 .NOT.ASSOCIATED(this%volanaattri)) THEN
4794 CALL vol7d_force_alloc_ana(this, ini)
4795 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
4796 SIZE(this%network), SIZE(this%anaattr%i)))
4797 IF (linivol) this%volanaattri(:,:,:,:) = imiss
4798ENDIF
4799
4800IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4801 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4802 CALL vol7d_force_alloc_ana(this, ini)
4803 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
4804 SIZE(this%network), SIZE(this%anaattr%b)))
4805 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
4806ENDIF
4807
4808IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4809 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4810 CALL vol7d_force_alloc_ana(this, ini)
4811 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
4812 SIZE(this%network), SIZE(this%anaattr%c)))
4813 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
4814ENDIF
4815
4816! Dati
4817IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4818 CALL vol7d_force_alloc_dati(this, ini)
4819 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4820 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
4821 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
4822ENDIF
4823
4824IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4825 CALL vol7d_force_alloc_dati(this, ini)
4826 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4827 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
4828 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
4829ENDIF
4830
4831IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4832 CALL vol7d_force_alloc_dati(this, ini)
4833 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4834 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
4835 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
4836ENDIF
4837
4838IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4839 CALL vol7d_force_alloc_dati(this, ini)
4840 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4841 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
4842 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
4843ENDIF
4844
4845IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4846 CALL vol7d_force_alloc_dati(this, ini)
4847 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4848 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
4849 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
4850ENDIF
4851
4852! Attributi dei dati
4853IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4854 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4855 CALL vol7d_force_alloc_dati(this, ini)
4856 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4857 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
4858 SIZE(this%datiattr%r)))
4859 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
4860ENDIF
4861
4862IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4863 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4864 CALL vol7d_force_alloc_dati(this, ini)
4865 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4866 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
4867 SIZE(this%datiattr%d)))
4868 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
4869ENDIF
4870
4871IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4872 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4873 CALL vol7d_force_alloc_dati(this, ini)
4874 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4875 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
4876 SIZE(this%datiattr%i)))
4877 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
4878ENDIF
4879
4880IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4881 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4882 CALL vol7d_force_alloc_dati(this, ini)
4883 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4884 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
4885 SIZE(this%datiattr%b)))
4886 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
4887ENDIF
4888
4889IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4890 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4891 CALL vol7d_force_alloc_dati(this, ini)
4892 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4893 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
4894 SIZE(this%datiattr%c)))
4895 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
4896ENDIF
4897
4898! Catch-all method
4899CALL vol7d_force_alloc(this)
4900
4901! Creo gli indici var-attr
4902
4903#ifdef DEBUG
4904CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
4905#endif
4906
4907CALL vol7d_set_attr_ind(this)
4908
4909
4910
4911END SUBROUTINE vol7d_alloc_vol
4912
4913
4920SUBROUTINE vol7d_set_attr_ind(this)
4921TYPE(vol7d),INTENT(inout) :: this
4922
4923INTEGER :: i
4924
4925! real
4926IF (ASSOCIATED(this%dativar%r)) THEN
4927 IF (ASSOCIATED(this%dativarattr%r)) THEN
4928 DO i = 1, SIZE(this%dativar%r)
4929 this%dativar%r(i)%r = &
4930 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
4931 ENDDO
4932 ENDIF
4933
4934 IF (ASSOCIATED(this%dativarattr%d)) THEN
4935 DO i = 1, SIZE(this%dativar%r)
4936 this%dativar%r(i)%d = &
4937 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
4938 ENDDO
4939 ENDIF
4940
4941 IF (ASSOCIATED(this%dativarattr%i)) THEN
4942 DO i = 1, SIZE(this%dativar%r)
4943 this%dativar%r(i)%i = &
4944 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
4945 ENDDO
4946 ENDIF
4947
4948 IF (ASSOCIATED(this%dativarattr%b)) THEN
4949 DO i = 1, SIZE(this%dativar%r)
4950 this%dativar%r(i)%b = &
4951 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
4952 ENDDO
4953 ENDIF
4954
4955 IF (ASSOCIATED(this%dativarattr%c)) THEN
4956 DO i = 1, SIZE(this%dativar%r)
4957 this%dativar%r(i)%c = &
4958 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
4959 ENDDO
4960 ENDIF
4961ENDIF
4962! double
4963IF (ASSOCIATED(this%dativar%d)) THEN
4964 IF (ASSOCIATED(this%dativarattr%r)) THEN
4965 DO i = 1, SIZE(this%dativar%d)
4966 this%dativar%d(i)%r = &
4967 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
4968 ENDDO
4969 ENDIF
4970
4971 IF (ASSOCIATED(this%dativarattr%d)) THEN
4972 DO i = 1, SIZE(this%dativar%d)
4973 this%dativar%d(i)%d = &
4974 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
4975 ENDDO
4976 ENDIF
4977
4978 IF (ASSOCIATED(this%dativarattr%i)) THEN
4979 DO i = 1, SIZE(this%dativar%d)
4980 this%dativar%d(i)%i = &
4981 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
4982 ENDDO
4983 ENDIF
4984
4985 IF (ASSOCIATED(this%dativarattr%b)) THEN
4986 DO i = 1, SIZE(this%dativar%d)
4987 this%dativar%d(i)%b = &
4988 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
4989 ENDDO
4990 ENDIF
4991
4992 IF (ASSOCIATED(this%dativarattr%c)) THEN
4993 DO i = 1, SIZE(this%dativar%d)
4994 this%dativar%d(i)%c = &
4995 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
4996 ENDDO
4997 ENDIF
4998ENDIF
4999! integer
5000IF (ASSOCIATED(this%dativar%i)) THEN
5001 IF (ASSOCIATED(this%dativarattr%r)) THEN
5002 DO i = 1, SIZE(this%dativar%i)
5003 this%dativar%i(i)%r = &
5004 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5005 ENDDO
5006 ENDIF
5007
5008 IF (ASSOCIATED(this%dativarattr%d)) THEN
5009 DO i = 1, SIZE(this%dativar%i)
5010 this%dativar%i(i)%d = &
5011 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5012 ENDDO
5013 ENDIF
5014
5015 IF (ASSOCIATED(this%dativarattr%i)) THEN
5016 DO i = 1, SIZE(this%dativar%i)
5017 this%dativar%i(i)%i = &
5018 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5019 ENDDO
5020 ENDIF
5021
5022 IF (ASSOCIATED(this%dativarattr%b)) THEN
5023 DO i = 1, SIZE(this%dativar%i)
5024 this%dativar%i(i)%b = &
5025 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5026 ENDDO
5027 ENDIF
5028
5029 IF (ASSOCIATED(this%dativarattr%c)) THEN
5030 DO i = 1, SIZE(this%dativar%i)
5031 this%dativar%i(i)%c = &
5032 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5033 ENDDO
5034 ENDIF
5035ENDIF
5036! byte
5037IF (ASSOCIATED(this%dativar%b)) THEN
5038 IF (ASSOCIATED(this%dativarattr%r)) THEN
5039 DO i = 1, SIZE(this%dativar%b)
5040 this%dativar%b(i)%r = &
5041 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5042 ENDDO
5043 ENDIF
5044
5045 IF (ASSOCIATED(this%dativarattr%d)) THEN
5046 DO i = 1, SIZE(this%dativar%b)
5047 this%dativar%b(i)%d = &
5048 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5049 ENDDO
5050 ENDIF
5051
5052 IF (ASSOCIATED(this%dativarattr%i)) THEN
5053 DO i = 1, SIZE(this%dativar%b)
5054 this%dativar%b(i)%i = &
5055 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5056 ENDDO
5057 ENDIF
5058
5059 IF (ASSOCIATED(this%dativarattr%b)) THEN
5060 DO i = 1, SIZE(this%dativar%b)
5061 this%dativar%b(i)%b = &
5062 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5063 ENDDO
5064 ENDIF
5065
5066 IF (ASSOCIATED(this%dativarattr%c)) THEN
5067 DO i = 1, SIZE(this%dativar%b)
5068 this%dativar%b(i)%c = &
5069 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5070 ENDDO
5071 ENDIF
5072ENDIF
5073! character
5074IF (ASSOCIATED(this%dativar%c)) THEN
5075 IF (ASSOCIATED(this%dativarattr%r)) THEN
5076 DO i = 1, SIZE(this%dativar%c)
5077 this%dativar%c(i)%r = &
5078 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5079 ENDDO
5080 ENDIF
5081
5082 IF (ASSOCIATED(this%dativarattr%d)) THEN
5083 DO i = 1, SIZE(this%dativar%c)
5084 this%dativar%c(i)%d = &
5085 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5086 ENDDO
5087 ENDIF
5088
5089 IF (ASSOCIATED(this%dativarattr%i)) THEN
5090 DO i = 1, SIZE(this%dativar%c)
5091 this%dativar%c(i)%i = &
5092 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5093 ENDDO
5094 ENDIF
5095
5096 IF (ASSOCIATED(this%dativarattr%b)) THEN
5097 DO i = 1, SIZE(this%dativar%c)
5098 this%dativar%c(i)%b = &
5099 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5100 ENDDO
5101 ENDIF
5102
5103 IF (ASSOCIATED(this%dativarattr%c)) THEN
5104 DO i = 1, SIZE(this%dativar%c)
5105 this%dativar%c(i)%c = &
5106 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5107 ENDDO
5108 ENDIF
5109ENDIF
5110
5111END SUBROUTINE vol7d_set_attr_ind
5112
5113
5118SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5119 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5120TYPE(vol7d),INTENT(INOUT) :: this
5121TYPE(vol7d),INTENT(INOUT) :: that
5122LOGICAL,INTENT(IN),OPTIONAL :: sort
5123LOGICAL,INTENT(in),OPTIONAL :: bestdata
5124LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5125
5126TYPE(vol7d) :: v7d_clean
5127
5128
5130 this = that
5132 that = v7d_clean ! destroy that without deallocating
5133ELSE ! Append that to this and destroy that
5135 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5137ENDIF
5138
5139END SUBROUTINE vol7d_merge
5140
5141
5170SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5171 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5172TYPE(vol7d),INTENT(INOUT) :: this
5173TYPE(vol7d),INTENT(IN) :: that
5174LOGICAL,INTENT(IN),OPTIONAL :: sort
5175! experimental, please do not use outside the library now, they force the use
5176! of a simplified mapping algorithm which is valid only whene the dimension
5177! content is the same in both volumes , or when one of them is empty
5178LOGICAL,INTENT(in),OPTIONAL :: bestdata
5179LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5180
5181
5182TYPE(vol7d) :: v7dtmp
5183LOGICAL :: lsort, lbestdata
5184INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5185 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5186
5188IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5191 RETURN
5192ENDIF
5193
5194IF (this%time_definition /= that%time_definition) THEN
5195 CALL l4f_log(l4f_fatal, &
5196 'in vol7d_append, cannot append volumes with different &
5197 &time definition')
5198 CALL raise_fatal_error()
5199ENDIF
5200
5201! Completo l'allocazione per avere volumi a norma
5202CALL vol7d_alloc_vol(this)
5203
5207
5208! Calcolo le mappature tra volumi vecchi e volume nuovo
5209! I puntatori remap* vengono tutti o allocati o nullificati
5210IF (optio_log(ltimesimple)) THEN
5211 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5212 lsort, remapt1, remapt2)
5213ELSE
5214 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5215 lsort, remapt1, remapt2)
5216ENDIF
5217IF (optio_log(ltimerangesimple)) THEN
5218 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5219 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5220ELSE
5221 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5222 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5223ENDIF
5224IF (optio_log(llevelsimple)) THEN
5225 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5226 lsort, remapl1, remapl2)
5227ELSE
5228 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5229 lsort, remapl1, remapl2)
5230ENDIF
5231IF (optio_log(lanasimple)) THEN
5232 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5233 .false., remapa1, remapa2)
5234ELSE
5235 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5236 .false., remapa1, remapa2)
5237ENDIF
5238IF (optio_log(lnetworksimple)) THEN
5239 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5240 .false., remapn1, remapn2)
5241ELSE
5242 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5243 .false., remapn1, remapn2)
5244ENDIF
5245
5246! Faccio la fusione fisica dei volumi
5247CALL vol7d_merge_finalr(this, that, v7dtmp, &
5248 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5249 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5250CALL vol7d_merge_finald(this, that, v7dtmp, &
5251 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5252 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5253CALL vol7d_merge_finali(this, that, v7dtmp, &
5254 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5255 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5256CALL vol7d_merge_finalb(this, that, v7dtmp, &
5257 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5258 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5259CALL vol7d_merge_finalc(this, that, v7dtmp, &
5260 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5261 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5262
5263! Dealloco i vettori di rimappatura
5264IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5265IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5266IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5267IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5268IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5269IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5270IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5271IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5272IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5273IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5274
5275! Distruggo il vecchio volume e assegno il nuovo a this
5277this = v7dtmp
5278! Ricreo gli indici var-attr
5279CALL vol7d_set_attr_ind(this)
5280
5281END SUBROUTINE vol7d_append
5282
5283
5316SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5317 lsort_time, lsort_timerange, lsort_level, &
5318 ltime, ltimerange, llevel, lana, lnetwork, &
5319 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5320 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5321 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5322 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5323 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5324 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5325TYPE(vol7d),INTENT(IN) :: this
5326TYPE(vol7d),INTENT(INOUT) :: that
5327LOGICAL,INTENT(IN),OPTIONAL :: sort
5328LOGICAL,INTENT(IN),OPTIONAL :: unique
5329LOGICAL,INTENT(IN),OPTIONAL :: miss
5330LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5331LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5332LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5340LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5342LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5344LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5346LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5348LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5350LOGICAL,INTENT(in),OPTIONAL :: &
5351 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5352 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5353 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5354 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5355 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5356 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5357
5358LOGICAL :: lsort, lunique, lmiss
5359INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5360
5363IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5364
5368
5369! Calcolo le mappature tra volume vecchio e volume nuovo
5370! I puntatori remap* vengono tutti o allocati o nullificati
5371CALL vol7d_remap1_datetime(this%time, that%time, &
5372 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
5373CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
5374 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
5375CALL vol7d_remap1_vol7d_level(this%level, that%level, &
5376 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
5377CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
5378 lsort, lunique, lmiss, remapa, lana)
5379CALL vol7d_remap1_vol7d_network(this%network, that%network, &
5380 lsort, lunique, lmiss, remapn, lnetwork)
5381
5382! lanavari, lanavarb, lanavarc, &
5383! lanaattri, lanaattrb, lanaattrc, &
5384! lanavarattri, lanavarattrb, lanavarattrc, &
5385! ldativari, ldativarb, ldativarc, &
5386! ldatiattri, ldatiattrb, ldatiattrc, &
5387! ldativarattri, ldativarattrb, ldativarattrc
5388! Faccio la riforma fisica dei volumi
5389CALL vol7d_reform_finalr(this, that, &
5390 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5391 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
5392CALL vol7d_reform_finald(this, that, &
5393 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5394 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
5395CALL vol7d_reform_finali(this, that, &
5396 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5397 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
5398CALL vol7d_reform_finalb(this, that, &
5399 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5400 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
5401CALL vol7d_reform_finalc(this, that, &
5402 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5403 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
5404
5405! Dealloco i vettori di rimappatura
5406IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
5407IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
5408IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
5409IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
5410IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
5411
5412! Ricreo gli indici var-attr
5413CALL vol7d_set_attr_ind(that)
5414that%time_definition = this%time_definition
5415
5416END SUBROUTINE vol7d_copy
5417
5418
5429SUBROUTINE vol7d_reform(this, sort, unique, miss, &
5430 lsort_time, lsort_timerange, lsort_level, &
5431 ltime, ltimerange, llevel, lana, lnetwork, &
5432 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5433 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5434 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5435 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5436 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5437 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
5438 ,purgeana)
5439TYPE(vol7d),INTENT(INOUT) :: this
5440LOGICAL,INTENT(IN),OPTIONAL :: sort
5441LOGICAL,INTENT(IN),OPTIONAL :: unique
5442LOGICAL,INTENT(IN),OPTIONAL :: miss
5443LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5444LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5445LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5453LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5454LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5455LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5456LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5457LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5459LOGICAL,INTENT(in),OPTIONAL :: &
5460 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5461 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5462 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5463 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5464 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5465 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5466LOGICAL,INTENT(IN),OPTIONAL :: purgeana
5467
5468TYPE(vol7d) :: v7dtmp
5469logical,allocatable :: llana(:)
5470integer :: i
5471
5473 lsort_time, lsort_timerange, lsort_level, &
5474 ltime, ltimerange, llevel, lana, lnetwork, &
5475 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5476 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5477 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5478 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5479 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5480 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5481
5482! destroy old volume
5484
5485if (optio_log(purgeana)) then
5486 allocate(llana(size(v7dtmp%ana)))
5487 llana =.false.
5488 do i =1,size(v7dtmp%ana)
5489 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
5490 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
5491 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
5492 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
5493 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
5494 end do
5495 CALL vol7d_copy(v7dtmp, this,lana=llana)
5497 deallocate(llana)
5498else
5499 this=v7dtmp
5500end if
5501
5502END SUBROUTINE vol7d_reform
5503
5504
5512SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
5513TYPE(vol7d),INTENT(INOUT) :: this
5514LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
5515LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
5516LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
5517
5518INTEGER :: i
5519LOGICAL :: to_be_sorted
5520
5521to_be_sorted = .false.
5522CALL vol7d_alloc_vol(this) ! usual safety check
5523
5524IF (optio_log(lsort_time)) THEN
5525 DO i = 2, SIZE(this%time)
5526 IF (this%time(i) < this%time(i-1)) THEN
5527 to_be_sorted = .true.
5528 EXIT
5529 ENDIF
5530 ENDDO
5531ENDIF
5532IF (optio_log(lsort_timerange)) THEN
5533 DO i = 2, SIZE(this%timerange)
5534 IF (this%timerange(i) < this%timerange(i-1)) THEN
5535 to_be_sorted = .true.
5536 EXIT
5537 ENDIF
5538 ENDDO
5539ENDIF
5540IF (optio_log(lsort_level)) THEN
5541 DO i = 2, SIZE(this%level)
5542 IF (this%level(i) < this%level(i-1)) THEN
5543 to_be_sorted = .true.
5544 EXIT
5545 ENDIF
5546 ENDDO
5547ENDIF
5548
5549IF (to_be_sorted) CALL vol7d_reform(this, &
5550 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
5551
5552END SUBROUTINE vol7d_smart_sort
5553
5561SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
5562TYPE(vol7d),INTENT(inout) :: this
5563CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
5564CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
5565TYPE(vol7d_network),OPTIONAL :: nl(:)
5566TYPE(datetime),INTENT(in),OPTIONAL :: s_d
5567TYPE(datetime),INTENT(in),OPTIONAL :: e_d
5568
5569INTEGER :: i
5570
5571IF (PRESENT(avl)) THEN
5572 IF (SIZE(avl) > 0) THEN
5573
5574 IF (ASSOCIATED(this%anavar%r)) THEN
5575 DO i = 1, SIZE(this%anavar%r)
5576 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
5577 ENDDO
5578 ENDIF
5579
5580 IF (ASSOCIATED(this%anavar%i)) THEN
5581 DO i = 1, SIZE(this%anavar%i)
5582 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
5583 ENDDO
5584 ENDIF
5585
5586 IF (ASSOCIATED(this%anavar%b)) THEN
5587 DO i = 1, SIZE(this%anavar%b)
5588 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
5589 ENDDO
5590 ENDIF
5591
5592 IF (ASSOCIATED(this%anavar%d)) THEN
5593 DO i = 1, SIZE(this%anavar%d)
5594 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
5595 ENDDO
5596 ENDIF
5597
5598 IF (ASSOCIATED(this%anavar%c)) THEN
5599 DO i = 1, SIZE(this%anavar%c)
5600 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
5601 ENDDO
5602 ENDIF
5603
5604 ENDIF
5605ENDIF
5606
5607
5608IF (PRESENT(vl)) THEN
5609 IF (size(vl) > 0) THEN
5610 IF (ASSOCIATED(this%dativar%r)) THEN
5611 DO i = 1, SIZE(this%dativar%r)
5612 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
5613 ENDDO
5614 ENDIF
5615
5616 IF (ASSOCIATED(this%dativar%i)) THEN
5617 DO i = 1, SIZE(this%dativar%i)
5618 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
5619 ENDDO
5620 ENDIF
5621
5622 IF (ASSOCIATED(this%dativar%b)) THEN
5623 DO i = 1, SIZE(this%dativar%b)
5624 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
5625 ENDDO
5626 ENDIF
5627
5628 IF (ASSOCIATED(this%dativar%d)) THEN
5629 DO i = 1, SIZE(this%dativar%d)
5630 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
5631 ENDDO
5632 ENDIF
5633
5634 IF (ASSOCIATED(this%dativar%c)) THEN
5635 DO i = 1, SIZE(this%dativar%c)
5636 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5637 ENDDO
5638 ENDIF
5639
5640 IF (ASSOCIATED(this%dativar%c)) THEN
5641 DO i = 1, SIZE(this%dativar%c)
5642 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5643 ENDDO
5644 ENDIF
5645
5646 ENDIF
5647ENDIF
5648
5649IF (PRESENT(nl)) THEN
5650 IF (SIZE(nl) > 0) THEN
5651 DO i = 1, SIZE(this%network)
5652 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
5653 ENDDO
5654 ENDIF
5655ENDIF
5656
5657IF (PRESENT(s_d)) THEN
5659 WHERE (this%time < s_d)
5660 this%time = datetime_miss
5661 END WHERE
5662 ENDIF
5663ENDIF
5664
5665IF (PRESENT(e_d)) THEN
5667 WHERE (this%time > e_d)
5668 this%time = datetime_miss
5669 END WHERE
5670 ENDIF
5671ENDIF
5672
5673CALL vol7d_reform(this, miss=.true.)
5674
5675END SUBROUTINE vol7d_filter
5676
5677
5684SUBROUTINE vol7d_convr(this, that, anaconv)
5685TYPE(vol7d),INTENT(IN) :: this
5686TYPE(vol7d),INTENT(INOUT) :: that
5687LOGICAL,OPTIONAL,INTENT(in) :: anaconv
5688INTEGER :: i
5689LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
5690TYPE(vol7d) :: v7d_tmp
5691
5692IF (optio_log(anaconv)) THEN
5693 acp=fv
5694 acn=tv
5695ELSE
5696 acp=tv
5697 acn=fv
5698ENDIF
5699
5700! Volume con solo i dati reali e tutti gli attributi
5701! l'anagrafica e` copiata interamente se necessario
5702CALL vol7d_copy(this, that, &
5703 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
5704 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
5705
5706! Volume solo di dati double
5707CALL vol7d_copy(this, v7d_tmp, &
5708 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
5709 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5710 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5711 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
5712 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5713 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5714
5715! converto a dati reali
5716IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
5717
5718 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
5719! alloco i dati reali e vi trasferisco i double
5720 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
5721 SIZE(v7d_tmp%volanad, 3)))
5722 DO i = 1, SIZE(v7d_tmp%anavar%d)
5723 v7d_tmp%volanar(:,i,:) = &
5724 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
5725 ENDDO
5726 DEALLOCATE(v7d_tmp%volanad)
5727! trasferisco le variabili
5728 v7d_tmp%anavar%r => v7d_tmp%anavar%d
5729 NULLIFY(v7d_tmp%anavar%d)
5730 ENDIF
5731
5732 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
5733! alloco i dati reali e vi trasferisco i double
5734 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
5735 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
5736 SIZE(v7d_tmp%voldatid, 6)))
5737 DO i = 1, SIZE(v7d_tmp%dativar%d)
5738 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5739 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
5740 ENDDO
5741 DEALLOCATE(v7d_tmp%voldatid)
5742! trasferisco le variabili
5743 v7d_tmp%dativar%r => v7d_tmp%dativar%d
5744 NULLIFY(v7d_tmp%dativar%d)
5745 ENDIF
5746
5747! fondo con il volume definitivo
5748 CALL vol7d_merge(that, v7d_tmp)
5749ELSE
5751ENDIF
5752
5753
5754! Volume solo di dati interi
5755CALL vol7d_copy(this, v7d_tmp, &
5756 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
5757 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5758 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5759 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
5760 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5761 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5762
5763! converto a dati reali
5764IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
5765
5766 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
5767! alloco i dati reali e vi trasferisco gli interi
5768 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
5769 SIZE(v7d_tmp%volanai, 3)))
5770 DO i = 1, SIZE(v7d_tmp%anavar%i)
5771 v7d_tmp%volanar(:,i,:) = &
5772 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
5773 ENDDO
5774 DEALLOCATE(v7d_tmp%volanai)
5775! trasferisco le variabili
5776 v7d_tmp%anavar%r => v7d_tmp%anavar%i
5777 NULLIFY(v7d_tmp%anavar%i)
5778 ENDIF
5779
5780 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
5781! alloco i dati reali e vi trasferisco gli interi
5782 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
5783 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
5784 SIZE(v7d_tmp%voldatii, 6)))
5785 DO i = 1, SIZE(v7d_tmp%dativar%i)
5786 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5787 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
5788 ENDDO
5789 DEALLOCATE(v7d_tmp%voldatii)
5790! trasferisco le variabili
5791 v7d_tmp%dativar%r => v7d_tmp%dativar%i
5792 NULLIFY(v7d_tmp%dativar%i)
5793 ENDIF
5794
5795! fondo con il volume definitivo
5796 CALL vol7d_merge(that, v7d_tmp)
5797ELSE
5799ENDIF
5800
5801
5802! Volume solo di dati byte
5803CALL vol7d_copy(this, v7d_tmp, &
5804 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
5805 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5806 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5807 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
5808 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5809 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5810
5811! converto a dati reali
5812IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
5813
5814 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
5815! alloco i dati reali e vi trasferisco i byte
5816 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
5817 SIZE(v7d_tmp%volanab, 3)))
5818 DO i = 1, SIZE(v7d_tmp%anavar%b)
5819 v7d_tmp%volanar(:,i,:) = &
5820 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
5821 ENDDO
5822 DEALLOCATE(v7d_tmp%volanab)
5823! trasferisco le variabili
5824 v7d_tmp%anavar%r => v7d_tmp%anavar%b
5825 NULLIFY(v7d_tmp%anavar%b)
5826 ENDIF
5827
5828 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
5829! alloco i dati reali e vi trasferisco i byte
5830 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
5831 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
5832 SIZE(v7d_tmp%voldatib, 6)))
5833 DO i = 1, SIZE(v7d_tmp%dativar%b)
5834 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5835 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
5836 ENDDO
5837 DEALLOCATE(v7d_tmp%voldatib)
5838! trasferisco le variabili
5839 v7d_tmp%dativar%r => v7d_tmp%dativar%b
5840 NULLIFY(v7d_tmp%dativar%b)
5841 ENDIF
5842
5843! fondo con il volume definitivo
5844 CALL vol7d_merge(that, v7d_tmp)
5845ELSE
5847ENDIF
5848
5849
5850! Volume solo di dati character
5851CALL vol7d_copy(this, v7d_tmp, &
5852 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
5853 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5854 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5855 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
5856 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5857 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5858
5859! converto a dati reali
5860IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
5861
5862 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
5863! alloco i dati reali e vi trasferisco i character
5864 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
5865 SIZE(v7d_tmp%volanac, 3)))
5866 DO i = 1, SIZE(v7d_tmp%anavar%c)
5867 v7d_tmp%volanar(:,i,:) = &
5868 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
5869 ENDDO
5870 DEALLOCATE(v7d_tmp%volanac)
5871! trasferisco le variabili
5872 v7d_tmp%anavar%r => v7d_tmp%anavar%c
5873 NULLIFY(v7d_tmp%anavar%c)
5874 ENDIF
5875
5876 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
5877! alloco i dati reali e vi trasferisco i character
5878 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
5879 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
5880 SIZE(v7d_tmp%voldatic, 6)))
5881 DO i = 1, SIZE(v7d_tmp%dativar%c)
5882 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5883 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
5884 ENDDO
5885 DEALLOCATE(v7d_tmp%voldatic)
5886! trasferisco le variabili
5887 v7d_tmp%dativar%r => v7d_tmp%dativar%c
5888 NULLIFY(v7d_tmp%dativar%c)
5889 ENDIF
5890
5891! fondo con il volume definitivo
5892 CALL vol7d_merge(that, v7d_tmp)
5893ELSE
5895ENDIF
5896
5897END SUBROUTINE vol7d_convr
5898
5899
5903SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
5904TYPE(vol7d),INTENT(IN) :: this
5905TYPE(vol7d),INTENT(OUT) :: that
5906logical , optional, intent(in) :: data_only
5907logical , optional, intent(in) :: ana
5908logical :: ldata_only,lana
5909
5910IF (PRESENT(data_only)) THEN
5911 ldata_only = data_only
5912ELSE
5913 ldata_only = .false.
5914ENDIF
5915
5916IF (PRESENT(ana)) THEN
5917 lana = ana
5918ELSE
5919 lana = .false.
5920ENDIF
5921
5922
5923#undef VOL7D_POLY_ARRAY
5924#define VOL7D_POLY_ARRAY voldati
5925#include "vol7d_class_diff.F90"
5926#undef VOL7D_POLY_ARRAY
5927#define VOL7D_POLY_ARRAY voldatiattr
5928#include "vol7d_class_diff.F90"
5929#undef VOL7D_POLY_ARRAY
5930
5931if ( .not. ldata_only) then
5932
5933#define VOL7D_POLY_ARRAY volana
5934#include "vol7d_class_diff.F90"
5935#undef VOL7D_POLY_ARRAY
5936#define VOL7D_POLY_ARRAY volanaattr
5937#include "vol7d_class_diff.F90"
5938#undef VOL7D_POLY_ARRAY
5939
5940 if(lana)then
5941 where ( this%ana == that%ana )
5942 that%ana = vol7d_ana_miss
5943 end where
5944 end if
5945
5946end if
5947
5948
5949
5950END SUBROUTINE vol7d_diff_only
5951
5952
5953
5954! Creo le routine da ripetere per i vari tipi di dati di v7d
5955! tramite un template e il preprocessore
5956#undef VOL7D_POLY_TYPE
5957#undef VOL7D_POLY_TYPES
5958#define VOL7D_POLY_TYPE REAL
5959#define VOL7D_POLY_TYPES r
5960#include "vol7d_class_type_templ.F90"
5961#undef VOL7D_POLY_TYPE
5962#undef VOL7D_POLY_TYPES
5963#define VOL7D_POLY_TYPE DOUBLE PRECISION
5964#define VOL7D_POLY_TYPES d
5965#include "vol7d_class_type_templ.F90"
5966#undef VOL7D_POLY_TYPE
5967#undef VOL7D_POLY_TYPES
5968#define VOL7D_POLY_TYPE INTEGER
5969#define VOL7D_POLY_TYPES i
5970#include "vol7d_class_type_templ.F90"
5971#undef VOL7D_POLY_TYPE
5972#undef VOL7D_POLY_TYPES
5973#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
5974#define VOL7D_POLY_TYPES b
5975#include "vol7d_class_type_templ.F90"
5976#undef VOL7D_POLY_TYPE
5977#undef VOL7D_POLY_TYPES
5978#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
5979#define VOL7D_POLY_TYPES c
5980#include "vol7d_class_type_templ.F90"
5981
5982! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
5983! tramite un template e il preprocessore
5984#define VOL7D_SORT
5985#undef VOL7D_NO_ZERO_ALLOC
5986#undef VOL7D_POLY_TYPE
5987#define VOL7D_POLY_TYPE datetime
5988#include "vol7d_class_desc_templ.F90"
5989#undef VOL7D_POLY_TYPE
5990#define VOL7D_POLY_TYPE vol7d_timerange
5991#include "vol7d_class_desc_templ.F90"
5992#undef VOL7D_POLY_TYPE
5993#define VOL7D_POLY_TYPE vol7d_level
5994#include "vol7d_class_desc_templ.F90"
5995#undef VOL7D_SORT
5996#undef VOL7D_POLY_TYPE
5997#define VOL7D_POLY_TYPE vol7d_network
5998#include "vol7d_class_desc_templ.F90"
5999#undef VOL7D_POLY_TYPE
6000#define VOL7D_POLY_TYPE vol7d_ana
6001#include "vol7d_class_desc_templ.F90"
6002#define VOL7D_NO_ZERO_ALLOC
6003#undef VOL7D_POLY_TYPE
6004#define VOL7D_POLY_TYPE vol7d_var
6005#include "vol7d_class_desc_templ.F90"
6006
6016subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6017
6018TYPE(vol7d),INTENT(IN) :: this
6019integer,optional,intent(inout) :: unit
6020character(len=*),intent(in),optional :: filename
6021character(len=*),intent(out),optional :: filename_auto
6022character(len=*),INTENT(IN),optional :: description
6023
6024integer :: lunit
6025character(len=254) :: ldescription,arg,lfilename
6026integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6027 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6028 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6029 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6030 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6031 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6032 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6033!integer :: im,id,iy
6034integer :: tarray(8)
6035logical :: opened,exist
6036
6037 nana=0
6038 ntime=0
6039 ntimerange=0
6040 nlevel=0
6041 nnetwork=0
6042 ndativarr=0
6043 ndativari=0
6044 ndativarb=0
6045 ndativard=0
6046 ndativarc=0
6047 ndatiattrr=0
6048 ndatiattri=0
6049 ndatiattrb=0
6050 ndatiattrd=0
6051 ndatiattrc=0
6052 ndativarattrr=0
6053 ndativarattri=0
6054 ndativarattrb=0
6055 ndativarattrd=0
6056 ndativarattrc=0
6057 nanavarr=0
6058 nanavari=0
6059 nanavarb=0
6060 nanavard=0
6061 nanavarc=0
6062 nanaattrr=0
6063 nanaattri=0
6064 nanaattrb=0
6065 nanaattrd=0
6066 nanaattrc=0
6067 nanavarattrr=0
6068 nanavarattri=0
6069 nanavarattrb=0
6070 nanavarattrd=0
6071 nanavarattrc=0
6072
6073
6074!call idate(im,id,iy)
6075call date_and_time(values=tarray)
6076call getarg(0,arg)
6077
6078if (present(description))then
6079 ldescription=description
6080else
6081 ldescription="Vol7d generated by: "//trim(arg)
6082end if
6083
6084if (.not. present(unit))then
6085 lunit=getunit()
6086else
6087 if (unit==0)then
6088 lunit=getunit()
6089 unit=lunit
6090 else
6091 lunit=unit
6092 end if
6093end if
6094
6095lfilename=trim(arg)//".v7d"
6097
6098if (present(filename))then
6099 if (filename /= "")then
6100 lfilename=filename
6101 end if
6102end if
6103
6104if (present(filename_auto))filename_auto=lfilename
6105
6106
6107inquire(unit=lunit,opened=opened)
6108if (.not. opened) then
6109! inquire(file=lfilename, EXIST=exist)
6110! IF (exist) THEN
6111! CALL l4f_log(L4F_FATAL, &
6112! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6113! CALL raise_fatal_error()
6114! ENDIF
6115 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6116 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6117end if
6118
6119if (associated(this%ana)) nana=size(this%ana)
6120if (associated(this%time)) ntime=size(this%time)
6121if (associated(this%timerange)) ntimerange=size(this%timerange)
6122if (associated(this%level)) nlevel=size(this%level)
6123if (associated(this%network)) nnetwork=size(this%network)
6124
6125if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6126if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6127if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6128if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6129if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6130
6131if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6132if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6133if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6134if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6135if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6136
6137if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6138if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6139if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6140if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6141if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6142
6143if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6144if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6145if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6146if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6147if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6148
6149if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6150if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6151if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6152if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6153if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6154
6155if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6156if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6157if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6158if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6159if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6160
6161write(unit=lunit)ldescription
6162write(unit=lunit)tarray
6163
6164write(unit=lunit)&
6165 nana, ntime, ntimerange, nlevel, nnetwork, &
6166 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6167 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6168 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6169 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6170 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6171 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6172 this%time_definition
6173
6174
6175!write(unit=lunit)this
6176
6177
6178!! prime 5 dimensioni
6181if (associated(this%level)) write(unit=lunit)this%level
6182if (associated(this%timerange)) write(unit=lunit)this%timerange
6183if (associated(this%network)) write(unit=lunit)this%network
6184
6185 !! 6a dimensione: variabile dell'anagrafica e dei dati
6186 !! con relativi attributi e in 5 tipi diversi
6187
6188if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6189if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6190if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6191if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6192if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6193
6194if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6195if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6196if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6197if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6198if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6199
6200if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6201if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6202if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6203if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6204if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6205
6206if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6207if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6208if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6209if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6210if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6211
6212if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6213if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6214if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6215if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6216if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6217
6218if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6219if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6220if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6221if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6222if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6223
6224!! Volumi di valori e attributi per anagrafica e dati
6225
6226if (associated(this%volanar)) write(unit=lunit)this%volanar
6227if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6228if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6229if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6230
6231if (associated(this%volanai)) write(unit=lunit)this%volanai
6232if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6233if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6234if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6235
6236if (associated(this%volanab)) write(unit=lunit)this%volanab
6237if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6238if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6239if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6240
6241if (associated(this%volanad)) write(unit=lunit)this%volanad
6242if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6243if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6244if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6245
6246if (associated(this%volanac)) write(unit=lunit)this%volanac
6247if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6248if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6249if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6250
6251if (.not. present(unit)) close(unit=lunit)
6252
6253end subroutine vol7d_write_on_file
6254
6255
6262
6263
6264subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6265
6266TYPE(vol7d),INTENT(OUT) :: this
6267integer,intent(inout),optional :: unit
6268character(len=*),INTENT(in),optional :: filename
6269character(len=*),intent(out),optional :: filename_auto
6270character(len=*),INTENT(out),optional :: description
6271integer,intent(out),optional :: tarray(8)
6272
6273
6274integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6275 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6276 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6277 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6278 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6279 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6280 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6281
6282character(len=254) :: ldescription,lfilename,arg
6283integer :: ltarray(8),lunit,ios
6284logical :: opened,exist
6285
6286
6287call getarg(0,arg)
6288
6289if (.not. present(unit))then
6290 lunit=getunit()
6291else
6292 if (unit==0)then
6293 lunit=getunit()
6294 unit=lunit
6295 else
6296 lunit=unit
6297 end if
6298end if
6299
6300lfilename=trim(arg)//".v7d"
6302
6303if (present(filename))then
6304 if (filename /= "")then
6305 lfilename=filename
6306 end if
6307end if
6308
6309if (present(filename_auto))filename_auto=lfilename
6310
6311
6312inquire(unit=lunit,opened=opened)
6313IF (.NOT. opened) THEN
6314 inquire(file=lfilename,exist=exist)
6315 IF (.NOT.exist) THEN
6316 CALL l4f_log(l4f_fatal, &
6317 'in vol7d_read_from_file, file does not exists, cannot open')
6318 CALL raise_fatal_error()
6319 ENDIF
6320 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6321 status='OLD', action='READ')
6322 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6323end if
6324
6325
6327read(unit=lunit,iostat=ios)ldescription
6328
6329if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6330 call vol7d_alloc (this)
6331 call vol7d_alloc_vol (this)
6332 if (present(description))description=ldescription
6333 if (present(tarray))tarray=ltarray
6334 if (.not. present(unit)) close(unit=lunit)
6335end if
6336
6337read(unit=lunit)ltarray
6338
6339CALL l4f_log(l4f_info, 'Reading vol7d from file')
6340CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6343
6344if (present(description))description=ldescription
6345if (present(tarray))tarray=ltarray
6346
6347read(unit=lunit)&
6348 nana, ntime, ntimerange, nlevel, nnetwork, &
6349 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6350 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6351 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6352 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6353 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6354 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6355 this%time_definition
6356
6357call vol7d_alloc (this, &
6358 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6359 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6360 ndativard=ndativard, ndativarc=ndativarc,&
6361 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6362 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6363 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6364 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6365 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6366 nanavard=nanavard, nanavarc=nanavarc,&
6367 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6368 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6369 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
6370 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
6371
6372
6375if (associated(this%level)) read(unit=lunit)this%level
6376if (associated(this%timerange)) read(unit=lunit)this%timerange
6377if (associated(this%network)) read(unit=lunit)this%network
6378
6379if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
6380if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
6381if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
6382if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
6383if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
6384
6385if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
6386if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
6387if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
6388if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
6389if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
6390
6391if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
6392if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
6393if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
6394if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
6395if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
6396
6397if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
6398if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
6399if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
6400if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
6401if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
6402
6403if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
6404if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
6405if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
6406if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
6407if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
6408
6409if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
6410if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
6411if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
6412if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
6413if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
6414
6415call vol7d_alloc_vol (this)
6416
6417!! Volumi di valori e attributi per anagrafica e dati
6418
6419if (associated(this%volanar)) read(unit=lunit)this%volanar
6420if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
6421if (associated(this%voldatir)) read(unit=lunit)this%voldatir
6422if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
6423
6424if (associated(this%volanai)) read(unit=lunit)this%volanai
6425if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
6426if (associated(this%voldatii)) read(unit=lunit)this%voldatii
6427if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
6428
6429if (associated(this%volanab)) read(unit=lunit)this%volanab
6430if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
6431if (associated(this%voldatib)) read(unit=lunit)this%voldatib
6432if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
6433
6434if (associated(this%volanad)) read(unit=lunit)this%volanad
6435if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
6436if (associated(this%voldatid)) read(unit=lunit)this%voldatid
6437if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
6438
6439if (associated(this%volanac)) read(unit=lunit)this%volanac
6440if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
6441if (associated(this%voldatic)) read(unit=lunit)this%voldatic
6442if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
6443
6444if (.not. present(unit)) close(unit=lunit)
6445
6446end subroutine vol7d_read_from_file
6447
6448
6449! to double precision
6450elemental doubleprecision function doubledatd(voldat,var)
6451doubleprecision,intent(in) :: voldat
6452type(vol7d_var),intent(in) :: var
6453
6454doubledatd=voldat
6455
6456end function doubledatd
6457
6458
6459elemental doubleprecision function doubledatr(voldat,var)
6460real,intent(in) :: voldat
6461type(vol7d_var),intent(in) :: var
6462
6464 doubledatr=dble(voldat)
6465else
6466 doubledatr=dmiss
6467end if
6468
6469end function doubledatr
6470
6471
6472elemental doubleprecision function doubledati(voldat,var)
6473integer,intent(in) :: voldat
6474type(vol7d_var),intent(in) :: var
6475
6478 doubledati=dble(voldat)/10.d0**var%scalefactor
6479 else
6480 doubledati=dble(voldat)
6481 endif
6482else
6483 doubledati=dmiss
6484end if
6485
6486end function doubledati
6487
6488
6489elemental doubleprecision function doubledatb(voldat,var)
6490integer(kind=int_b),intent(in) :: voldat
6491type(vol7d_var),intent(in) :: var
6492
6495 doubledatb=dble(voldat)/10.d0**var%scalefactor
6496 else
6497 doubledatb=dble(voldat)
6498 endif
6499else
6500 doubledatb=dmiss
6501end if
6502
6503end function doubledatb
6504
6505
6506elemental doubleprecision function doubledatc(voldat,var)
6507CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6508type(vol7d_var),intent(in) :: var
6509
6510doubledatc = c2d(voldat)
6512 doubledatc=doubledatc/10.d0**var%scalefactor
6513end if
6514
6515end function doubledatc
6516
6517
6518! to integer
6519elemental integer function integerdatd(voldat,var)
6520doubleprecision,intent(in) :: voldat
6521type(vol7d_var),intent(in) :: var
6522
6525 integerdatd=nint(voldat*10d0**var%scalefactor)
6526 else
6527 integerdatd=nint(voldat)
6528 endif
6529else
6530 integerdatd=imiss
6531end if
6532
6533end function integerdatd
6534
6535
6536elemental integer function integerdatr(voldat,var)
6537real,intent(in) :: voldat
6538type(vol7d_var),intent(in) :: var
6539
6542 integerdatr=nint(voldat*10d0**var%scalefactor)
6543 else
6544 integerdatr=nint(voldat)
6545 endif
6546else
6547 integerdatr=imiss
6548end if
6549
6550end function integerdatr
6551
6552
6553elemental integer function integerdati(voldat,var)
6554integer,intent(in) :: voldat
6555type(vol7d_var),intent(in) :: var
6556
6557integerdati=voldat
6558
6559end function integerdati
6560
6561
6562elemental integer function integerdatb(voldat,var)
6563integer(kind=int_b),intent(in) :: voldat
6564type(vol7d_var),intent(in) :: var
6565
6567 integerdatb=voldat
6568else
6569 integerdatb=imiss
6570end if
6571
6572end function integerdatb
6573
6574
6575elemental integer function integerdatc(voldat,var)
6576CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6577type(vol7d_var),intent(in) :: var
6578
6579integerdatc=c2i(voldat)
6580
6581end function integerdatc
6582
6583
6584! to real
6585elemental real function realdatd(voldat,var)
6586doubleprecision,intent(in) :: voldat
6587type(vol7d_var),intent(in) :: var
6588
6590 realdatd=real(voldat)
6591else
6592 realdatd=rmiss
6593end if
6594
6595end function realdatd
6596
6597
6598elemental real function realdatr(voldat,var)
6599real,intent(in) :: voldat
6600type(vol7d_var),intent(in) :: var
6601
6602realdatr=voldat
6603
6604end function realdatr
6605
6606
6607elemental real function realdati(voldat,var)
6608integer,intent(in) :: voldat
6609type(vol7d_var),intent(in) :: var
6610
6613 realdati=float(voldat)/10.**var%scalefactor
6614 else
6615 realdati=float(voldat)
6616 endif
6617else
6618 realdati=rmiss
6619end if
6620
6621end function realdati
6622
6623
6624elemental real function realdatb(voldat,var)
6625integer(kind=int_b),intent(in) :: voldat
6626type(vol7d_var),intent(in) :: var
6627
6630 realdatb=float(voldat)/10**var%scalefactor
6631 else
6632 realdatb=float(voldat)
6633 endif
6634else
6635 realdatb=rmiss
6636end if
6637
6638end function realdatb
6639
6640
6641elemental real function realdatc(voldat,var)
6642CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6643type(vol7d_var),intent(in) :: var
6644
6645realdatc=c2r(voldat)
6647 realdatc=realdatc/10.**var%scalefactor
6648end if
6649
6650end function realdatc
6651
6652
6658FUNCTION realanavol(this, var) RESULT(vol)
6659TYPE(vol7d),INTENT(in) :: this
6660TYPE(vol7d_var),INTENT(in) :: var
6661REAL :: vol(SIZE(this%ana),size(this%network))
6662
6663CHARACTER(len=1) :: dtype
6664INTEGER :: indvar
6665
6666dtype = cmiss
6667indvar = index(this%anavar, var, type=dtype)
6668
6669IF (indvar > 0) THEN
6670 SELECT CASE (dtype)
6671 CASE("d")
6672 vol = realdat(this%volanad(:,indvar,:), var)
6673 CASE("r")
6674 vol = this%volanar(:,indvar,:)
6675 CASE("i")
6676 vol = realdat(this%volanai(:,indvar,:), var)
6677 CASE("b")
6678 vol = realdat(this%volanab(:,indvar,:), var)
6679 CASE("c")
6680 vol = realdat(this%volanac(:,indvar,:), var)
6681 CASE default
6682 vol = rmiss
6683 END SELECT
6684ELSE
6685 vol = rmiss
6686ENDIF
6687
6688END FUNCTION realanavol
6689
6690
6696FUNCTION integeranavol(this, var) RESULT(vol)
6697TYPE(vol7d),INTENT(in) :: this
6698TYPE(vol7d_var),INTENT(in) :: var
6699INTEGER :: vol(SIZE(this%ana),size(this%network))
6700
6701CHARACTER(len=1) :: dtype
6702INTEGER :: indvar
6703
6704dtype = cmiss
6705indvar = index(this%anavar, var, type=dtype)
6706
6707IF (indvar > 0) THEN
6708 SELECT CASE (dtype)
6709 CASE("d")
6710 vol = integerdat(this%volanad(:,indvar,:), var)
6711 CASE("r")
6712 vol = integerdat(this%volanar(:,indvar,:), var)
6713 CASE("i")
6714 vol = this%volanai(:,indvar,:)
6715 CASE("b")
6716 vol = integerdat(this%volanab(:,indvar,:), var)
6717 CASE("c")
6718 vol = integerdat(this%volanac(:,indvar,:), var)
6719 CASE default
6720 vol = imiss
6721 END SELECT
6722ELSE
6723 vol = imiss
6724ENDIF
6725
6726END FUNCTION integeranavol
6727
6728
6734subroutine move_datac (v7d,&
6735 indana,indtime,indlevel,indtimerange,indnetwork,&
6736 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6737
6738TYPE(vol7d),intent(inout) :: v7d
6739
6740integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6741integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6742integer :: inddativar,inddativarattr
6743
6744
6745do inddativar=1,size(v7d%dativar%c)
6746
6748 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6749 ) then
6750
6751 ! dati
6752 v7d%voldatic &
6753 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6754 v7d%voldatic &
6755 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6756
6757
6758 ! attributi
6759 if (associated (v7d%dativarattr%i)) then
6760 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
6761 if (inddativarattr > 0 ) then
6762 v7d%voldatiattri &
6763 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6764 v7d%voldatiattri &
6765 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6766 end if
6767 end if
6768
6769 if (associated (v7d%dativarattr%r)) then
6770 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
6771 if (inddativarattr > 0 ) then
6772 v7d%voldatiattrr &
6773 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6774 v7d%voldatiattrr &
6775 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6776 end if
6777 end if
6778
6779 if (associated (v7d%dativarattr%d)) then
6780 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
6781 if (inddativarattr > 0 ) then
6782 v7d%voldatiattrd &
6783 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6784 v7d%voldatiattrd &
6785 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6786 end if
6787 end if
6788
6789 if (associated (v7d%dativarattr%b)) then
6790 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
6791 if (inddativarattr > 0 ) then
6792 v7d%voldatiattrb &
6793 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6794 v7d%voldatiattrb &
6795 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6796 end if
6797 end if
6798
6799 if (associated (v7d%dativarattr%c)) then
6800 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
6801 if (inddativarattr > 0 ) then
6802 v7d%voldatiattrc &
6803 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6804 v7d%voldatiattrc &
6805 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6806 end if
6807 end if
6808
6809 end if
6810
6811end do
6812
6813end subroutine move_datac
6814
6820subroutine move_datar (v7d,&
6821 indana,indtime,indlevel,indtimerange,indnetwork,&
6822 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6823
6824TYPE(vol7d),intent(inout) :: v7d
6825
6826integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6827integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6828integer :: inddativar,inddativarattr
6829
6830
6831do inddativar=1,size(v7d%dativar%r)
6832
6834 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6835 ) then
6836
6837 ! dati
6838 v7d%voldatir &
6839 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6840 v7d%voldatir &
6841 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6842
6843
6844 ! attributi
6845 if (associated (v7d%dativarattr%i)) then
6846 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
6847 if (inddativarattr > 0 ) then
6848 v7d%voldatiattri &
6849 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6850 v7d%voldatiattri &
6851 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6852 end if
6853 end if
6854
6855 if (associated (v7d%dativarattr%r)) then
6856 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
6857 if (inddativarattr > 0 ) then
6858 v7d%voldatiattrr &
6859 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6860 v7d%voldatiattrr &
6861 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6862 end if
6863 end if
6864
6865 if (associated (v7d%dativarattr%d)) then
6866 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
6867 if (inddativarattr > 0 ) then
6868 v7d%voldatiattrd &
6869 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6870 v7d%voldatiattrd &
6871 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6872 end if
6873 end if
6874
6875 if (associated (v7d%dativarattr%b)) then
6876 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
6877 if (inddativarattr > 0 ) then
6878 v7d%voldatiattrb &
6879 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6880 v7d%voldatiattrb &
6881 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6882 end if
6883 end if
6884
6885 if (associated (v7d%dativarattr%c)) then
6886 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
6887 if (inddativarattr > 0 ) then
6888 v7d%voldatiattrc &
6889 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6890 v7d%voldatiattrc &
6891 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6892 end if
6893 end if
6894
6895 end if
6896
6897end do
6898
6899end subroutine move_datar
6900
6901
6915subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
6916type(vol7d),intent(inout) :: v7din
6917type(vol7d),intent(out) :: v7dout
6918type(vol7d_level),intent(in),optional :: level(:)
6919type(vol7d_timerange),intent(in),optional :: timerange(:)
6920!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
6921!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
6922logical,intent(in),optional :: nostatproc
6923
6924integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
6925integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
6926type(vol7d_level) :: roundlevel(size(v7din%level))
6927type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
6928type(vol7d) :: v7d_tmp
6929
6930
6931nbin=0
6932
6933if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
6934if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
6935if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
6936if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
6937
6939
6940roundlevel=v7din%level
6941
6942if (present(level))then
6943 do ilevel = 1, size(v7din%level)
6944 if ((any(v7din%level(ilevel) .almosteq. level))) then
6945 roundlevel(ilevel)=level(1)
6946 end if
6947 end do
6948end if
6949
6950roundtimerange=v7din%timerange
6951
6952if (present(timerange))then
6953 do itimerange = 1, size(v7din%timerange)
6954 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
6955 roundtimerange(itimerange)=timerange(1)
6956 end if
6957 end do
6958end if
6959
6960!set istantaneous values everywere
6961!preserve p1 for forecast time
6962if (optio_log(nostatproc)) then
6963 roundtimerange(:)%timerange=254
6964 roundtimerange(:)%p2=0
6965end if
6966
6967
6968nana=size(v7din%ana)
6969nlevel=count_distinct(roundlevel,back=.true.)
6970ntime=size(v7din%time)
6971ntimerange=count_distinct(roundtimerange,back=.true.)
6972nnetwork=size(v7din%network)
6973
6975
6976if (nbin == 0) then
6978else
6979 call vol7d_convr(v7din,v7d_tmp)
6980end if
6981
6982v7d_tmp%level=roundlevel
6983v7d_tmp%timerange=roundtimerange
6984
6985do ilevel=1, size(v7d_tmp%level)
6986 indl=index(v7d_tmp%level,roundlevel(ilevel))
6987 do itimerange=1,size(v7d_tmp%timerange)
6988 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
6989
6990 if (indl /= ilevel .or. indt /= itimerange) then
6991
6992 do iana=1, nana
6993 do itime=1,ntime
6994 do inetwork=1,nnetwork
6995
6996 if (nbin > 0) then
6997 call move_datar (v7d_tmp,&
6998 iana,itime,ilevel,itimerange,inetwork,&
6999 iana,itime,indl,indt,inetwork)
7000 else
7001 call move_datac (v7d_tmp,&
7002 iana,itime,ilevel,itimerange,inetwork,&
7003 iana,itime,indl,indt,inetwork)
7004 end if
7005
7006 end do
7007 end do
7008 end do
7009
7010 end if
7011
7012 end do
7013end do
7014
7015! set to missing level and time > nlevel
7016do ilevel=nlevel+1,size(v7d_tmp%level)
7018end do
7019
7020do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7022end do
7023
7024!copy with remove
7027
7028!call display(v7dout)
7029
7030end subroutine v7d_rounding
7031
7032
7034
7040
7041
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition char_utilities.F90:278 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition datetime_class.F90:478 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition datetime_class.F90:485 Generic subroutine for checking OPTIONAL parameters. Definition optional_values.f90:36 Check for problems return 0 if all check passed print diagnostics with log4f. Definition vol7d_class.F90:445 Reduce some dimensions (level and timerage) for semplification (rounding). Definition vol7d_class.F90:462 This module defines usefull general purpose function and subroutine. Definition array_utilities.F90:212 Definition of constants to be used for declaring variables of a desired type. Definition kinds.F90:245 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition optional_values.f90:28 Classe per la gestione dell'anagrafica di stazioni meteo e affini. Definition vol7d_ana_class.F90:212 Classe per la gestione di un volume completo di dati osservati. Definition vol7d_class.F90:273 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition vol7d_level_class.F90:213 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition vol7d_network_class.F90:214 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition vol7d_timerange_class.F90:215 Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var. Definition vol7d_varvect_class.f90:22 Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension... Definition vol7d_class.F90:312 |