libsim Versione 7.1.11
|
◆ vol7d_get_voldatir()
Crea una vista a dimensione ridotta di un volume di dati 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 :: vol2d(:,:)
...
CALL vol7d_get_voldatir(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
ENDIF
return
Definizione alla linea 3651 del file vol7d_class.F90. 3653! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3654! authors:
3655! Davide Cesari <dcesari@arpa.emr.it>
3656! Paolo Patruno <ppatruno@arpa.emr.it>
3657
3658! This program is free software; you can redistribute it and/or
3659! modify it under the terms of the GNU General Public License as
3660! published by the Free Software Foundation; either version 2 of
3661! the License, or (at your option) any later version.
3662
3663! This program is distributed in the hope that it will be useful,
3664! but WITHOUT ANY WARRANTY; without even the implied warranty of
3665! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3666! GNU General Public License for more details.
3667
3668! You should have received a copy of the GNU General Public License
3669! along with this program. If not, see <http://www.gnu.org/licenses/>.
3670#include "config.h"
3671
3683
3751IMPLICIT NONE
3752
3753
3754INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
3755 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
3756
3757INTEGER, PARAMETER :: vol7d_ana_a=1
3758INTEGER, PARAMETER :: vol7d_var_a=2
3759INTEGER, PARAMETER :: vol7d_network_a=3
3760INTEGER, PARAMETER :: vol7d_attr_a=4
3761INTEGER, PARAMETER :: vol7d_ana_d=1
3762INTEGER, PARAMETER :: vol7d_time_d=2
3763INTEGER, PARAMETER :: vol7d_level_d=3
3764INTEGER, PARAMETER :: vol7d_timerange_d=4
3765INTEGER, PARAMETER :: vol7d_var_d=5
3766INTEGER, PARAMETER :: vol7d_network_d=6
3767INTEGER, PARAMETER :: vol7d_attr_d=7
3768INTEGER, PARAMETER :: vol7d_cdatalen=32
3769
3770TYPE vol7d_varmap
3771 INTEGER :: r, d, i, b, c
3772END TYPE vol7d_varmap
3773
3778 TYPE(vol7d_ana),POINTER :: ana(:)
3780 TYPE(datetime),POINTER :: time(:)
3782 TYPE(vol7d_level),POINTER :: level(:)
3784 TYPE(vol7d_timerange),POINTER :: timerange(:)
3786 TYPE(vol7d_network),POINTER :: network(:)
3788 TYPE(vol7d_varvect) :: anavar
3790 TYPE(vol7d_varvect) :: anaattr
3792 TYPE(vol7d_varvect) :: anavarattr
3794 TYPE(vol7d_varvect) :: dativar
3796 TYPE(vol7d_varvect) :: datiattr
3798 TYPE(vol7d_varvect) :: dativarattr
3799
3801 REAL,POINTER :: volanar(:,:,:)
3803 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
3805 INTEGER,POINTER :: volanai(:,:,:)
3807 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
3809 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
3810
3812 REAL,POINTER :: volanaattrr(:,:,:,:)
3814 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
3816 INTEGER,POINTER :: volanaattri(:,:,:,:)
3818 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
3820 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
3821
3823 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
3825 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
3827 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
3829 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
3831 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
3832
3834 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
3836 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
3838 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
3840 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
3842 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
3843
3845 integer :: time_definition
3846
3848
3853 MODULE PROCEDURE vol7d_init
3854END INTERFACE
3855
3858 MODULE PROCEDURE vol7d_delete
3859END INTERFACE
3860
3863 MODULE PROCEDURE vol7d_write_on_file
3864END INTERFACE
3865
3867INTERFACE import
3868 MODULE PROCEDURE vol7d_read_from_file
3869END INTERFACE
3870
3873 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
3874END INTERFACE
3875
3878 MODULE PROCEDURE to_char_dat
3879END INTERFACE
3880
3883 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3884END INTERFACE
3885
3888 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
3889END INTERFACE
3890
3893 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
3894END INTERFACE
3895
3898 MODULE PROCEDURE vol7d_copy
3899END INTERFACE
3900
3903 MODULE PROCEDURE vol7d_c_e
3904END INTERFACE
3905
3910 MODULE PROCEDURE vol7d_check
3911END INTERFACE
3912
3927 MODULE PROCEDURE v7d_rounding
3928END INTERFACE
3929
3930!!$INTERFACE get_volana
3931!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
3932!!$ vol7d_get_volanab, vol7d_get_volanac
3933!!$END INTERFACE
3934!!$
3935!!$INTERFACE get_voldati
3936!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
3937!!$ vol7d_get_voldatib, vol7d_get_voldatic
3938!!$END INTERFACE
3939!!$
3940!!$INTERFACE get_volanaattr
3941!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
3942!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
3943!!$END INTERFACE
3944!!$
3945!!$INTERFACE get_voldatiattr
3946!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
3947!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
3948!!$END INTERFACE
3949
3950PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
3951 vol7d_get_volc, &
3952 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
3953 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
3954 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
3955 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
3956 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
3957 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
3958 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
3959 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
3960 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
3961 vol7d_display, dat_display, dat_vect_display, &
3962 to_char_dat, vol7d_check
3963
3964PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3965
3966PRIVATE vol7d_c_e
3967
3968CONTAINS
3969
3970
3975SUBROUTINE vol7d_init(this,time_definition)
3976TYPE(vol7d),intent(out) :: this
3977integer,INTENT(IN),OPTIONAL :: time_definition
3978
3985CALL vol7d_var_features_init() ! initialise var features table once
3986
3987NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
3988
3989NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
3990NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
3991NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
3992NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
3993NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
3994
3995if(present(time_definition)) then
3996 this%time_definition=time_definition
3997else
3998 this%time_definition=1 !default to validity time
3999end if
4000
4001END SUBROUTINE vol7d_init
4002
4003
4007ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
4008TYPE(vol7d),intent(inout) :: this
4009LOGICAL, INTENT(in), OPTIONAL :: dataonly
4010
4011
4012IF (.NOT. optio_log(dataonly)) THEN
4013 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
4014 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
4015 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
4016 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
4017 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
4018 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
4019 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
4020 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
4021 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
4022 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
4023ENDIF
4024IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
4025IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
4026IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
4027IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
4028IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
4029IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
4030IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
4031IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
4032IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
4033IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
4034
4035IF (.NOT. optio_log(dataonly)) THEN
4036 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4037 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4038ENDIF
4039IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4040IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4041IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4042
4043IF (.NOT. optio_log(dataonly)) THEN
4047ENDIF
4051
4052END SUBROUTINE vol7d_delete
4053
4054
4055
4056integer function vol7d_check(this)
4057TYPE(vol7d),intent(in) :: this
4058integer :: i,j,k,l,m,n
4059
4060vol7d_check=0
4061
4062if (associated(this%voldatii)) then
4063do i = 1,size(this%voldatii,1)
4064 do j = 1,size(this%voldatii,2)
4065 do k = 1,size(this%voldatii,3)
4066 do l = 1,size(this%voldatii,4)
4067 do m = 1,size(this%voldatii,5)
4068 do n = 1,size(this%voldatii,6)
4069 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4070 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4072 vol7d_check=1
4073 end if
4074 end do
4075 end do
4076 end do
4077 end do
4078 end do
4079end do
4080end if
4081
4082
4083if (associated(this%voldatir)) then
4084do i = 1,size(this%voldatir,1)
4085 do j = 1,size(this%voldatir,2)
4086 do k = 1,size(this%voldatir,3)
4087 do l = 1,size(this%voldatir,4)
4088 do m = 1,size(this%voldatir,5)
4089 do n = 1,size(this%voldatir,6)
4090 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4091 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4093 vol7d_check=2
4094 end if
4095 end do
4096 end do
4097 end do
4098 end do
4099 end do
4100end do
4101end if
4102
4103if (associated(this%voldatid)) then
4104do i = 1,size(this%voldatid,1)
4105 do j = 1,size(this%voldatid,2)
4106 do k = 1,size(this%voldatid,3)
4107 do l = 1,size(this%voldatid,4)
4108 do m = 1,size(this%voldatid,5)
4109 do n = 1,size(this%voldatid,6)
4110 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4111 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4113 vol7d_check=3
4114 end if
4115 end do
4116 end do
4117 end do
4118 end do
4119 end do
4120end do
4121end if
4122
4123if (associated(this%voldatib)) then
4124do i = 1,size(this%voldatib,1)
4125 do j = 1,size(this%voldatib,2)
4126 do k = 1,size(this%voldatib,3)
4127 do l = 1,size(this%voldatib,4)
4128 do m = 1,size(this%voldatib,5)
4129 do n = 1,size(this%voldatib,6)
4130 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4131 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4133 vol7d_check=4
4134 end if
4135 end do
4136 end do
4137 end do
4138 end do
4139 end do
4140end do
4141end if
4142
4143end function vol7d_check
4144
4145
4146
4147!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4149SUBROUTINE vol7d_display(this)
4150TYPE(vol7d),intent(in) :: this
4151integer :: i
4152
4153REAL :: rdat
4154DOUBLE PRECISION :: ddat
4155INTEGER :: idat
4156INTEGER(kind=int_b) :: bdat
4157CHARACTER(len=vol7d_cdatalen) :: cdat
4158
4159
4160print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4161if (this%time_definition == 0) then
4162 print*,"TIME DEFINITION: time is reference time"
4163else if (this%time_definition == 1) then
4164 print*,"TIME DEFINITION: time is validity time"
4165else
4166 print*,"Time definition have a wrong walue:", this%time_definition
4167end if
4168
4169IF (ASSOCIATED(this%network))then
4170 print*,"---- network vector ----"
4171 print*,"elements=",size(this%network)
4172 do i=1, size(this%network)
4174 end do
4175end IF
4176
4177IF (ASSOCIATED(this%ana))then
4178 print*,"---- ana vector ----"
4179 print*,"elements=",size(this%ana)
4180 do i=1, size(this%ana)
4182 end do
4183end IF
4184
4185IF (ASSOCIATED(this%time))then
4186 print*,"---- time vector ----"
4187 print*,"elements=",size(this%time)
4188 do i=1, size(this%time)
4190 end do
4191end if
4192
4193IF (ASSOCIATED(this%level)) then
4194 print*,"---- level vector ----"
4195 print*,"elements=",size(this%level)
4196 do i =1,size(this%level)
4198 end do
4199end if
4200
4201IF (ASSOCIATED(this%timerange))then
4202 print*,"---- timerange vector ----"
4203 print*,"elements=",size(this%timerange)
4204 do i =1,size(this%timerange)
4206 end do
4207end if
4208
4209
4210print*,"---- ana vector ----"
4211print*,""
4212print*,"->>>>>>>>> anavar -"
4214print*,""
4215print*,"->>>>>>>>> anaattr -"
4217print*,""
4218print*,"->>>>>>>>> anavarattr -"
4220
4221print*,"-- ana data section (first point) --"
4222
4223idat=imiss
4224rdat=rmiss
4225ddat=dmiss
4226bdat=ibmiss
4227cdat=cmiss
4228
4229!ntime = MIN(SIZE(this%time),nprint)
4230!ntimerange = MIN(SIZE(this%timerange),nprint)
4231!nlevel = MIN(SIZE(this%level),nprint)
4232!nnetwork = MIN(SIZE(this%network),nprint)
4233!nana = MIN(SIZE(this%ana),nprint)
4234
4235IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4236if (associated(this%volanai)) then
4237 do i=1,size(this%anavar%i)
4238 idat=this%volanai(1,i,1)
4240 end do
4241end if
4242idat=imiss
4243
4244if (associated(this%volanar)) then
4245 do i=1,size(this%anavar%r)
4246 rdat=this%volanar(1,i,1)
4248 end do
4249end if
4250rdat=rmiss
4251
4252if (associated(this%volanad)) then
4253 do i=1,size(this%anavar%d)
4254 ddat=this%volanad(1,i,1)
4256 end do
4257end if
4258ddat=dmiss
4259
4260if (associated(this%volanab)) then
4261 do i=1,size(this%anavar%b)
4262 bdat=this%volanab(1,i,1)
4264 end do
4265end if
4266bdat=ibmiss
4267
4268if (associated(this%volanac)) then
4269 do i=1,size(this%anavar%c)
4270 cdat=this%volanac(1,i,1)
4272 end do
4273end if
4274cdat=cmiss
4275ENDIF
4276
4277print*,"---- data vector ----"
4278print*,""
4279print*,"->>>>>>>>> dativar -"
4281print*,""
4282print*,"->>>>>>>>> datiattr -"
4284print*,""
4285print*,"->>>>>>>>> dativarattr -"
4287
4288print*,"-- data data section (first point) --"
4289
4290idat=imiss
4291rdat=rmiss
4292ddat=dmiss
4293bdat=ibmiss
4294cdat=cmiss
4295
4296IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4297 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4298if (associated(this%voldatii)) then
4299 do i=1,size(this%dativar%i)
4300 idat=this%voldatii(1,1,1,1,i,1)
4302 end do
4303end if
4304idat=imiss
4305
4306if (associated(this%voldatir)) then
4307 do i=1,size(this%dativar%r)
4308 rdat=this%voldatir(1,1,1,1,i,1)
4310 end do
4311end if
4312rdat=rmiss
4313
4314if (associated(this%voldatid)) then
4315 do i=1,size(this%dativar%d)
4316 ddat=this%voldatid(1,1,1,1,i,1)
4318 end do
4319end if
4320ddat=dmiss
4321
4322if (associated(this%voldatib)) then
4323 do i=1,size(this%dativar%b)
4324 bdat=this%voldatib(1,1,1,1,i,1)
4326 end do
4327end if
4328bdat=ibmiss
4329
4330if (associated(this%voldatic)) then
4331 do i=1,size(this%dativar%c)
4332 cdat=this%voldatic(1,1,1,1,i,1)
4334 end do
4335end if
4336cdat=cmiss
4337ENDIF
4338
4339print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4340
4341END SUBROUTINE vol7d_display
4342
4343
4345SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4346TYPE(vol7d_var),intent(in) :: this
4348REAL :: rdat
4350DOUBLE PRECISION :: ddat
4352INTEGER :: idat
4354INTEGER(kind=int_b) :: bdat
4356CHARACTER(len=*) :: cdat
4357
4358print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4359
4360end SUBROUTINE dat_display
4361
4363SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4364
4365TYPE(vol7d_var),intent(in) :: this(:)
4367REAL :: rdat(:)
4369DOUBLE PRECISION :: ddat(:)
4371INTEGER :: idat(:)
4373INTEGER(kind=int_b) :: bdat(:)
4375CHARACTER(len=*):: cdat(:)
4376
4377integer :: i
4378
4379do i =1,size(this)
4381end do
4382
4383end SUBROUTINE dat_vect_display
4384
4385
4386FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4387#ifdef HAVE_DBALLE
4388USE dballef
4389#endif
4390TYPE(vol7d_var),INTENT(in) :: this
4392REAL :: rdat
4394DOUBLE PRECISION :: ddat
4396INTEGER :: idat
4398INTEGER(kind=int_b) :: bdat
4400CHARACTER(len=*) :: cdat
4401CHARACTER(len=80) :: to_char_dat
4402
4403CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4404
4405
4406#ifdef HAVE_DBALLE
4407INTEGER :: handle, ier
4408
4409handle = 0
4410to_char_dat="VALUE: "
4411
4416
4418 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4419 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4420 ier = idba_fatto(handle)
4421 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4422endif
4423
4424#else
4425
4426to_char_dat="VALUE: "
4432
4433#endif
4434
4435END FUNCTION to_char_dat
4436
4437
4440FUNCTION vol7d_c_e(this) RESULT(c_e)
4441TYPE(vol7d), INTENT(in) :: this
4442
4443LOGICAL :: c_e
4444
4446 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
4447 ASSOCIATED(this%network) .OR. &
4448 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4449 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4450 ASSOCIATED(this%anavar%c) .OR. &
4451 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
4452 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
4453 ASSOCIATED(this%anaattr%c) .OR. &
4454 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4455 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4456 ASSOCIATED(this%dativar%c) .OR. &
4457 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
4458 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
4459 ASSOCIATED(this%datiattr%c)
4460
4461END FUNCTION vol7d_c_e
4462
4463
4502SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
4503 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4504 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4505 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4506 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4507 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4508 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
4509 ini)
4510TYPE(vol7d),INTENT(inout) :: this
4511INTEGER,INTENT(in),OPTIONAL :: nana
4512INTEGER,INTENT(in),OPTIONAL :: ntime
4513INTEGER,INTENT(in),OPTIONAL :: nlevel
4514INTEGER,INTENT(in),OPTIONAL :: ntimerange
4515INTEGER,INTENT(in),OPTIONAL :: nnetwork
4517INTEGER,INTENT(in),OPTIONAL :: &
4518 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4519 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4520 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4521 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4522 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4523 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
4524LOGICAL,INTENT(in),OPTIONAL :: ini
4525
4526INTEGER :: i
4527LOGICAL :: linit
4528
4529IF (PRESENT(ini)) THEN
4530 linit = ini
4531ELSE
4532 linit = .false.
4533ENDIF
4534
4535! Dimensioni principali
4536IF (PRESENT(nana)) THEN
4537 IF (nana >= 0) THEN
4538 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4539 ALLOCATE(this%ana(nana))
4540 IF (linit) THEN
4541 DO i = 1, nana
4543 ENDDO
4544 ENDIF
4545 ENDIF
4546ENDIF
4547IF (PRESENT(ntime)) THEN
4548 IF (ntime >= 0) THEN
4549 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4550 ALLOCATE(this%time(ntime))
4551 IF (linit) THEN
4552 DO i = 1, ntime
4554 ENDDO
4555 ENDIF
4556 ENDIF
4557ENDIF
4558IF (PRESENT(nlevel)) THEN
4559 IF (nlevel >= 0) THEN
4560 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4561 ALLOCATE(this%level(nlevel))
4562 IF (linit) THEN
4563 DO i = 1, nlevel
4565 ENDDO
4566 ENDIF
4567 ENDIF
4568ENDIF
4569IF (PRESENT(ntimerange)) THEN
4570 IF (ntimerange >= 0) THEN
4571 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4572 ALLOCATE(this%timerange(ntimerange))
4573 IF (linit) THEN
4574 DO i = 1, ntimerange
4576 ENDDO
4577 ENDIF
4578 ENDIF
4579ENDIF
4580IF (PRESENT(nnetwork)) THEN
4581 IF (nnetwork >= 0) THEN
4582 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4583 ALLOCATE(this%network(nnetwork))
4584 IF (linit) THEN
4585 DO i = 1, nnetwork
4587 ENDDO
4588 ENDIF
4589 ENDIF
4590ENDIF
4591! Dimensioni dei tipi delle variabili
4592CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
4593 nanavari, nanavarb, nanavarc, ini)
4594CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
4595 nanaattri, nanaattrb, nanaattrc, ini)
4596CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
4597 nanavarattri, nanavarattrb, nanavarattrc, ini)
4598CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
4599 ndativari, ndativarb, ndativarc, ini)
4600CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
4601 ndatiattri, ndatiattrb, ndatiattrc, ini)
4602CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
4603 ndativarattri, ndativarattrb, ndativarattrc, ini)
4604
4605END SUBROUTINE vol7d_alloc
4606
4607
4608FUNCTION vol7d_check_alloc_ana(this)
4609TYPE(vol7d),INTENT(in) :: this
4610LOGICAL :: vol7d_check_alloc_ana
4611
4612vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
4613
4614END FUNCTION vol7d_check_alloc_ana
4615
4616SUBROUTINE vol7d_force_alloc_ana(this, ini)
4617TYPE(vol7d),INTENT(inout) :: this
4618LOGICAL,INTENT(in),OPTIONAL :: ini
4619
4620! Alloco i descrittori minimi per avere un volume di anagrafica
4621IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
4622IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
4623
4624END SUBROUTINE vol7d_force_alloc_ana
4625
4626
4627FUNCTION vol7d_check_alloc_dati(this)
4628TYPE(vol7d),INTENT(in) :: this
4629LOGICAL :: vol7d_check_alloc_dati
4630
4631vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
4632 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
4633 ASSOCIATED(this%timerange)
4634
4635END FUNCTION vol7d_check_alloc_dati
4636
4637SUBROUTINE vol7d_force_alloc_dati(this, ini)
4638TYPE(vol7d),INTENT(inout) :: this
4639LOGICAL,INTENT(in),OPTIONAL :: ini
4640
4641! Alloco i descrittori minimi per avere un volume di dati
4642CALL vol7d_force_alloc_ana(this, ini)
4643IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
4644IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
4645IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
4646
4647END SUBROUTINE vol7d_force_alloc_dati
4648
4649
4650SUBROUTINE vol7d_force_alloc(this)
4651TYPE(vol7d),INTENT(inout) :: this
4652
4653! If anything really not allocated yet, allocate with size 0
4654IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
4655IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
4656IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
4657IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
4658IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
4659
4660END SUBROUTINE vol7d_force_alloc
4661
4662
4663FUNCTION vol7d_check_vol(this)
4664TYPE(vol7d),INTENT(in) :: this
4665LOGICAL :: vol7d_check_vol
4666
4667vol7d_check_vol = c_e(this)
4668
4669! Anagrafica
4670IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4671 vol7d_check_vol = .false.
4672ENDIF
4673
4674IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4675 vol7d_check_vol = .false.
4676ENDIF
4677
4678IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4679 vol7d_check_vol = .false.
4680ENDIF
4681
4682IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4683 vol7d_check_vol = .false.
4684ENDIF
4685
4686IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4687 vol7d_check_vol = .false.
4688ENDIF
4689IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4690 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4691 ASSOCIATED(this%anavar%c)) THEN
4692 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
4693ENDIF
4694
4695! Attributi dell'anagrafica
4696IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4697 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4698 vol7d_check_vol = .false.
4699ENDIF
4700
4701IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4702 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4703 vol7d_check_vol = .false.
4704ENDIF
4705
4706IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4707 .NOT.ASSOCIATED(this%volanaattri)) THEN
4708 vol7d_check_vol = .false.
4709ENDIF
4710
4711IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4712 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4713 vol7d_check_vol = .false.
4714ENDIF
4715
4716IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4717 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4718 vol7d_check_vol = .false.
4719ENDIF
4720
4721! Dati
4722IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4723 vol7d_check_vol = .false.
4724ENDIF
4725
4726IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4727 vol7d_check_vol = .false.
4728ENDIF
4729
4730IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4731 vol7d_check_vol = .false.
4732ENDIF
4733
4734IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4735 vol7d_check_vol = .false.
4736ENDIF
4737
4738IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4739 vol7d_check_vol = .false.
4740ENDIF
4741
4742! Attributi dei dati
4743IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4744 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4745 vol7d_check_vol = .false.
4746ENDIF
4747
4748IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4749 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4750 vol7d_check_vol = .false.
4751ENDIF
4752
4753IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4754 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4755 vol7d_check_vol = .false.
4756ENDIF
4757
4758IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4759 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4760 vol7d_check_vol = .false.
4761ENDIF
4762
4763IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4764 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4765 vol7d_check_vol = .false.
4766ENDIF
4767IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4768 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4769 ASSOCIATED(this%dativar%c)) THEN
4770 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
4771ENDIF
4772
4773END FUNCTION vol7d_check_vol
4774
4775
4790SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
4791TYPE(vol7d),INTENT(inout) :: this
4792LOGICAL,INTENT(in),OPTIONAL :: ini
4793LOGICAL,INTENT(in),OPTIONAL :: inivol
4794
4795LOGICAL :: linivol
4796
4797IF (PRESENT(inivol)) THEN
4798 linivol = inivol
4799ELSE
4800 linivol = .true.
4801ENDIF
4802
4803! Anagrafica
4804IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4805 CALL vol7d_force_alloc_ana(this, ini)
4806 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
4807 IF (linivol) this%volanar(:,:,:) = rmiss
4808ENDIF
4809
4810IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4811 CALL vol7d_force_alloc_ana(this, ini)
4812 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
4813 IF (linivol) this%volanad(:,:,:) = rdmiss
4814ENDIF
4815
4816IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4817 CALL vol7d_force_alloc_ana(this, ini)
4818 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
4819 IF (linivol) this%volanai(:,:,:) = imiss
4820ENDIF
4821
4822IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4823 CALL vol7d_force_alloc_ana(this, ini)
4824 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
4825 IF (linivol) this%volanab(:,:,:) = ibmiss
4826ENDIF
4827
4828IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4829 CALL vol7d_force_alloc_ana(this, ini)
4830 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
4831 IF (linivol) this%volanac(:,:,:) = cmiss
4832ENDIF
4833
4834! Attributi dell'anagrafica
4835IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4836 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4837 CALL vol7d_force_alloc_ana(this, ini)
4838 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
4839 SIZE(this%network), SIZE(this%anaattr%r)))
4840 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
4841ENDIF
4842
4843IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4844 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4845 CALL vol7d_force_alloc_ana(this, ini)
4846 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
4847 SIZE(this%network), SIZE(this%anaattr%d)))
4848 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
4849ENDIF
4850
4851IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4852 .NOT.ASSOCIATED(this%volanaattri)) THEN
4853 CALL vol7d_force_alloc_ana(this, ini)
4854 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
4855 SIZE(this%network), SIZE(this%anaattr%i)))
4856 IF (linivol) this%volanaattri(:,:,:,:) = imiss
4857ENDIF
4858
4859IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4860 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4861 CALL vol7d_force_alloc_ana(this, ini)
4862 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
4863 SIZE(this%network), SIZE(this%anaattr%b)))
4864 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
4865ENDIF
4866
4867IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4868 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4869 CALL vol7d_force_alloc_ana(this, ini)
4870 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
4871 SIZE(this%network), SIZE(this%anaattr%c)))
4872 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
4873ENDIF
4874
4875! Dati
4876IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4877 CALL vol7d_force_alloc_dati(this, ini)
4878 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4879 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
4880 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
4881ENDIF
4882
4883IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4884 CALL vol7d_force_alloc_dati(this, ini)
4885 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4886 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
4887 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
4888ENDIF
4889
4890IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4891 CALL vol7d_force_alloc_dati(this, ini)
4892 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4893 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
4894 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
4895ENDIF
4896
4897IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4898 CALL vol7d_force_alloc_dati(this, ini)
4899 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4900 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
4901 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
4902ENDIF
4903
4904IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4905 CALL vol7d_force_alloc_dati(this, ini)
4906 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4907 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
4908 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
4909ENDIF
4910
4911! Attributi dei dati
4912IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4913 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4914 CALL vol7d_force_alloc_dati(this, ini)
4915 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4916 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
4917 SIZE(this%datiattr%r)))
4918 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
4919ENDIF
4920
4921IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4922 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4923 CALL vol7d_force_alloc_dati(this, ini)
4924 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4925 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
4926 SIZE(this%datiattr%d)))
4927 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
4928ENDIF
4929
4930IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4931 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4932 CALL vol7d_force_alloc_dati(this, ini)
4933 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4934 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
4935 SIZE(this%datiattr%i)))
4936 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
4937ENDIF
4938
4939IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4940 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4941 CALL vol7d_force_alloc_dati(this, ini)
4942 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4943 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
4944 SIZE(this%datiattr%b)))
4945 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
4946ENDIF
4947
4948IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4949 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4950 CALL vol7d_force_alloc_dati(this, ini)
4951 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4952 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
4953 SIZE(this%datiattr%c)))
4954 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
4955ENDIF
4956
4957! Catch-all method
4958CALL vol7d_force_alloc(this)
4959
4960! Creo gli indici var-attr
4961
4962#ifdef DEBUG
4963CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
4964#endif
4965
4966CALL vol7d_set_attr_ind(this)
4967
4968
4969
4970END SUBROUTINE vol7d_alloc_vol
4971
4972
4979SUBROUTINE vol7d_set_attr_ind(this)
4980TYPE(vol7d),INTENT(inout) :: this
4981
4982INTEGER :: i
4983
4984! real
4985IF (ASSOCIATED(this%dativar%r)) THEN
4986 IF (ASSOCIATED(this%dativarattr%r)) THEN
4987 DO i = 1, SIZE(this%dativar%r)
4988 this%dativar%r(i)%r = &
4989 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
4990 ENDDO
4991 ENDIF
4992
4993 IF (ASSOCIATED(this%dativarattr%d)) THEN
4994 DO i = 1, SIZE(this%dativar%r)
4995 this%dativar%r(i)%d = &
4996 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
4997 ENDDO
4998 ENDIF
4999
5000 IF (ASSOCIATED(this%dativarattr%i)) THEN
5001 DO i = 1, SIZE(this%dativar%r)
5002 this%dativar%r(i)%i = &
5003 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
5004 ENDDO
5005 ENDIF
5006
5007 IF (ASSOCIATED(this%dativarattr%b)) THEN
5008 DO i = 1, SIZE(this%dativar%r)
5009 this%dativar%r(i)%b = &
5010 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
5011 ENDDO
5012 ENDIF
5013
5014 IF (ASSOCIATED(this%dativarattr%c)) THEN
5015 DO i = 1, SIZE(this%dativar%r)
5016 this%dativar%r(i)%c = &
5017 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
5018 ENDDO
5019 ENDIF
5020ENDIF
5021! double
5022IF (ASSOCIATED(this%dativar%d)) THEN
5023 IF (ASSOCIATED(this%dativarattr%r)) THEN
5024 DO i = 1, SIZE(this%dativar%d)
5025 this%dativar%d(i)%r = &
5026 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
5027 ENDDO
5028 ENDIF
5029
5030 IF (ASSOCIATED(this%dativarattr%d)) THEN
5031 DO i = 1, SIZE(this%dativar%d)
5032 this%dativar%d(i)%d = &
5033 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
5034 ENDDO
5035 ENDIF
5036
5037 IF (ASSOCIATED(this%dativarattr%i)) THEN
5038 DO i = 1, SIZE(this%dativar%d)
5039 this%dativar%d(i)%i = &
5040 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
5041 ENDDO
5042 ENDIF
5043
5044 IF (ASSOCIATED(this%dativarattr%b)) THEN
5045 DO i = 1, SIZE(this%dativar%d)
5046 this%dativar%d(i)%b = &
5047 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
5048 ENDDO
5049 ENDIF
5050
5051 IF (ASSOCIATED(this%dativarattr%c)) THEN
5052 DO i = 1, SIZE(this%dativar%d)
5053 this%dativar%d(i)%c = &
5054 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
5055 ENDDO
5056 ENDIF
5057ENDIF
5058! integer
5059IF (ASSOCIATED(this%dativar%i)) THEN
5060 IF (ASSOCIATED(this%dativarattr%r)) THEN
5061 DO i = 1, SIZE(this%dativar%i)
5062 this%dativar%i(i)%r = &
5063 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5064 ENDDO
5065 ENDIF
5066
5067 IF (ASSOCIATED(this%dativarattr%d)) THEN
5068 DO i = 1, SIZE(this%dativar%i)
5069 this%dativar%i(i)%d = &
5070 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5071 ENDDO
5072 ENDIF
5073
5074 IF (ASSOCIATED(this%dativarattr%i)) THEN
5075 DO i = 1, SIZE(this%dativar%i)
5076 this%dativar%i(i)%i = &
5077 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5078 ENDDO
5079 ENDIF
5080
5081 IF (ASSOCIATED(this%dativarattr%b)) THEN
5082 DO i = 1, SIZE(this%dativar%i)
5083 this%dativar%i(i)%b = &
5084 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5085 ENDDO
5086 ENDIF
5087
5088 IF (ASSOCIATED(this%dativarattr%c)) THEN
5089 DO i = 1, SIZE(this%dativar%i)
5090 this%dativar%i(i)%c = &
5091 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5092 ENDDO
5093 ENDIF
5094ENDIF
5095! byte
5096IF (ASSOCIATED(this%dativar%b)) THEN
5097 IF (ASSOCIATED(this%dativarattr%r)) THEN
5098 DO i = 1, SIZE(this%dativar%b)
5099 this%dativar%b(i)%r = &
5100 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5101 ENDDO
5102 ENDIF
5103
5104 IF (ASSOCIATED(this%dativarattr%d)) THEN
5105 DO i = 1, SIZE(this%dativar%b)
5106 this%dativar%b(i)%d = &
5107 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5108 ENDDO
5109 ENDIF
5110
5111 IF (ASSOCIATED(this%dativarattr%i)) THEN
5112 DO i = 1, SIZE(this%dativar%b)
5113 this%dativar%b(i)%i = &
5114 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5115 ENDDO
5116 ENDIF
5117
5118 IF (ASSOCIATED(this%dativarattr%b)) THEN
5119 DO i = 1, SIZE(this%dativar%b)
5120 this%dativar%b(i)%b = &
5121 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5122 ENDDO
5123 ENDIF
5124
5125 IF (ASSOCIATED(this%dativarattr%c)) THEN
5126 DO i = 1, SIZE(this%dativar%b)
5127 this%dativar%b(i)%c = &
5128 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5129 ENDDO
5130 ENDIF
5131ENDIF
5132! character
5133IF (ASSOCIATED(this%dativar%c)) THEN
5134 IF (ASSOCIATED(this%dativarattr%r)) THEN
5135 DO i = 1, SIZE(this%dativar%c)
5136 this%dativar%c(i)%r = &
5137 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5138 ENDDO
5139 ENDIF
5140
5141 IF (ASSOCIATED(this%dativarattr%d)) THEN
5142 DO i = 1, SIZE(this%dativar%c)
5143 this%dativar%c(i)%d = &
5144 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5145 ENDDO
5146 ENDIF
5147
5148 IF (ASSOCIATED(this%dativarattr%i)) THEN
5149 DO i = 1, SIZE(this%dativar%c)
5150 this%dativar%c(i)%i = &
5151 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5152 ENDDO
5153 ENDIF
5154
5155 IF (ASSOCIATED(this%dativarattr%b)) THEN
5156 DO i = 1, SIZE(this%dativar%c)
5157 this%dativar%c(i)%b = &
5158 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5159 ENDDO
5160 ENDIF
5161
5162 IF (ASSOCIATED(this%dativarattr%c)) THEN
5163 DO i = 1, SIZE(this%dativar%c)
5164 this%dativar%c(i)%c = &
5165 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5166 ENDDO
5167 ENDIF
5168ENDIF
5169
5170END SUBROUTINE vol7d_set_attr_ind
5171
5172
5177SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5178 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5179TYPE(vol7d),INTENT(INOUT) :: this
5180TYPE(vol7d),INTENT(INOUT) :: that
5181LOGICAL,INTENT(IN),OPTIONAL :: sort
5182LOGICAL,INTENT(in),OPTIONAL :: bestdata
5183LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5184
5185TYPE(vol7d) :: v7d_clean
5186
5187
5189 this = that
5191 that = v7d_clean ! destroy that without deallocating
5192ELSE ! Append that to this and destroy that
5194 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5196ENDIF
5197
5198END SUBROUTINE vol7d_merge
5199
5200
5229SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5230 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5231TYPE(vol7d),INTENT(INOUT) :: this
5232TYPE(vol7d),INTENT(IN) :: that
5233LOGICAL,INTENT(IN),OPTIONAL :: sort
5234! experimental, please do not use outside the library now, they force the use
5235! of a simplified mapping algorithm which is valid only whene the dimension
5236! content is the same in both volumes , or when one of them is empty
5237LOGICAL,INTENT(in),OPTIONAL :: bestdata
5238LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5239
5240
5241TYPE(vol7d) :: v7dtmp
5242LOGICAL :: lsort, lbestdata
5243INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5244 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5245
5247IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5250 RETURN
5251ENDIF
5252
5253IF (this%time_definition /= that%time_definition) THEN
5254 CALL l4f_log(l4f_fatal, &
5255 'in vol7d_append, cannot append volumes with different &
5256 &time definition')
5257 CALL raise_fatal_error()
5258ENDIF
5259
5260! Completo l'allocazione per avere volumi a norma
5261CALL vol7d_alloc_vol(this)
5262
5266
5267! Calcolo le mappature tra volumi vecchi e volume nuovo
5268! I puntatori remap* vengono tutti o allocati o nullificati
5269IF (optio_log(ltimesimple)) THEN
5270 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5271 lsort, remapt1, remapt2)
5272ELSE
5273 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5274 lsort, remapt1, remapt2)
5275ENDIF
5276IF (optio_log(ltimerangesimple)) THEN
5277 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5278 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5279ELSE
5280 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5281 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5282ENDIF
5283IF (optio_log(llevelsimple)) THEN
5284 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5285 lsort, remapl1, remapl2)
5286ELSE
5287 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5288 lsort, remapl1, remapl2)
5289ENDIF
5290IF (optio_log(lanasimple)) THEN
5291 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5292 .false., remapa1, remapa2)
5293ELSE
5294 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5295 .false., remapa1, remapa2)
5296ENDIF
5297IF (optio_log(lnetworksimple)) THEN
5298 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5299 .false., remapn1, remapn2)
5300ELSE
5301 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5302 .false., remapn1, remapn2)
5303ENDIF
5304
5305! Faccio la fusione fisica dei volumi
5306CALL vol7d_merge_finalr(this, that, v7dtmp, &
5307 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5308 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5309CALL vol7d_merge_finald(this, that, v7dtmp, &
5310 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5311 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5312CALL vol7d_merge_finali(this, that, v7dtmp, &
5313 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5314 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5315CALL vol7d_merge_finalb(this, that, v7dtmp, &
5316 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5317 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5318CALL vol7d_merge_finalc(this, that, v7dtmp, &
5319 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5320 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5321
5322! Dealloco i vettori di rimappatura
5323IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5324IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5325IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5326IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5327IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5328IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5329IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5330IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5331IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5332IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5333
5334! Distruggo il vecchio volume e assegno il nuovo a this
5336this = v7dtmp
5337! Ricreo gli indici var-attr
5338CALL vol7d_set_attr_ind(this)
5339
5340END SUBROUTINE vol7d_append
5341
5342
5375SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5376 lsort_time, lsort_timerange, lsort_level, &
5377 ltime, ltimerange, llevel, lana, lnetwork, &
5378 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5379 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5380 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5381 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5382 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5383 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5384TYPE(vol7d),INTENT(IN) :: this
5385TYPE(vol7d),INTENT(INOUT) :: that
5386LOGICAL,INTENT(IN),OPTIONAL :: sort
5387LOGICAL,INTENT(IN),OPTIONAL :: unique
5388LOGICAL,INTENT(IN),OPTIONAL :: miss
5389LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5390LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5391LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5399LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5401LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5403LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5405LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5407LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5409LOGICAL,INTENT(in),OPTIONAL :: &
5410 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5411 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5412 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5413 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5414 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5415 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5416
5417LOGICAL :: lsort, lunique, lmiss
5418INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5419
5422IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5423
5427
5428! Calcolo le mappature tra volume vecchio e volume nuovo
5429! I puntatori remap* vengono tutti o allocati o nullificati
5430CALL vol7d_remap1_datetime(this%time, that%time, &
5431 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
5432CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
5433 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
5434CALL vol7d_remap1_vol7d_level(this%level, that%level, &
5435 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
5436CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
5437 lsort, lunique, lmiss, remapa, lana)
5438CALL vol7d_remap1_vol7d_network(this%network, that%network, &
5439 lsort, lunique, lmiss, remapn, lnetwork)
5440
5441! lanavari, lanavarb, lanavarc, &
5442! lanaattri, lanaattrb, lanaattrc, &
5443! lanavarattri, lanavarattrb, lanavarattrc, &
5444! ldativari, ldativarb, ldativarc, &
5445! ldatiattri, ldatiattrb, ldatiattrc, &
5446! ldativarattri, ldativarattrb, ldativarattrc
5447! Faccio la riforma fisica dei volumi
5448CALL vol7d_reform_finalr(this, that, &
5449 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5450 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
5451CALL vol7d_reform_finald(this, that, &
5452 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5453 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
5454CALL vol7d_reform_finali(this, that, &
5455 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5456 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
5457CALL vol7d_reform_finalb(this, that, &
5458 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5459 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
5460CALL vol7d_reform_finalc(this, that, &
5461 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5462 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
5463
5464! Dealloco i vettori di rimappatura
5465IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
5466IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
5467IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
5468IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
5469IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
5470
5471! Ricreo gli indici var-attr
5472CALL vol7d_set_attr_ind(that)
5473that%time_definition = this%time_definition
5474
5475END SUBROUTINE vol7d_copy
5476
5477
5488SUBROUTINE vol7d_reform(this, sort, unique, miss, &
5489 lsort_time, lsort_timerange, lsort_level, &
5490 ltime, ltimerange, llevel, lana, lnetwork, &
5491 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5492 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5493 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5494 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5495 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5496 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
5497 ,purgeana)
5498TYPE(vol7d),INTENT(INOUT) :: this
5499LOGICAL,INTENT(IN),OPTIONAL :: sort
5500LOGICAL,INTENT(IN),OPTIONAL :: unique
5501LOGICAL,INTENT(IN),OPTIONAL :: miss
5502LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5503LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5504LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5512LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5513LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5514LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5515LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5516LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5518LOGICAL,INTENT(in),OPTIONAL :: &
5519 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5520 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5521 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5522 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5523 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5524 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5525LOGICAL,INTENT(IN),OPTIONAL :: purgeana
5526
5527TYPE(vol7d) :: v7dtmp
5528logical,allocatable :: llana(:)
5529integer :: i
5530
5532 lsort_time, lsort_timerange, lsort_level, &
5533 ltime, ltimerange, llevel, lana, lnetwork, &
5534 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5535 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5536 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5537 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5538 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5539 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5540
5541! destroy old volume
5543
5544if (optio_log(purgeana)) then
5545 allocate(llana(size(v7dtmp%ana)))
5546 llana =.false.
5547 do i =1,size(v7dtmp%ana)
5548 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
5549 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
5550 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
5551 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
5552 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
5553 end do
5554 CALL vol7d_copy(v7dtmp, this,lana=llana)
5556 deallocate(llana)
5557else
5558 this=v7dtmp
5559end if
5560
5561END SUBROUTINE vol7d_reform
5562
5563
5571SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
5572TYPE(vol7d),INTENT(INOUT) :: this
5573LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
5574LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
5575LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
5576
5577INTEGER :: i
5578LOGICAL :: to_be_sorted
5579
5580to_be_sorted = .false.
5581CALL vol7d_alloc_vol(this) ! usual safety check
5582
5583IF (optio_log(lsort_time)) THEN
5584 DO i = 2, SIZE(this%time)
5585 IF (this%time(i) < this%time(i-1)) THEN
5586 to_be_sorted = .true.
5587 EXIT
5588 ENDIF
5589 ENDDO
5590ENDIF
5591IF (optio_log(lsort_timerange)) THEN
5592 DO i = 2, SIZE(this%timerange)
5593 IF (this%timerange(i) < this%timerange(i-1)) THEN
5594 to_be_sorted = .true.
5595 EXIT
5596 ENDIF
5597 ENDDO
5598ENDIF
5599IF (optio_log(lsort_level)) THEN
5600 DO i = 2, SIZE(this%level)
5601 IF (this%level(i) < this%level(i-1)) THEN
5602 to_be_sorted = .true.
5603 EXIT
5604 ENDIF
5605 ENDDO
5606ENDIF
5607
5608IF (to_be_sorted) CALL vol7d_reform(this, &
5609 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
5610
5611END SUBROUTINE vol7d_smart_sort
5612
5620SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
5621TYPE(vol7d),INTENT(inout) :: this
5622CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
5623CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
5624TYPE(vol7d_network),OPTIONAL :: nl(:)
5625TYPE(datetime),INTENT(in),OPTIONAL :: s_d
5626TYPE(datetime),INTENT(in),OPTIONAL :: e_d
5627
5628INTEGER :: i
5629
5630IF (PRESENT(avl)) THEN
5631 IF (SIZE(avl) > 0) THEN
5632
5633 IF (ASSOCIATED(this%anavar%r)) THEN
5634 DO i = 1, SIZE(this%anavar%r)
5635 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
5636 ENDDO
5637 ENDIF
5638
5639 IF (ASSOCIATED(this%anavar%i)) THEN
5640 DO i = 1, SIZE(this%anavar%i)
5641 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
5642 ENDDO
5643 ENDIF
5644
5645 IF (ASSOCIATED(this%anavar%b)) THEN
5646 DO i = 1, SIZE(this%anavar%b)
5647 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
5648 ENDDO
5649 ENDIF
5650
5651 IF (ASSOCIATED(this%anavar%d)) THEN
5652 DO i = 1, SIZE(this%anavar%d)
5653 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
5654 ENDDO
5655 ENDIF
5656
5657 IF (ASSOCIATED(this%anavar%c)) THEN
5658 DO i = 1, SIZE(this%anavar%c)
5659 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
5660 ENDDO
5661 ENDIF
5662
5663 ENDIF
5664ENDIF
5665
5666
5667IF (PRESENT(vl)) THEN
5668 IF (size(vl) > 0) THEN
5669 IF (ASSOCIATED(this%dativar%r)) THEN
5670 DO i = 1, SIZE(this%dativar%r)
5671 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
5672 ENDDO
5673 ENDIF
5674
5675 IF (ASSOCIATED(this%dativar%i)) THEN
5676 DO i = 1, SIZE(this%dativar%i)
5677 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
5678 ENDDO
5679 ENDIF
5680
5681 IF (ASSOCIATED(this%dativar%b)) THEN
5682 DO i = 1, SIZE(this%dativar%b)
5683 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
5684 ENDDO
5685 ENDIF
5686
5687 IF (ASSOCIATED(this%dativar%d)) THEN
5688 DO i = 1, SIZE(this%dativar%d)
5689 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
5690 ENDDO
5691 ENDIF
5692
5693 IF (ASSOCIATED(this%dativar%c)) THEN
5694 DO i = 1, SIZE(this%dativar%c)
5695 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5696 ENDDO
5697 ENDIF
5698
5699 IF (ASSOCIATED(this%dativar%c)) THEN
5700 DO i = 1, SIZE(this%dativar%c)
5701 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5702 ENDDO
5703 ENDIF
5704
5705 ENDIF
5706ENDIF
5707
5708IF (PRESENT(nl)) THEN
5709 IF (SIZE(nl) > 0) THEN
5710 DO i = 1, SIZE(this%network)
5711 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
5712 ENDDO
5713 ENDIF
5714ENDIF
5715
5716IF (PRESENT(s_d)) THEN
5718 WHERE (this%time < s_d)
5719 this%time = datetime_miss
5720 END WHERE
5721 ENDIF
5722ENDIF
5723
5724IF (PRESENT(e_d)) THEN
5726 WHERE (this%time > e_d)
5727 this%time = datetime_miss
5728 END WHERE
5729 ENDIF
5730ENDIF
5731
5732CALL vol7d_reform(this, miss=.true.)
5733
5734END SUBROUTINE vol7d_filter
5735
5736
5743SUBROUTINE vol7d_convr(this, that, anaconv)
5744TYPE(vol7d),INTENT(IN) :: this
5745TYPE(vol7d),INTENT(INOUT) :: that
5746LOGICAL,OPTIONAL,INTENT(in) :: anaconv
5747INTEGER :: i
5748LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
5749TYPE(vol7d) :: v7d_tmp
5750
5751IF (optio_log(anaconv)) THEN
5752 acp=fv
5753 acn=tv
5754ELSE
5755 acp=tv
5756 acn=fv
5757ENDIF
5758
5759! Volume con solo i dati reali e tutti gli attributi
5760! l'anagrafica e` copiata interamente se necessario
5761CALL vol7d_copy(this, that, &
5762 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
5763 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
5764
5765! Volume solo di dati double
5766CALL vol7d_copy(this, v7d_tmp, &
5767 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
5768 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5769 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5770 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
5771 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5772 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5773
5774! converto a dati reali
5775IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
5776
5777 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
5778! alloco i dati reali e vi trasferisco i double
5779 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
5780 SIZE(v7d_tmp%volanad, 3)))
5781 DO i = 1, SIZE(v7d_tmp%anavar%d)
5782 v7d_tmp%volanar(:,i,:) = &
5783 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
5784 ENDDO
5785 DEALLOCATE(v7d_tmp%volanad)
5786! trasferisco le variabili
5787 v7d_tmp%anavar%r => v7d_tmp%anavar%d
5788 NULLIFY(v7d_tmp%anavar%d)
5789 ENDIF
5790
5791 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
5792! alloco i dati reali e vi trasferisco i double
5793 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
5794 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
5795 SIZE(v7d_tmp%voldatid, 6)))
5796 DO i = 1, SIZE(v7d_tmp%dativar%d)
5797 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5798 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
5799 ENDDO
5800 DEALLOCATE(v7d_tmp%voldatid)
5801! trasferisco le variabili
5802 v7d_tmp%dativar%r => v7d_tmp%dativar%d
5803 NULLIFY(v7d_tmp%dativar%d)
5804 ENDIF
5805
5806! fondo con il volume definitivo
5807 CALL vol7d_merge(that, v7d_tmp)
5808ELSE
5810ENDIF
5811
5812
5813! Volume solo di dati interi
5814CALL vol7d_copy(this, v7d_tmp, &
5815 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
5816 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5817 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5818 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
5819 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5820 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5821
5822! converto a dati reali
5823IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
5824
5825 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
5826! alloco i dati reali e vi trasferisco gli interi
5827 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
5828 SIZE(v7d_tmp%volanai, 3)))
5829 DO i = 1, SIZE(v7d_tmp%anavar%i)
5830 v7d_tmp%volanar(:,i,:) = &
5831 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
5832 ENDDO
5833 DEALLOCATE(v7d_tmp%volanai)
5834! trasferisco le variabili
5835 v7d_tmp%anavar%r => v7d_tmp%anavar%i
5836 NULLIFY(v7d_tmp%anavar%i)
5837 ENDIF
5838
5839 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
5840! alloco i dati reali e vi trasferisco gli interi
5841 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
5842 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
5843 SIZE(v7d_tmp%voldatii, 6)))
5844 DO i = 1, SIZE(v7d_tmp%dativar%i)
5845 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5846 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
5847 ENDDO
5848 DEALLOCATE(v7d_tmp%voldatii)
5849! trasferisco le variabili
5850 v7d_tmp%dativar%r => v7d_tmp%dativar%i
5851 NULLIFY(v7d_tmp%dativar%i)
5852 ENDIF
5853
5854! fondo con il volume definitivo
5855 CALL vol7d_merge(that, v7d_tmp)
5856ELSE
5858ENDIF
5859
5860
5861! Volume solo di dati byte
5862CALL vol7d_copy(this, v7d_tmp, &
5863 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
5864 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5865 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5866 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
5867 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5868 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5869
5870! converto a dati reali
5871IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
5872
5873 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
5874! alloco i dati reali e vi trasferisco i byte
5875 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
5876 SIZE(v7d_tmp%volanab, 3)))
5877 DO i = 1, SIZE(v7d_tmp%anavar%b)
5878 v7d_tmp%volanar(:,i,:) = &
5879 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
5880 ENDDO
5881 DEALLOCATE(v7d_tmp%volanab)
5882! trasferisco le variabili
5883 v7d_tmp%anavar%r => v7d_tmp%anavar%b
5884 NULLIFY(v7d_tmp%anavar%b)
5885 ENDIF
5886
5887 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
5888! alloco i dati reali e vi trasferisco i byte
5889 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
5890 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
5891 SIZE(v7d_tmp%voldatib, 6)))
5892 DO i = 1, SIZE(v7d_tmp%dativar%b)
5893 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5894 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
5895 ENDDO
5896 DEALLOCATE(v7d_tmp%voldatib)
5897! trasferisco le variabili
5898 v7d_tmp%dativar%r => v7d_tmp%dativar%b
5899 NULLIFY(v7d_tmp%dativar%b)
5900 ENDIF
5901
5902! fondo con il volume definitivo
5903 CALL vol7d_merge(that, v7d_tmp)
5904ELSE
5906ENDIF
5907
5908
5909! Volume solo di dati character
5910CALL vol7d_copy(this, v7d_tmp, &
5911 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
5912 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5913 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5914 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
5915 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5916 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5917
5918! converto a dati reali
5919IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
5920
5921 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
5922! alloco i dati reali e vi trasferisco i character
5923 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
5924 SIZE(v7d_tmp%volanac, 3)))
5925 DO i = 1, SIZE(v7d_tmp%anavar%c)
5926 v7d_tmp%volanar(:,i,:) = &
5927 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
5928 ENDDO
5929 DEALLOCATE(v7d_tmp%volanac)
5930! trasferisco le variabili
5931 v7d_tmp%anavar%r => v7d_tmp%anavar%c
5932 NULLIFY(v7d_tmp%anavar%c)
5933 ENDIF
5934
5935 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
5936! alloco i dati reali e vi trasferisco i character
5937 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
5938 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
5939 SIZE(v7d_tmp%voldatic, 6)))
5940 DO i = 1, SIZE(v7d_tmp%dativar%c)
5941 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5942 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
5943 ENDDO
5944 DEALLOCATE(v7d_tmp%voldatic)
5945! trasferisco le variabili
5946 v7d_tmp%dativar%r => v7d_tmp%dativar%c
5947 NULLIFY(v7d_tmp%dativar%c)
5948 ENDIF
5949
5950! fondo con il volume definitivo
5951 CALL vol7d_merge(that, v7d_tmp)
5952ELSE
5954ENDIF
5955
5956END SUBROUTINE vol7d_convr
5957
5958
5962SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
5963TYPE(vol7d),INTENT(IN) :: this
5964TYPE(vol7d),INTENT(OUT) :: that
5965logical , optional, intent(in) :: data_only
5966logical , optional, intent(in) :: ana
5967logical :: ldata_only,lana
5968
5969IF (PRESENT(data_only)) THEN
5970 ldata_only = data_only
5971ELSE
5972 ldata_only = .false.
5973ENDIF
5974
5975IF (PRESENT(ana)) THEN
5976 lana = ana
5977ELSE
5978 lana = .false.
5979ENDIF
5980
5981
5982#undef VOL7D_POLY_ARRAY
5983#define VOL7D_POLY_ARRAY voldati
5984#include "vol7d_class_diff.F90"
5985#undef VOL7D_POLY_ARRAY
5986#define VOL7D_POLY_ARRAY voldatiattr
5987#include "vol7d_class_diff.F90"
5988#undef VOL7D_POLY_ARRAY
5989
5990if ( .not. ldata_only) then
5991
5992#define VOL7D_POLY_ARRAY volana
5993#include "vol7d_class_diff.F90"
5994#undef VOL7D_POLY_ARRAY
5995#define VOL7D_POLY_ARRAY volanaattr
5996#include "vol7d_class_diff.F90"
5997#undef VOL7D_POLY_ARRAY
5998
5999 if(lana)then
6000 where ( this%ana == that%ana )
6001 that%ana = vol7d_ana_miss
6002 end where
6003 end if
6004
6005end if
6006
6007
6008
6009END SUBROUTINE vol7d_diff_only
6010
6011
6012
6013! Creo le routine da ripetere per i vari tipi di dati di v7d
6014! tramite un template e il preprocessore
6015#undef VOL7D_POLY_TYPE
6016#undef VOL7D_POLY_TYPES
6017#define VOL7D_POLY_TYPE REAL
6018#define VOL7D_POLY_TYPES r
6019#include "vol7d_class_type_templ.F90"
6020#undef VOL7D_POLY_TYPE
6021#undef VOL7D_POLY_TYPES
6022#define VOL7D_POLY_TYPE DOUBLE PRECISION
6023#define VOL7D_POLY_TYPES d
6024#include "vol7d_class_type_templ.F90"
6025#undef VOL7D_POLY_TYPE
6026#undef VOL7D_POLY_TYPES
6027#define VOL7D_POLY_TYPE INTEGER
6028#define VOL7D_POLY_TYPES i
6029#include "vol7d_class_type_templ.F90"
6030#undef VOL7D_POLY_TYPE
6031#undef VOL7D_POLY_TYPES
6032#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
6033#define VOL7D_POLY_TYPES b
6034#include "vol7d_class_type_templ.F90"
6035#undef VOL7D_POLY_TYPE
6036#undef VOL7D_POLY_TYPES
6037#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
6038#define VOL7D_POLY_TYPES c
6039#include "vol7d_class_type_templ.F90"
6040
6041! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
6042! tramite un template e il preprocessore
6043#define VOL7D_SORT
6044#undef VOL7D_NO_ZERO_ALLOC
6045#undef VOL7D_POLY_TYPE
6046#define VOL7D_POLY_TYPE datetime
6047#include "vol7d_class_desc_templ.F90"
6048#undef VOL7D_POLY_TYPE
6049#define VOL7D_POLY_TYPE vol7d_timerange
6050#include "vol7d_class_desc_templ.F90"
6051#undef VOL7D_POLY_TYPE
6052#define VOL7D_POLY_TYPE vol7d_level
6053#include "vol7d_class_desc_templ.F90"
6054#undef VOL7D_SORT
6055#undef VOL7D_POLY_TYPE
6056#define VOL7D_POLY_TYPE vol7d_network
6057#include "vol7d_class_desc_templ.F90"
6058#undef VOL7D_POLY_TYPE
6059#define VOL7D_POLY_TYPE vol7d_ana
6060#include "vol7d_class_desc_templ.F90"
6061#define VOL7D_NO_ZERO_ALLOC
6062#undef VOL7D_POLY_TYPE
6063#define VOL7D_POLY_TYPE vol7d_var
6064#include "vol7d_class_desc_templ.F90"
6065
6075subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6076
6077TYPE(vol7d),INTENT(IN) :: this
6078integer,optional,intent(inout) :: unit
6079character(len=*),intent(in),optional :: filename
6080character(len=*),intent(out),optional :: filename_auto
6081character(len=*),INTENT(IN),optional :: description
6082
6083integer :: lunit
6084character(len=254) :: ldescription,arg,lfilename
6085integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6086 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6087 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6088 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6089 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6090 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6091 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6092!integer :: im,id,iy
6093integer :: tarray(8)
6094logical :: opened,exist
6095
6096 nana=0
6097 ntime=0
6098 ntimerange=0
6099 nlevel=0
6100 nnetwork=0
6101 ndativarr=0
6102 ndativari=0
6103 ndativarb=0
6104 ndativard=0
6105 ndativarc=0
6106 ndatiattrr=0
6107 ndatiattri=0
6108 ndatiattrb=0
6109 ndatiattrd=0
6110 ndatiattrc=0
6111 ndativarattrr=0
6112 ndativarattri=0
6113 ndativarattrb=0
6114 ndativarattrd=0
6115 ndativarattrc=0
6116 nanavarr=0
6117 nanavari=0
6118 nanavarb=0
6119 nanavard=0
6120 nanavarc=0
6121 nanaattrr=0
6122 nanaattri=0
6123 nanaattrb=0
6124 nanaattrd=0
6125 nanaattrc=0
6126 nanavarattrr=0
6127 nanavarattri=0
6128 nanavarattrb=0
6129 nanavarattrd=0
6130 nanavarattrc=0
6131
6132
6133!call idate(im,id,iy)
6134call date_and_time(values=tarray)
6135call getarg(0,arg)
6136
6137if (present(description))then
6138 ldescription=description
6139else
6140 ldescription="Vol7d generated by: "//trim(arg)
6141end if
6142
6143if (.not. present(unit))then
6144 lunit=getunit()
6145else
6146 if (unit==0)then
6147 lunit=getunit()
6148 unit=lunit
6149 else
6150 lunit=unit
6151 end if
6152end if
6153
6154lfilename=trim(arg)//".v7d"
6156
6157if (present(filename))then
6158 if (filename /= "")then
6159 lfilename=filename
6160 end if
6161end if
6162
6163if (present(filename_auto))filename_auto=lfilename
6164
6165
6166inquire(unit=lunit,opened=opened)
6167if (.not. opened) then
6168! inquire(file=lfilename, EXIST=exist)
6169! IF (exist) THEN
6170! CALL l4f_log(L4F_FATAL, &
6171! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6172! CALL raise_fatal_error()
6173! ENDIF
6174 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6175 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6176end if
6177
6178if (associated(this%ana)) nana=size(this%ana)
6179if (associated(this%time)) ntime=size(this%time)
6180if (associated(this%timerange)) ntimerange=size(this%timerange)
6181if (associated(this%level)) nlevel=size(this%level)
6182if (associated(this%network)) nnetwork=size(this%network)
6183
6184if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6185if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6186if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6187if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6188if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6189
6190if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6191if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6192if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6193if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6194if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6195
6196if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6197if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6198if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6199if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6200if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6201
6202if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6203if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6204if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6205if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6206if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6207
6208if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6209if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6210if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6211if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6212if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6213
6214if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6215if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6216if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6217if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6218if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6219
6220write(unit=lunit)ldescription
6221write(unit=lunit)tarray
6222
6223write(unit=lunit)&
6224 nana, ntime, ntimerange, nlevel, nnetwork, &
6225 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6226 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6227 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6228 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6229 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6230 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6231 this%time_definition
6232
6233
6234!write(unit=lunit)this
6235
6236
6237!! prime 5 dimensioni
6240if (associated(this%level)) write(unit=lunit)this%level
6241if (associated(this%timerange)) write(unit=lunit)this%timerange
6242if (associated(this%network)) write(unit=lunit)this%network
6243
6244 !! 6a dimensione: variabile dell'anagrafica e dei dati
6245 !! con relativi attributi e in 5 tipi diversi
6246
6247if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6248if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6249if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6250if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6251if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6252
6253if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6254if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6255if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6256if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6257if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6258
6259if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6260if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6261if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6262if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6263if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6264
6265if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6266if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6267if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6268if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6269if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6270
6271if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6272if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6273if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6274if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6275if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6276
6277if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6278if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6279if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6280if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6281if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6282
6283!! Volumi di valori e attributi per anagrafica e dati
6284
6285if (associated(this%volanar)) write(unit=lunit)this%volanar
6286if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6287if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6288if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6289
6290if (associated(this%volanai)) write(unit=lunit)this%volanai
6291if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6292if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6293if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6294
6295if (associated(this%volanab)) write(unit=lunit)this%volanab
6296if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6297if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6298if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6299
6300if (associated(this%volanad)) write(unit=lunit)this%volanad
6301if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6302if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6303if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6304
6305if (associated(this%volanac)) write(unit=lunit)this%volanac
6306if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6307if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6308if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6309
6310if (.not. present(unit)) close(unit=lunit)
6311
6312end subroutine vol7d_write_on_file
6313
6314
6321
6322
6323subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6324
6325TYPE(vol7d),INTENT(OUT) :: this
6326integer,intent(inout),optional :: unit
6327character(len=*),INTENT(in),optional :: filename
6328character(len=*),intent(out),optional :: filename_auto
6329character(len=*),INTENT(out),optional :: description
6330integer,intent(out),optional :: tarray(8)
6331
6332
6333integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6334 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6335 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6336 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6337 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6338 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6339 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6340
6341character(len=254) :: ldescription,lfilename,arg
6342integer :: ltarray(8),lunit,ios
6343logical :: opened,exist
6344
6345
6346call getarg(0,arg)
6347
6348if (.not. present(unit))then
6349 lunit=getunit()
6350else
6351 if (unit==0)then
6352 lunit=getunit()
6353 unit=lunit
6354 else
6355 lunit=unit
6356 end if
6357end if
6358
6359lfilename=trim(arg)//".v7d"
6361
6362if (present(filename))then
6363 if (filename /= "")then
6364 lfilename=filename
6365 end if
6366end if
6367
6368if (present(filename_auto))filename_auto=lfilename
6369
6370
6371inquire(unit=lunit,opened=opened)
6372IF (.NOT. opened) THEN
6373 inquire(file=lfilename,exist=exist)
6374 IF (.NOT.exist) THEN
6375 CALL l4f_log(l4f_fatal, &
6376 'in vol7d_read_from_file, file does not exists, cannot open')
6377 CALL raise_fatal_error()
6378 ENDIF
6379 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6380 status='OLD', action='READ')
6381 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6382end if
6383
6384
6386read(unit=lunit,iostat=ios)ldescription
6387
6388if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6389 call vol7d_alloc (this)
6390 call vol7d_alloc_vol (this)
6391 if (present(description))description=ldescription
6392 if (present(tarray))tarray=ltarray
6393 if (.not. present(unit)) close(unit=lunit)
6394end if
6395
6396read(unit=lunit)ltarray
6397
6398CALL l4f_log(l4f_info, 'Reading vol7d from file')
6399CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6402
6403if (present(description))description=ldescription
6404if (present(tarray))tarray=ltarray
6405
6406read(unit=lunit)&
6407 nana, ntime, ntimerange, nlevel, nnetwork, &
6408 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6409 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6410 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6411 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6412 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6413 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6414 this%time_definition
6415
6416call vol7d_alloc (this, &
6417 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6418 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6419 ndativard=ndativard, ndativarc=ndativarc,&
6420 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6421 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6422 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6423 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6424 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6425 nanavard=nanavard, nanavarc=nanavarc,&
6426 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6427 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6428 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
6429 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
6430
6431
6434if (associated(this%level)) read(unit=lunit)this%level
6435if (associated(this%timerange)) read(unit=lunit)this%timerange
6436if (associated(this%network)) read(unit=lunit)this%network
6437
6438if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
6439if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
6440if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
6441if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
6442if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
6443
6444if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
6445if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
6446if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
6447if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
6448if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
6449
6450if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
6451if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
6452if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
6453if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
6454if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
6455
6456if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
6457if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
6458if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
6459if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
6460if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
6461
6462if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
6463if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
6464if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
6465if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
6466if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
6467
6468if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
6469if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
6470if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
6471if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
6472if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
6473
6474call vol7d_alloc_vol (this)
6475
6476!! Volumi di valori e attributi per anagrafica e dati
6477
6478if (associated(this%volanar)) read(unit=lunit)this%volanar
6479if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
6480if (associated(this%voldatir)) read(unit=lunit)this%voldatir
6481if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
6482
6483if (associated(this%volanai)) read(unit=lunit)this%volanai
6484if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
6485if (associated(this%voldatii)) read(unit=lunit)this%voldatii
6486if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
6487
6488if (associated(this%volanab)) read(unit=lunit)this%volanab
6489if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
6490if (associated(this%voldatib)) read(unit=lunit)this%voldatib
6491if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
6492
6493if (associated(this%volanad)) read(unit=lunit)this%volanad
6494if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
6495if (associated(this%voldatid)) read(unit=lunit)this%voldatid
6496if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
6497
6498if (associated(this%volanac)) read(unit=lunit)this%volanac
6499if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
6500if (associated(this%voldatic)) read(unit=lunit)this%voldatic
6501if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
6502
6503if (.not. present(unit)) close(unit=lunit)
6504
6505end subroutine vol7d_read_from_file
6506
6507
6508! to double precision
6509elemental doubleprecision function doubledatd(voldat,var)
6510doubleprecision,intent(in) :: voldat
6511type(vol7d_var),intent(in) :: var
6512
6513doubledatd=voldat
6514
6515end function doubledatd
6516
6517
6518elemental doubleprecision function doubledatr(voldat,var)
6519real,intent(in) :: voldat
6520type(vol7d_var),intent(in) :: var
6521
6523 doubledatr=dble(voldat)
6524else
6525 doubledatr=dmiss
6526end if
6527
6528end function doubledatr
6529
6530
6531elemental doubleprecision function doubledati(voldat,var)
6532integer,intent(in) :: voldat
6533type(vol7d_var),intent(in) :: var
6534
6537 doubledati=dble(voldat)/10.d0**var%scalefactor
6538 else
6539 doubledati=dble(voldat)
6540 endif
6541else
6542 doubledati=dmiss
6543end if
6544
6545end function doubledati
6546
6547
6548elemental doubleprecision function doubledatb(voldat,var)
6549integer(kind=int_b),intent(in) :: voldat
6550type(vol7d_var),intent(in) :: var
6551
6554 doubledatb=dble(voldat)/10.d0**var%scalefactor
6555 else
6556 doubledatb=dble(voldat)
6557 endif
6558else
6559 doubledatb=dmiss
6560end if
6561
6562end function doubledatb
6563
6564
6565elemental doubleprecision function doubledatc(voldat,var)
6566CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6567type(vol7d_var),intent(in) :: var
6568
6569doubledatc = c2d(voldat)
6571 doubledatc=doubledatc/10.d0**var%scalefactor
6572end if
6573
6574end function doubledatc
6575
6576
6577! to integer
6578elemental integer function integerdatd(voldat,var)
6579doubleprecision,intent(in) :: voldat
6580type(vol7d_var),intent(in) :: var
6581
6584 integerdatd=nint(voldat*10d0**var%scalefactor)
6585 else
6586 integerdatd=nint(voldat)
6587 endif
6588else
6589 integerdatd=imiss
6590end if
6591
6592end function integerdatd
6593
6594
6595elemental integer function integerdatr(voldat,var)
6596real,intent(in) :: voldat
6597type(vol7d_var),intent(in) :: var
6598
6601 integerdatr=nint(voldat*10d0**var%scalefactor)
6602 else
6603 integerdatr=nint(voldat)
6604 endif
6605else
6606 integerdatr=imiss
6607end if
6608
6609end function integerdatr
6610
6611
6612elemental integer function integerdati(voldat,var)
6613integer,intent(in) :: voldat
6614type(vol7d_var),intent(in) :: var
6615
6616integerdati=voldat
6617
6618end function integerdati
6619
6620
6621elemental integer function integerdatb(voldat,var)
6622integer(kind=int_b),intent(in) :: voldat
6623type(vol7d_var),intent(in) :: var
6624
6626 integerdatb=voldat
6627else
6628 integerdatb=imiss
6629end if
6630
6631end function integerdatb
6632
6633
6634elemental integer function integerdatc(voldat,var)
6635CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6636type(vol7d_var),intent(in) :: var
6637
6638integerdatc=c2i(voldat)
6639
6640end function integerdatc
6641
6642
6643! to real
6644elemental real function realdatd(voldat,var)
6645doubleprecision,intent(in) :: voldat
6646type(vol7d_var),intent(in) :: var
6647
6649 realdatd=real(voldat)
6650else
6651 realdatd=rmiss
6652end if
6653
6654end function realdatd
6655
6656
6657elemental real function realdatr(voldat,var)
6658real,intent(in) :: voldat
6659type(vol7d_var),intent(in) :: var
6660
6661realdatr=voldat
6662
6663end function realdatr
6664
6665
6666elemental real function realdati(voldat,var)
6667integer,intent(in) :: voldat
6668type(vol7d_var),intent(in) :: var
6669
6672 realdati=float(voldat)/10.**var%scalefactor
6673 else
6674 realdati=float(voldat)
6675 endif
6676else
6677 realdati=rmiss
6678end if
6679
6680end function realdati
6681
6682
6683elemental real function realdatb(voldat,var)
6684integer(kind=int_b),intent(in) :: voldat
6685type(vol7d_var),intent(in) :: var
6686
6689 realdatb=float(voldat)/10**var%scalefactor
6690 else
6691 realdatb=float(voldat)
6692 endif
6693else
6694 realdatb=rmiss
6695end if
6696
6697end function realdatb
6698
6699
6700elemental real function realdatc(voldat,var)
6701CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6702type(vol7d_var),intent(in) :: var
6703
6704realdatc=c2r(voldat)
6706 realdatc=realdatc/10.**var%scalefactor
6707end if
6708
6709end function realdatc
6710
6711
6717FUNCTION realanavol(this, var) RESULT(vol)
6718TYPE(vol7d),INTENT(in) :: this
6719TYPE(vol7d_var),INTENT(in) :: var
6720REAL :: vol(SIZE(this%ana),size(this%network))
6721
6722CHARACTER(len=1) :: dtype
6723INTEGER :: indvar
6724
6725dtype = cmiss
6726indvar = index(this%anavar, var, type=dtype)
6727
6728IF (indvar > 0) THEN
6729 SELECT CASE (dtype)
6730 CASE("d")
6731 vol = realdat(this%volanad(:,indvar,:), var)
6732 CASE("r")
6733 vol = this%volanar(:,indvar,:)
6734 CASE("i")
6735 vol = realdat(this%volanai(:,indvar,:), var)
6736 CASE("b")
6737 vol = realdat(this%volanab(:,indvar,:), var)
6738 CASE("c")
6739 vol = realdat(this%volanac(:,indvar,:), var)
6740 CASE default
6741 vol = rmiss
6742 END SELECT
6743ELSE
6744 vol = rmiss
6745ENDIF
6746
6747END FUNCTION realanavol
6748
6749
6755FUNCTION integeranavol(this, var) RESULT(vol)
6756TYPE(vol7d),INTENT(in) :: this
6757TYPE(vol7d_var),INTENT(in) :: var
6758INTEGER :: vol(SIZE(this%ana),size(this%network))
6759
6760CHARACTER(len=1) :: dtype
6761INTEGER :: indvar
6762
6763dtype = cmiss
6764indvar = index(this%anavar, var, type=dtype)
6765
6766IF (indvar > 0) THEN
6767 SELECT CASE (dtype)
6768 CASE("d")
6769 vol = integerdat(this%volanad(:,indvar,:), var)
6770 CASE("r")
6771 vol = integerdat(this%volanar(:,indvar,:), var)
6772 CASE("i")
6773 vol = this%volanai(:,indvar,:)
6774 CASE("b")
6775 vol = integerdat(this%volanab(:,indvar,:), var)
6776 CASE("c")
6777 vol = integerdat(this%volanac(:,indvar,:), var)
6778 CASE default
6779 vol = imiss
6780 END SELECT
6781ELSE
6782 vol = imiss
6783ENDIF
6784
6785END FUNCTION integeranavol
6786
6787
6793subroutine move_datac (v7d,&
6794 indana,indtime,indlevel,indtimerange,indnetwork,&
6795 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6796
6797TYPE(vol7d),intent(inout) :: v7d
6798
6799integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6800integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6801integer :: inddativar,inddativarattr
6802
6803
6804do inddativar=1,size(v7d%dativar%c)
6805
6807 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6808 ) then
6809
6810 ! dati
6811 v7d%voldatic &
6812 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6813 v7d%voldatic &
6814 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6815
6816
6817 ! attributi
6818 if (associated (v7d%dativarattr%i)) then
6819 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
6820 if (inddativarattr > 0 ) then
6821 v7d%voldatiattri &
6822 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6823 v7d%voldatiattri &
6824 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6825 end if
6826 end if
6827
6828 if (associated (v7d%dativarattr%r)) then
6829 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
6830 if (inddativarattr > 0 ) then
6831 v7d%voldatiattrr &
6832 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6833 v7d%voldatiattrr &
6834 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6835 end if
6836 end if
6837
6838 if (associated (v7d%dativarattr%d)) then
6839 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
6840 if (inddativarattr > 0 ) then
6841 v7d%voldatiattrd &
6842 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6843 v7d%voldatiattrd &
6844 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6845 end if
6846 end if
6847
6848 if (associated (v7d%dativarattr%b)) then
6849 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
6850 if (inddativarattr > 0 ) then
6851 v7d%voldatiattrb &
6852 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6853 v7d%voldatiattrb &
6854 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6855 end if
6856 end if
6857
6858 if (associated (v7d%dativarattr%c)) then
6859 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
6860 if (inddativarattr > 0 ) then
6861 v7d%voldatiattrc &
6862 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6863 v7d%voldatiattrc &
6864 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6865 end if
6866 end if
6867
6868 end if
6869
6870end do
6871
6872end subroutine move_datac
6873
6879subroutine move_datar (v7d,&
6880 indana,indtime,indlevel,indtimerange,indnetwork,&
6881 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6882
6883TYPE(vol7d),intent(inout) :: v7d
6884
6885integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6886integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6887integer :: inddativar,inddativarattr
6888
6889
6890do inddativar=1,size(v7d%dativar%r)
6891
6893 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6894 ) then
6895
6896 ! dati
6897 v7d%voldatir &
6898 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6899 v7d%voldatir &
6900 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6901
6902
6903 ! attributi
6904 if (associated (v7d%dativarattr%i)) then
6905 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
6906 if (inddativarattr > 0 ) then
6907 v7d%voldatiattri &
6908 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6909 v7d%voldatiattri &
6910 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6911 end if
6912 end if
6913
6914 if (associated (v7d%dativarattr%r)) then
6915 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
6916 if (inddativarattr > 0 ) then
6917 v7d%voldatiattrr &
6918 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6919 v7d%voldatiattrr &
6920 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6921 end if
6922 end if
6923
6924 if (associated (v7d%dativarattr%d)) then
6925 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
6926 if (inddativarattr > 0 ) then
6927 v7d%voldatiattrd &
6928 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6929 v7d%voldatiattrd &
6930 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6931 end if
6932 end if
6933
6934 if (associated (v7d%dativarattr%b)) then
6935 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
6936 if (inddativarattr > 0 ) then
6937 v7d%voldatiattrb &
6938 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6939 v7d%voldatiattrb &
6940 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6941 end if
6942 end if
6943
6944 if (associated (v7d%dativarattr%c)) then
6945 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
6946 if (inddativarattr > 0 ) then
6947 v7d%voldatiattrc &
6948 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6949 v7d%voldatiattrc &
6950 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6951 end if
6952 end if
6953
6954 end if
6955
6956end do
6957
6958end subroutine move_datar
6959
6960
6974subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
6975type(vol7d),intent(inout) :: v7din
6976type(vol7d),intent(out) :: v7dout
6977type(vol7d_level),intent(in),optional :: level(:)
6978type(vol7d_timerange),intent(in),optional :: timerange(:)
6979!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
6980!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
6981logical,intent(in),optional :: nostatproc
6982
6983integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
6984integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
6985type(vol7d_level) :: roundlevel(size(v7din%level))
6986type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
6987type(vol7d) :: v7d_tmp
6988
6989
6990nbin=0
6991
6992if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
6993if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
6994if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
6995if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
6996
6998
6999roundlevel=v7din%level
7000
7001if (present(level))then
7002 do ilevel = 1, size(v7din%level)
7003 if ((any(v7din%level(ilevel) .almosteq. level))) then
7004 roundlevel(ilevel)=level(1)
7005 end if
7006 end do
7007end if
7008
7009roundtimerange=v7din%timerange
7010
7011if (present(timerange))then
7012 do itimerange = 1, size(v7din%timerange)
7013 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
7014 roundtimerange(itimerange)=timerange(1)
7015 end if
7016 end do
7017end if
7018
7019!set istantaneous values everywere
7020!preserve p1 for forecast time
7021if (optio_log(nostatproc)) then
7022 roundtimerange(:)%timerange=254
7023 roundtimerange(:)%p2=0
7024end if
7025
7026
7027nana=size(v7din%ana)
7028nlevel=count_distinct(roundlevel,back=.true.)
7029ntime=size(v7din%time)
7030ntimerange=count_distinct(roundtimerange,back=.true.)
7031nnetwork=size(v7din%network)
7032
7034
7035if (nbin == 0) then
7037else
7038 call vol7d_convr(v7din,v7d_tmp)
7039end if
7040
7041v7d_tmp%level=roundlevel
7042v7d_tmp%timerange=roundtimerange
7043
7044do ilevel=1, size(v7d_tmp%level)
7045 indl=index(v7d_tmp%level,roundlevel(ilevel))
7046 do itimerange=1,size(v7d_tmp%timerange)
7047 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
7048
7049 if (indl /= ilevel .or. indt /= itimerange) then
7050
7051 do iana=1, nana
7052 do itime=1,ntime
7053 do inetwork=1,nnetwork
7054
7055 if (nbin > 0) then
7056 call move_datar (v7d_tmp,&
7057 iana,itime,ilevel,itimerange,inetwork,&
7058 iana,itime,indl,indt,inetwork)
7059 else
7060 call move_datac (v7d_tmp,&
7061 iana,itime,ilevel,itimerange,inetwork,&
7062 iana,itime,indl,indt,inetwork)
7063 end if
7064
7065 end do
7066 end do
7067 end do
7068
7069 end if
7070
7071 end do
7072end do
7073
7074! set to missing level and time > nlevel
7075do ilevel=nlevel+1,size(v7d_tmp%level)
7077end do
7078
7079do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7081end do
7082
7083!copy with remove
7086
7087!call display(v7dout)
7088
7089end subroutine v7d_rounding
7090
7091
7093
7099
7100
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition: char_utilities.F90:284 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:484 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:491 Generic subroutine for checking OPTIONAL parameters. Definition: optional_values.f90:36 Check for problems return 0 if all check passed print diagnostics with log4f. Definition: vol7d_class.F90:451 Reduce some dimensions (level and timerage) for semplification (rounding). Definition: vol7d_class.F90:468 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:218 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Classe per la gestione dell'anagrafica di stazioni meteo e affini. Definition: vol7d_ana_class.F90:218 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:219 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition: vol7d_network_class.F90:220 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition: vol7d_timerange_class.F90:221 Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var. Definition: vol7d_varvect_class.f90:22 Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension... Definition: vol7d_class.F90:318 |