libsim Versione 7.1.11
|
◆ vol7d_get_voldatiattrr()
Crea una vista a dimensione ridotta di un volume di attributi 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_voldatiattrr(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
ENDIF
return
Definizione alla linea 3707 del file vol7d_class.F90. 3709! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
3710! authors:
3711! Davide Cesari <dcesari@arpa.emr.it>
3712! Paolo Patruno <ppatruno@arpa.emr.it>
3713
3714! This program is free software; you can redistribute it and/or
3715! modify it under the terms of the GNU General Public License as
3716! published by the Free Software Foundation; either version 2 of
3717! the License, or (at your option) any later version.
3718
3719! This program is distributed in the hope that it will be useful,
3720! but WITHOUT ANY WARRANTY; without even the implied warranty of
3721! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
3722! GNU General Public License for more details.
3723
3724! You should have received a copy of the GNU General Public License
3725! along with this program. If not, see <http://www.gnu.org/licenses/>.
3726#include "config.h"
3727
3739
3807IMPLICIT NONE
3808
3809
3810INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
3811 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
3812
3813INTEGER, PARAMETER :: vol7d_ana_a=1
3814INTEGER, PARAMETER :: vol7d_var_a=2
3815INTEGER, PARAMETER :: vol7d_network_a=3
3816INTEGER, PARAMETER :: vol7d_attr_a=4
3817INTEGER, PARAMETER :: vol7d_ana_d=1
3818INTEGER, PARAMETER :: vol7d_time_d=2
3819INTEGER, PARAMETER :: vol7d_level_d=3
3820INTEGER, PARAMETER :: vol7d_timerange_d=4
3821INTEGER, PARAMETER :: vol7d_var_d=5
3822INTEGER, PARAMETER :: vol7d_network_d=6
3823INTEGER, PARAMETER :: vol7d_attr_d=7
3824INTEGER, PARAMETER :: vol7d_cdatalen=32
3825
3826TYPE vol7d_varmap
3827 INTEGER :: r, d, i, b, c
3828END TYPE vol7d_varmap
3829
3834 TYPE(vol7d_ana),POINTER :: ana(:)
3836 TYPE(datetime),POINTER :: time(:)
3838 TYPE(vol7d_level),POINTER :: level(:)
3840 TYPE(vol7d_timerange),POINTER :: timerange(:)
3842 TYPE(vol7d_network),POINTER :: network(:)
3844 TYPE(vol7d_varvect) :: anavar
3846 TYPE(vol7d_varvect) :: anaattr
3848 TYPE(vol7d_varvect) :: anavarattr
3850 TYPE(vol7d_varvect) :: dativar
3852 TYPE(vol7d_varvect) :: datiattr
3854 TYPE(vol7d_varvect) :: dativarattr
3855
3857 REAL,POINTER :: volanar(:,:,:)
3859 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
3861 INTEGER,POINTER :: volanai(:,:,:)
3863 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
3865 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
3866
3868 REAL,POINTER :: volanaattrr(:,:,:,:)
3870 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
3872 INTEGER,POINTER :: volanaattri(:,:,:,:)
3874 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
3876 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
3877
3879 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
3881 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
3883 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
3885 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
3887 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
3888
3890 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
3892 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
3894 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
3896 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
3898 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
3899
3901 integer :: time_definition
3902
3904
3909 MODULE PROCEDURE vol7d_init
3910END INTERFACE
3911
3914 MODULE PROCEDURE vol7d_delete
3915END INTERFACE
3916
3919 MODULE PROCEDURE vol7d_write_on_file
3920END INTERFACE
3921
3923INTERFACE import
3924 MODULE PROCEDURE vol7d_read_from_file
3925END INTERFACE
3926
3929 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
3930END INTERFACE
3931
3934 MODULE PROCEDURE to_char_dat
3935END INTERFACE
3936
3939 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
3940END INTERFACE
3941
3944 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
3945END INTERFACE
3946
3949 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
3950END INTERFACE
3951
3954 MODULE PROCEDURE vol7d_copy
3955END INTERFACE
3956
3959 MODULE PROCEDURE vol7d_c_e
3960END INTERFACE
3961
3966 MODULE PROCEDURE vol7d_check
3967END INTERFACE
3968
3983 MODULE PROCEDURE v7d_rounding
3984END INTERFACE
3985
3986!!$INTERFACE get_volana
3987!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
3988!!$ vol7d_get_volanab, vol7d_get_volanac
3989!!$END INTERFACE
3990!!$
3991!!$INTERFACE get_voldati
3992!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
3993!!$ vol7d_get_voldatib, vol7d_get_voldatic
3994!!$END INTERFACE
3995!!$
3996!!$INTERFACE get_volanaattr
3997!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
3998!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
3999!!$END INTERFACE
4000!!$
4001!!$INTERFACE get_voldatiattr
4002!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
4003!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
4004!!$END INTERFACE
4005
4006PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
4007 vol7d_get_volc, &
4008 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
4009 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
4010 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
4011 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
4012 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
4013 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
4014 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
4015 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
4016 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
4017 vol7d_display, dat_display, dat_vect_display, &
4018 to_char_dat, vol7d_check
4019
4020PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4021
4022PRIVATE vol7d_c_e
4023
4024CONTAINS
4025
4026
4031SUBROUTINE vol7d_init(this,time_definition)
4032TYPE(vol7d),intent(out) :: this
4033integer,INTENT(IN),OPTIONAL :: time_definition
4034
4041CALL vol7d_var_features_init() ! initialise var features table once
4042
4043NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
4044
4045NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
4046NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
4047NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
4048NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
4049NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
4050
4051if(present(time_definition)) then
4052 this%time_definition=time_definition
4053else
4054 this%time_definition=1 !default to validity time
4055end if
4056
4057END SUBROUTINE vol7d_init
4058
4059
4063ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
4064TYPE(vol7d),intent(inout) :: this
4065LOGICAL, INTENT(in), OPTIONAL :: dataonly
4066
4067
4068IF (.NOT. optio_log(dataonly)) THEN
4069 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
4070 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
4071 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
4072 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
4073 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
4074 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
4075 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
4076 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
4077 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
4078 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
4079ENDIF
4080IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
4081IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
4082IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
4083IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
4084IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
4085IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
4086IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
4087IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
4088IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
4089IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
4090
4091IF (.NOT. optio_log(dataonly)) THEN
4092 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4093 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4094ENDIF
4095IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4096IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4097IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4098
4099IF (.NOT. optio_log(dataonly)) THEN
4103ENDIF
4107
4108END SUBROUTINE vol7d_delete
4109
4110
4111
4112integer function vol7d_check(this)
4113TYPE(vol7d),intent(in) :: this
4114integer :: i,j,k,l,m,n
4115
4116vol7d_check=0
4117
4118if (associated(this%voldatii)) then
4119do i = 1,size(this%voldatii,1)
4120 do j = 1,size(this%voldatii,2)
4121 do k = 1,size(this%voldatii,3)
4122 do l = 1,size(this%voldatii,4)
4123 do m = 1,size(this%voldatii,5)
4124 do n = 1,size(this%voldatii,6)
4125 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4126 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4128 vol7d_check=1
4129 end if
4130 end do
4131 end do
4132 end do
4133 end do
4134 end do
4135end do
4136end if
4137
4138
4139if (associated(this%voldatir)) then
4140do i = 1,size(this%voldatir,1)
4141 do j = 1,size(this%voldatir,2)
4142 do k = 1,size(this%voldatir,3)
4143 do l = 1,size(this%voldatir,4)
4144 do m = 1,size(this%voldatir,5)
4145 do n = 1,size(this%voldatir,6)
4146 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4147 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4149 vol7d_check=2
4150 end if
4151 end do
4152 end do
4153 end do
4154 end do
4155 end do
4156end do
4157end if
4158
4159if (associated(this%voldatid)) then
4160do i = 1,size(this%voldatid,1)
4161 do j = 1,size(this%voldatid,2)
4162 do k = 1,size(this%voldatid,3)
4163 do l = 1,size(this%voldatid,4)
4164 do m = 1,size(this%voldatid,5)
4165 do n = 1,size(this%voldatid,6)
4166 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4167 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4169 vol7d_check=3
4170 end if
4171 end do
4172 end do
4173 end do
4174 end do
4175 end do
4176end do
4177end if
4178
4179if (associated(this%voldatib)) then
4180do i = 1,size(this%voldatib,1)
4181 do j = 1,size(this%voldatib,2)
4182 do k = 1,size(this%voldatib,3)
4183 do l = 1,size(this%voldatib,4)
4184 do m = 1,size(this%voldatib,5)
4185 do n = 1,size(this%voldatib,6)
4186 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4187 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4189 vol7d_check=4
4190 end if
4191 end do
4192 end do
4193 end do
4194 end do
4195 end do
4196end do
4197end if
4198
4199end function vol7d_check
4200
4201
4202
4203!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4205SUBROUTINE vol7d_display(this)
4206TYPE(vol7d),intent(in) :: this
4207integer :: i
4208
4209REAL :: rdat
4210DOUBLE PRECISION :: ddat
4211INTEGER :: idat
4212INTEGER(kind=int_b) :: bdat
4213CHARACTER(len=vol7d_cdatalen) :: cdat
4214
4215
4216print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4217if (this%time_definition == 0) then
4218 print*,"TIME DEFINITION: time is reference time"
4219else if (this%time_definition == 1) then
4220 print*,"TIME DEFINITION: time is validity time"
4221else
4222 print*,"Time definition have a wrong walue:", this%time_definition
4223end if
4224
4225IF (ASSOCIATED(this%network))then
4226 print*,"---- network vector ----"
4227 print*,"elements=",size(this%network)
4228 do i=1, size(this%network)
4230 end do
4231end IF
4232
4233IF (ASSOCIATED(this%ana))then
4234 print*,"---- ana vector ----"
4235 print*,"elements=",size(this%ana)
4236 do i=1, size(this%ana)
4238 end do
4239end IF
4240
4241IF (ASSOCIATED(this%time))then
4242 print*,"---- time vector ----"
4243 print*,"elements=",size(this%time)
4244 do i=1, size(this%time)
4246 end do
4247end if
4248
4249IF (ASSOCIATED(this%level)) then
4250 print*,"---- level vector ----"
4251 print*,"elements=",size(this%level)
4252 do i =1,size(this%level)
4254 end do
4255end if
4256
4257IF (ASSOCIATED(this%timerange))then
4258 print*,"---- timerange vector ----"
4259 print*,"elements=",size(this%timerange)
4260 do i =1,size(this%timerange)
4262 end do
4263end if
4264
4265
4266print*,"---- ana vector ----"
4267print*,""
4268print*,"->>>>>>>>> anavar -"
4270print*,""
4271print*,"->>>>>>>>> anaattr -"
4273print*,""
4274print*,"->>>>>>>>> anavarattr -"
4276
4277print*,"-- ana data section (first point) --"
4278
4279idat=imiss
4280rdat=rmiss
4281ddat=dmiss
4282bdat=ibmiss
4283cdat=cmiss
4284
4285!ntime = MIN(SIZE(this%time),nprint)
4286!ntimerange = MIN(SIZE(this%timerange),nprint)
4287!nlevel = MIN(SIZE(this%level),nprint)
4288!nnetwork = MIN(SIZE(this%network),nprint)
4289!nana = MIN(SIZE(this%ana),nprint)
4290
4291IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4292if (associated(this%volanai)) then
4293 do i=1,size(this%anavar%i)
4294 idat=this%volanai(1,i,1)
4296 end do
4297end if
4298idat=imiss
4299
4300if (associated(this%volanar)) then
4301 do i=1,size(this%anavar%r)
4302 rdat=this%volanar(1,i,1)
4304 end do
4305end if
4306rdat=rmiss
4307
4308if (associated(this%volanad)) then
4309 do i=1,size(this%anavar%d)
4310 ddat=this%volanad(1,i,1)
4312 end do
4313end if
4314ddat=dmiss
4315
4316if (associated(this%volanab)) then
4317 do i=1,size(this%anavar%b)
4318 bdat=this%volanab(1,i,1)
4320 end do
4321end if
4322bdat=ibmiss
4323
4324if (associated(this%volanac)) then
4325 do i=1,size(this%anavar%c)
4326 cdat=this%volanac(1,i,1)
4328 end do
4329end if
4330cdat=cmiss
4331ENDIF
4332
4333print*,"---- data vector ----"
4334print*,""
4335print*,"->>>>>>>>> dativar -"
4337print*,""
4338print*,"->>>>>>>>> datiattr -"
4340print*,""
4341print*,"->>>>>>>>> dativarattr -"
4343
4344print*,"-- data data section (first point) --"
4345
4346idat=imiss
4347rdat=rmiss
4348ddat=dmiss
4349bdat=ibmiss
4350cdat=cmiss
4351
4352IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4353 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4354if (associated(this%voldatii)) then
4355 do i=1,size(this%dativar%i)
4356 idat=this%voldatii(1,1,1,1,i,1)
4358 end do
4359end if
4360idat=imiss
4361
4362if (associated(this%voldatir)) then
4363 do i=1,size(this%dativar%r)
4364 rdat=this%voldatir(1,1,1,1,i,1)
4366 end do
4367end if
4368rdat=rmiss
4369
4370if (associated(this%voldatid)) then
4371 do i=1,size(this%dativar%d)
4372 ddat=this%voldatid(1,1,1,1,i,1)
4374 end do
4375end if
4376ddat=dmiss
4377
4378if (associated(this%voldatib)) then
4379 do i=1,size(this%dativar%b)
4380 bdat=this%voldatib(1,1,1,1,i,1)
4382 end do
4383end if
4384bdat=ibmiss
4385
4386if (associated(this%voldatic)) then
4387 do i=1,size(this%dativar%c)
4388 cdat=this%voldatic(1,1,1,1,i,1)
4390 end do
4391end if
4392cdat=cmiss
4393ENDIF
4394
4395print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4396
4397END SUBROUTINE vol7d_display
4398
4399
4401SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4402TYPE(vol7d_var),intent(in) :: this
4404REAL :: rdat
4406DOUBLE PRECISION :: ddat
4408INTEGER :: idat
4410INTEGER(kind=int_b) :: bdat
4412CHARACTER(len=*) :: cdat
4413
4414print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4415
4416end SUBROUTINE dat_display
4417
4419SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4420
4421TYPE(vol7d_var),intent(in) :: this(:)
4423REAL :: rdat(:)
4425DOUBLE PRECISION :: ddat(:)
4427INTEGER :: idat(:)
4429INTEGER(kind=int_b) :: bdat(:)
4431CHARACTER(len=*):: cdat(:)
4432
4433integer :: i
4434
4435do i =1,size(this)
4437end do
4438
4439end SUBROUTINE dat_vect_display
4440
4441
4442FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4443#ifdef HAVE_DBALLE
4444USE dballef
4445#endif
4446TYPE(vol7d_var),INTENT(in) :: this
4448REAL :: rdat
4450DOUBLE PRECISION :: ddat
4452INTEGER :: idat
4454INTEGER(kind=int_b) :: bdat
4456CHARACTER(len=*) :: cdat
4457CHARACTER(len=80) :: to_char_dat
4458
4459CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4460
4461
4462#ifdef HAVE_DBALLE
4463INTEGER :: handle, ier
4464
4465handle = 0
4466to_char_dat="VALUE: "
4467
4472
4474 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4475 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4476 ier = idba_fatto(handle)
4477 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4478endif
4479
4480#else
4481
4482to_char_dat="VALUE: "
4488
4489#endif
4490
4491END FUNCTION to_char_dat
4492
4493
4496FUNCTION vol7d_c_e(this) RESULT(c_e)
4497TYPE(vol7d), INTENT(in) :: this
4498
4499LOGICAL :: c_e
4500
4502 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
4503 ASSOCIATED(this%network) .OR. &
4504 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4505 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4506 ASSOCIATED(this%anavar%c) .OR. &
4507 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
4508 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
4509 ASSOCIATED(this%anaattr%c) .OR. &
4510 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4511 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4512 ASSOCIATED(this%dativar%c) .OR. &
4513 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
4514 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
4515 ASSOCIATED(this%datiattr%c)
4516
4517END FUNCTION vol7d_c_e
4518
4519
4558SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
4559 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4560 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4561 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4562 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4563 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4564 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
4565 ini)
4566TYPE(vol7d),INTENT(inout) :: this
4567INTEGER,INTENT(in),OPTIONAL :: nana
4568INTEGER,INTENT(in),OPTIONAL :: ntime
4569INTEGER,INTENT(in),OPTIONAL :: nlevel
4570INTEGER,INTENT(in),OPTIONAL :: ntimerange
4571INTEGER,INTENT(in),OPTIONAL :: nnetwork
4573INTEGER,INTENT(in),OPTIONAL :: &
4574 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
4575 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
4576 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
4577 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
4578 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
4579 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
4580LOGICAL,INTENT(in),OPTIONAL :: ini
4581
4582INTEGER :: i
4583LOGICAL :: linit
4584
4585IF (PRESENT(ini)) THEN
4586 linit = ini
4587ELSE
4588 linit = .false.
4589ENDIF
4590
4591! Dimensioni principali
4592IF (PRESENT(nana)) THEN
4593 IF (nana >= 0) THEN
4594 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4595 ALLOCATE(this%ana(nana))
4596 IF (linit) THEN
4597 DO i = 1, nana
4599 ENDDO
4600 ENDIF
4601 ENDIF
4602ENDIF
4603IF (PRESENT(ntime)) THEN
4604 IF (ntime >= 0) THEN
4605 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4606 ALLOCATE(this%time(ntime))
4607 IF (linit) THEN
4608 DO i = 1, ntime
4610 ENDDO
4611 ENDIF
4612 ENDIF
4613ENDIF
4614IF (PRESENT(nlevel)) THEN
4615 IF (nlevel >= 0) THEN
4616 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4617 ALLOCATE(this%level(nlevel))
4618 IF (linit) THEN
4619 DO i = 1, nlevel
4621 ENDDO
4622 ENDIF
4623 ENDIF
4624ENDIF
4625IF (PRESENT(ntimerange)) THEN
4626 IF (ntimerange >= 0) THEN
4627 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4628 ALLOCATE(this%timerange(ntimerange))
4629 IF (linit) THEN
4630 DO i = 1, ntimerange
4632 ENDDO
4633 ENDIF
4634 ENDIF
4635ENDIF
4636IF (PRESENT(nnetwork)) THEN
4637 IF (nnetwork >= 0) THEN
4638 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4639 ALLOCATE(this%network(nnetwork))
4640 IF (linit) THEN
4641 DO i = 1, nnetwork
4643 ENDDO
4644 ENDIF
4645 ENDIF
4646ENDIF
4647! Dimensioni dei tipi delle variabili
4648CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
4649 nanavari, nanavarb, nanavarc, ini)
4650CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
4651 nanaattri, nanaattrb, nanaattrc, ini)
4652CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
4653 nanavarattri, nanavarattrb, nanavarattrc, ini)
4654CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
4655 ndativari, ndativarb, ndativarc, ini)
4656CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
4657 ndatiattri, ndatiattrb, ndatiattrc, ini)
4658CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
4659 ndativarattri, ndativarattrb, ndativarattrc, ini)
4660
4661END SUBROUTINE vol7d_alloc
4662
4663
4664FUNCTION vol7d_check_alloc_ana(this)
4665TYPE(vol7d),INTENT(in) :: this
4666LOGICAL :: vol7d_check_alloc_ana
4667
4668vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
4669
4670END FUNCTION vol7d_check_alloc_ana
4671
4672SUBROUTINE vol7d_force_alloc_ana(this, ini)
4673TYPE(vol7d),INTENT(inout) :: this
4674LOGICAL,INTENT(in),OPTIONAL :: ini
4675
4676! Alloco i descrittori minimi per avere un volume di anagrafica
4677IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
4678IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
4679
4680END SUBROUTINE vol7d_force_alloc_ana
4681
4682
4683FUNCTION vol7d_check_alloc_dati(this)
4684TYPE(vol7d),INTENT(in) :: this
4685LOGICAL :: vol7d_check_alloc_dati
4686
4687vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
4688 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
4689 ASSOCIATED(this%timerange)
4690
4691END FUNCTION vol7d_check_alloc_dati
4692
4693SUBROUTINE vol7d_force_alloc_dati(this, ini)
4694TYPE(vol7d),INTENT(inout) :: this
4695LOGICAL,INTENT(in),OPTIONAL :: ini
4696
4697! Alloco i descrittori minimi per avere un volume di dati
4698CALL vol7d_force_alloc_ana(this, ini)
4699IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
4700IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
4701IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
4702
4703END SUBROUTINE vol7d_force_alloc_dati
4704
4705
4706SUBROUTINE vol7d_force_alloc(this)
4707TYPE(vol7d),INTENT(inout) :: this
4708
4709! If anything really not allocated yet, allocate with size 0
4710IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
4711IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
4712IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
4713IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
4714IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
4715
4716END SUBROUTINE vol7d_force_alloc
4717
4718
4719FUNCTION vol7d_check_vol(this)
4720TYPE(vol7d),INTENT(in) :: this
4721LOGICAL :: vol7d_check_vol
4722
4723vol7d_check_vol = c_e(this)
4724
4725! Anagrafica
4726IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4727 vol7d_check_vol = .false.
4728ENDIF
4729
4730IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4731 vol7d_check_vol = .false.
4732ENDIF
4733
4734IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4735 vol7d_check_vol = .false.
4736ENDIF
4737
4738IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4739 vol7d_check_vol = .false.
4740ENDIF
4741
4742IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4743 vol7d_check_vol = .false.
4744ENDIF
4745IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
4746 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
4747 ASSOCIATED(this%anavar%c)) THEN
4748 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
4749ENDIF
4750
4751! Attributi dell'anagrafica
4752IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4753 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4754 vol7d_check_vol = .false.
4755ENDIF
4756
4757IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4758 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4759 vol7d_check_vol = .false.
4760ENDIF
4761
4762IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4763 .NOT.ASSOCIATED(this%volanaattri)) THEN
4764 vol7d_check_vol = .false.
4765ENDIF
4766
4767IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4768 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4769 vol7d_check_vol = .false.
4770ENDIF
4771
4772IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4773 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4774 vol7d_check_vol = .false.
4775ENDIF
4776
4777! Dati
4778IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4779 vol7d_check_vol = .false.
4780ENDIF
4781
4782IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4783 vol7d_check_vol = .false.
4784ENDIF
4785
4786IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4787 vol7d_check_vol = .false.
4788ENDIF
4789
4790IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4791 vol7d_check_vol = .false.
4792ENDIF
4793
4794IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4795 vol7d_check_vol = .false.
4796ENDIF
4797
4798! Attributi dei dati
4799IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4800 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4801 vol7d_check_vol = .false.
4802ENDIF
4803
4804IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4805 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4806 vol7d_check_vol = .false.
4807ENDIF
4808
4809IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4810 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4811 vol7d_check_vol = .false.
4812ENDIF
4813
4814IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4815 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4816 vol7d_check_vol = .false.
4817ENDIF
4818
4819IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
4820 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
4821 vol7d_check_vol = .false.
4822ENDIF
4823IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
4824 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
4825 ASSOCIATED(this%dativar%c)) THEN
4826 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
4827ENDIF
4828
4829END FUNCTION vol7d_check_vol
4830
4831
4846SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
4847TYPE(vol7d),INTENT(inout) :: this
4848LOGICAL,INTENT(in),OPTIONAL :: ini
4849LOGICAL,INTENT(in),OPTIONAL :: inivol
4850
4851LOGICAL :: linivol
4852
4853IF (PRESENT(inivol)) THEN
4854 linivol = inivol
4855ELSE
4856 linivol = .true.
4857ENDIF
4858
4859! Anagrafica
4860IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
4861 CALL vol7d_force_alloc_ana(this, ini)
4862 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
4863 IF (linivol) this%volanar(:,:,:) = rmiss
4864ENDIF
4865
4866IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
4867 CALL vol7d_force_alloc_ana(this, ini)
4868 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
4869 IF (linivol) this%volanad(:,:,:) = rdmiss
4870ENDIF
4871
4872IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
4873 CALL vol7d_force_alloc_ana(this, ini)
4874 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
4875 IF (linivol) this%volanai(:,:,:) = imiss
4876ENDIF
4877
4878IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
4879 CALL vol7d_force_alloc_ana(this, ini)
4880 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
4881 IF (linivol) this%volanab(:,:,:) = ibmiss
4882ENDIF
4883
4884IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
4885 CALL vol7d_force_alloc_ana(this, ini)
4886 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
4887 IF (linivol) this%volanac(:,:,:) = cmiss
4888ENDIF
4889
4890! Attributi dell'anagrafica
4891IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
4892 .NOT.ASSOCIATED(this%volanaattrr)) THEN
4893 CALL vol7d_force_alloc_ana(this, ini)
4894 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
4895 SIZE(this%network), SIZE(this%anaattr%r)))
4896 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
4897ENDIF
4898
4899IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
4900 .NOT.ASSOCIATED(this%volanaattrd)) THEN
4901 CALL vol7d_force_alloc_ana(this, ini)
4902 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
4903 SIZE(this%network), SIZE(this%anaattr%d)))
4904 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
4905ENDIF
4906
4907IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
4908 .NOT.ASSOCIATED(this%volanaattri)) THEN
4909 CALL vol7d_force_alloc_ana(this, ini)
4910 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
4911 SIZE(this%network), SIZE(this%anaattr%i)))
4912 IF (linivol) this%volanaattri(:,:,:,:) = imiss
4913ENDIF
4914
4915IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
4916 .NOT.ASSOCIATED(this%volanaattrb)) THEN
4917 CALL vol7d_force_alloc_ana(this, ini)
4918 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
4919 SIZE(this%network), SIZE(this%anaattr%b)))
4920 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
4921ENDIF
4922
4923IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
4924 .NOT.ASSOCIATED(this%volanaattrc)) THEN
4925 CALL vol7d_force_alloc_ana(this, ini)
4926 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
4927 SIZE(this%network), SIZE(this%anaattr%c)))
4928 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
4929ENDIF
4930
4931! Dati
4932IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
4933 CALL vol7d_force_alloc_dati(this, ini)
4934 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4935 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
4936 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
4937ENDIF
4938
4939IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
4940 CALL vol7d_force_alloc_dati(this, ini)
4941 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4942 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
4943 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
4944ENDIF
4945
4946IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
4947 CALL vol7d_force_alloc_dati(this, ini)
4948 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4949 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
4950 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
4951ENDIF
4952
4953IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
4954 CALL vol7d_force_alloc_dati(this, ini)
4955 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4956 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
4957 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
4958ENDIF
4959
4960IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
4961 CALL vol7d_force_alloc_dati(this, ini)
4962 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4963 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
4964 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
4965ENDIF
4966
4967! Attributi dei dati
4968IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
4969 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
4970 CALL vol7d_force_alloc_dati(this, ini)
4971 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4972 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
4973 SIZE(this%datiattr%r)))
4974 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
4975ENDIF
4976
4977IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
4978 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
4979 CALL vol7d_force_alloc_dati(this, ini)
4980 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4981 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
4982 SIZE(this%datiattr%d)))
4983 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
4984ENDIF
4985
4986IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
4987 .NOT.ASSOCIATED(this%voldatiattri)) THEN
4988 CALL vol7d_force_alloc_dati(this, ini)
4989 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4990 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
4991 SIZE(this%datiattr%i)))
4992 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
4993ENDIF
4994
4995IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
4996 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
4997 CALL vol7d_force_alloc_dati(this, ini)
4998 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
4999 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
5000 SIZE(this%datiattr%b)))
5001 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
5002ENDIF
5003
5004IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5005 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5006 CALL vol7d_force_alloc_dati(this, ini)
5007 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5008 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
5009 SIZE(this%datiattr%c)))
5010 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
5011ENDIF
5012
5013! Catch-all method
5014CALL vol7d_force_alloc(this)
5015
5016! Creo gli indici var-attr
5017
5018#ifdef DEBUG
5019CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
5020#endif
5021
5022CALL vol7d_set_attr_ind(this)
5023
5024
5025
5026END SUBROUTINE vol7d_alloc_vol
5027
5028
5035SUBROUTINE vol7d_set_attr_ind(this)
5036TYPE(vol7d),INTENT(inout) :: this
5037
5038INTEGER :: i
5039
5040! real
5041IF (ASSOCIATED(this%dativar%r)) THEN
5042 IF (ASSOCIATED(this%dativarattr%r)) THEN
5043 DO i = 1, SIZE(this%dativar%r)
5044 this%dativar%r(i)%r = &
5045 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
5046 ENDDO
5047 ENDIF
5048
5049 IF (ASSOCIATED(this%dativarattr%d)) THEN
5050 DO i = 1, SIZE(this%dativar%r)
5051 this%dativar%r(i)%d = &
5052 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
5053 ENDDO
5054 ENDIF
5055
5056 IF (ASSOCIATED(this%dativarattr%i)) THEN
5057 DO i = 1, SIZE(this%dativar%r)
5058 this%dativar%r(i)%i = &
5059 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
5060 ENDDO
5061 ENDIF
5062
5063 IF (ASSOCIATED(this%dativarattr%b)) THEN
5064 DO i = 1, SIZE(this%dativar%r)
5065 this%dativar%r(i)%b = &
5066 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
5067 ENDDO
5068 ENDIF
5069
5070 IF (ASSOCIATED(this%dativarattr%c)) THEN
5071 DO i = 1, SIZE(this%dativar%r)
5072 this%dativar%r(i)%c = &
5073 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
5074 ENDDO
5075 ENDIF
5076ENDIF
5077! double
5078IF (ASSOCIATED(this%dativar%d)) THEN
5079 IF (ASSOCIATED(this%dativarattr%r)) THEN
5080 DO i = 1, SIZE(this%dativar%d)
5081 this%dativar%d(i)%r = &
5082 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
5083 ENDDO
5084 ENDIF
5085
5086 IF (ASSOCIATED(this%dativarattr%d)) THEN
5087 DO i = 1, SIZE(this%dativar%d)
5088 this%dativar%d(i)%d = &
5089 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
5090 ENDDO
5091 ENDIF
5092
5093 IF (ASSOCIATED(this%dativarattr%i)) THEN
5094 DO i = 1, SIZE(this%dativar%d)
5095 this%dativar%d(i)%i = &
5096 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
5097 ENDDO
5098 ENDIF
5099
5100 IF (ASSOCIATED(this%dativarattr%b)) THEN
5101 DO i = 1, SIZE(this%dativar%d)
5102 this%dativar%d(i)%b = &
5103 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
5104 ENDDO
5105 ENDIF
5106
5107 IF (ASSOCIATED(this%dativarattr%c)) THEN
5108 DO i = 1, SIZE(this%dativar%d)
5109 this%dativar%d(i)%c = &
5110 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
5111 ENDDO
5112 ENDIF
5113ENDIF
5114! integer
5115IF (ASSOCIATED(this%dativar%i)) THEN
5116 IF (ASSOCIATED(this%dativarattr%r)) THEN
5117 DO i = 1, SIZE(this%dativar%i)
5118 this%dativar%i(i)%r = &
5119 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5120 ENDDO
5121 ENDIF
5122
5123 IF (ASSOCIATED(this%dativarattr%d)) THEN
5124 DO i = 1, SIZE(this%dativar%i)
5125 this%dativar%i(i)%d = &
5126 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5127 ENDDO
5128 ENDIF
5129
5130 IF (ASSOCIATED(this%dativarattr%i)) THEN
5131 DO i = 1, SIZE(this%dativar%i)
5132 this%dativar%i(i)%i = &
5133 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5134 ENDDO
5135 ENDIF
5136
5137 IF (ASSOCIATED(this%dativarattr%b)) THEN
5138 DO i = 1, SIZE(this%dativar%i)
5139 this%dativar%i(i)%b = &
5140 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5141 ENDDO
5142 ENDIF
5143
5144 IF (ASSOCIATED(this%dativarattr%c)) THEN
5145 DO i = 1, SIZE(this%dativar%i)
5146 this%dativar%i(i)%c = &
5147 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5148 ENDDO
5149 ENDIF
5150ENDIF
5151! byte
5152IF (ASSOCIATED(this%dativar%b)) THEN
5153 IF (ASSOCIATED(this%dativarattr%r)) THEN
5154 DO i = 1, SIZE(this%dativar%b)
5155 this%dativar%b(i)%r = &
5156 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5157 ENDDO
5158 ENDIF
5159
5160 IF (ASSOCIATED(this%dativarattr%d)) THEN
5161 DO i = 1, SIZE(this%dativar%b)
5162 this%dativar%b(i)%d = &
5163 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5164 ENDDO
5165 ENDIF
5166
5167 IF (ASSOCIATED(this%dativarattr%i)) THEN
5168 DO i = 1, SIZE(this%dativar%b)
5169 this%dativar%b(i)%i = &
5170 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5171 ENDDO
5172 ENDIF
5173
5174 IF (ASSOCIATED(this%dativarattr%b)) THEN
5175 DO i = 1, SIZE(this%dativar%b)
5176 this%dativar%b(i)%b = &
5177 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5178 ENDDO
5179 ENDIF
5180
5181 IF (ASSOCIATED(this%dativarattr%c)) THEN
5182 DO i = 1, SIZE(this%dativar%b)
5183 this%dativar%b(i)%c = &
5184 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5185 ENDDO
5186 ENDIF
5187ENDIF
5188! character
5189IF (ASSOCIATED(this%dativar%c)) THEN
5190 IF (ASSOCIATED(this%dativarattr%r)) THEN
5191 DO i = 1, SIZE(this%dativar%c)
5192 this%dativar%c(i)%r = &
5193 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5194 ENDDO
5195 ENDIF
5196
5197 IF (ASSOCIATED(this%dativarattr%d)) THEN
5198 DO i = 1, SIZE(this%dativar%c)
5199 this%dativar%c(i)%d = &
5200 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5201 ENDDO
5202 ENDIF
5203
5204 IF (ASSOCIATED(this%dativarattr%i)) THEN
5205 DO i = 1, SIZE(this%dativar%c)
5206 this%dativar%c(i)%i = &
5207 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5208 ENDDO
5209 ENDIF
5210
5211 IF (ASSOCIATED(this%dativarattr%b)) THEN
5212 DO i = 1, SIZE(this%dativar%c)
5213 this%dativar%c(i)%b = &
5214 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5215 ENDDO
5216 ENDIF
5217
5218 IF (ASSOCIATED(this%dativarattr%c)) THEN
5219 DO i = 1, SIZE(this%dativar%c)
5220 this%dativar%c(i)%c = &
5221 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5222 ENDDO
5223 ENDIF
5224ENDIF
5225
5226END SUBROUTINE vol7d_set_attr_ind
5227
5228
5233SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5234 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5235TYPE(vol7d),INTENT(INOUT) :: this
5236TYPE(vol7d),INTENT(INOUT) :: that
5237LOGICAL,INTENT(IN),OPTIONAL :: sort
5238LOGICAL,INTENT(in),OPTIONAL :: bestdata
5239LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5240
5241TYPE(vol7d) :: v7d_clean
5242
5243
5245 this = that
5247 that = v7d_clean ! destroy that without deallocating
5248ELSE ! Append that to this and destroy that
5250 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5252ENDIF
5253
5254END SUBROUTINE vol7d_merge
5255
5256
5285SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5286 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5287TYPE(vol7d),INTENT(INOUT) :: this
5288TYPE(vol7d),INTENT(IN) :: that
5289LOGICAL,INTENT(IN),OPTIONAL :: sort
5290! experimental, please do not use outside the library now, they force the use
5291! of a simplified mapping algorithm which is valid only whene the dimension
5292! content is the same in both volumes , or when one of them is empty
5293LOGICAL,INTENT(in),OPTIONAL :: bestdata
5294LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5295
5296
5297TYPE(vol7d) :: v7dtmp
5298LOGICAL :: lsort, lbestdata
5299INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5300 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5301
5303IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5306 RETURN
5307ENDIF
5308
5309IF (this%time_definition /= that%time_definition) THEN
5310 CALL l4f_log(l4f_fatal, &
5311 'in vol7d_append, cannot append volumes with different &
5312 &time definition')
5313 CALL raise_fatal_error()
5314ENDIF
5315
5316! Completo l'allocazione per avere volumi a norma
5317CALL vol7d_alloc_vol(this)
5318
5322
5323! Calcolo le mappature tra volumi vecchi e volume nuovo
5324! I puntatori remap* vengono tutti o allocati o nullificati
5325IF (optio_log(ltimesimple)) THEN
5326 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5327 lsort, remapt1, remapt2)
5328ELSE
5329 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5330 lsort, remapt1, remapt2)
5331ENDIF
5332IF (optio_log(ltimerangesimple)) THEN
5333 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5334 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5335ELSE
5336 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5337 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5338ENDIF
5339IF (optio_log(llevelsimple)) THEN
5340 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5341 lsort, remapl1, remapl2)
5342ELSE
5343 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5344 lsort, remapl1, remapl2)
5345ENDIF
5346IF (optio_log(lanasimple)) THEN
5347 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5348 .false., remapa1, remapa2)
5349ELSE
5350 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5351 .false., remapa1, remapa2)
5352ENDIF
5353IF (optio_log(lnetworksimple)) THEN
5354 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5355 .false., remapn1, remapn2)
5356ELSE
5357 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5358 .false., remapn1, remapn2)
5359ENDIF
5360
5361! Faccio la fusione fisica dei volumi
5362CALL vol7d_merge_finalr(this, that, v7dtmp, &
5363 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5364 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5365CALL vol7d_merge_finald(this, that, v7dtmp, &
5366 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5367 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5368CALL vol7d_merge_finali(this, that, v7dtmp, &
5369 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5370 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5371CALL vol7d_merge_finalb(this, that, v7dtmp, &
5372 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5373 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5374CALL vol7d_merge_finalc(this, that, v7dtmp, &
5375 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5376 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5377
5378! Dealloco i vettori di rimappatura
5379IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5380IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5381IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5382IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5383IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5384IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5385IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5386IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5387IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5388IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5389
5390! Distruggo il vecchio volume e assegno il nuovo a this
5392this = v7dtmp
5393! Ricreo gli indici var-attr
5394CALL vol7d_set_attr_ind(this)
5395
5396END SUBROUTINE vol7d_append
5397
5398
5431SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5432 lsort_time, lsort_timerange, lsort_level, &
5433 ltime, ltimerange, llevel, lana, lnetwork, &
5434 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5435 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5436 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5437 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5438 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5439 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5440TYPE(vol7d),INTENT(IN) :: this
5441TYPE(vol7d),INTENT(INOUT) :: that
5442LOGICAL,INTENT(IN),OPTIONAL :: sort
5443LOGICAL,INTENT(IN),OPTIONAL :: unique
5444LOGICAL,INTENT(IN),OPTIONAL :: miss
5445LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5446LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5447LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5455LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5457LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5459LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5461LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5463LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5465LOGICAL,INTENT(in),OPTIONAL :: &
5466 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5467 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5468 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5469 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5470 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5471 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5472
5473LOGICAL :: lsort, lunique, lmiss
5474INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5475
5478IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5479
5483
5484! Calcolo le mappature tra volume vecchio e volume nuovo
5485! I puntatori remap* vengono tutti o allocati o nullificati
5486CALL vol7d_remap1_datetime(this%time, that%time, &
5487 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
5488CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
5489 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
5490CALL vol7d_remap1_vol7d_level(this%level, that%level, &
5491 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
5492CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
5493 lsort, lunique, lmiss, remapa, lana)
5494CALL vol7d_remap1_vol7d_network(this%network, that%network, &
5495 lsort, lunique, lmiss, remapn, lnetwork)
5496
5497! lanavari, lanavarb, lanavarc, &
5498! lanaattri, lanaattrb, lanaattrc, &
5499! lanavarattri, lanavarattrb, lanavarattrc, &
5500! ldativari, ldativarb, ldativarc, &
5501! ldatiattri, ldatiattrb, ldatiattrc, &
5502! ldativarattri, ldativarattrb, ldativarattrc
5503! Faccio la riforma fisica dei volumi
5504CALL vol7d_reform_finalr(this, that, &
5505 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5506 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
5507CALL vol7d_reform_finald(this, that, &
5508 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5509 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
5510CALL vol7d_reform_finali(this, that, &
5511 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5512 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
5513CALL vol7d_reform_finalb(this, that, &
5514 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5515 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
5516CALL vol7d_reform_finalc(this, that, &
5517 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
5518 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
5519
5520! Dealloco i vettori di rimappatura
5521IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
5522IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
5523IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
5524IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
5525IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
5526
5527! Ricreo gli indici var-attr
5528CALL vol7d_set_attr_ind(that)
5529that%time_definition = this%time_definition
5530
5531END SUBROUTINE vol7d_copy
5532
5533
5544SUBROUTINE vol7d_reform(this, sort, unique, miss, &
5545 lsort_time, lsort_timerange, lsort_level, &
5546 ltime, ltimerange, llevel, lana, lnetwork, &
5547 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5548 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5549 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5550 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5551 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5552 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
5553 ,purgeana)
5554TYPE(vol7d),INTENT(INOUT) :: this
5555LOGICAL,INTENT(IN),OPTIONAL :: sort
5556LOGICAL,INTENT(IN),OPTIONAL :: unique
5557LOGICAL,INTENT(IN),OPTIONAL :: miss
5558LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5559LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5560LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5568LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5569LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5570LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5571LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5572LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5574LOGICAL,INTENT(in),OPTIONAL :: &
5575 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5576 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5577 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5578 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5579 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5580 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5581LOGICAL,INTENT(IN),OPTIONAL :: purgeana
5582
5583TYPE(vol7d) :: v7dtmp
5584logical,allocatable :: llana(:)
5585integer :: i
5586
5588 lsort_time, lsort_timerange, lsort_level, &
5589 ltime, ltimerange, llevel, lana, lnetwork, &
5590 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5591 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5592 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5593 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5594 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5595 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5596
5597! destroy old volume
5599
5600if (optio_log(purgeana)) then
5601 allocate(llana(size(v7dtmp%ana)))
5602 llana =.false.
5603 do i =1,size(v7dtmp%ana)
5604 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
5605 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
5606 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
5607 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
5608 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
5609 end do
5610 CALL vol7d_copy(v7dtmp, this,lana=llana)
5612 deallocate(llana)
5613else
5614 this=v7dtmp
5615end if
5616
5617END SUBROUTINE vol7d_reform
5618
5619
5627SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
5628TYPE(vol7d),INTENT(INOUT) :: this
5629LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
5630LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
5631LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
5632
5633INTEGER :: i
5634LOGICAL :: to_be_sorted
5635
5636to_be_sorted = .false.
5637CALL vol7d_alloc_vol(this) ! usual safety check
5638
5639IF (optio_log(lsort_time)) THEN
5640 DO i = 2, SIZE(this%time)
5641 IF (this%time(i) < this%time(i-1)) THEN
5642 to_be_sorted = .true.
5643 EXIT
5644 ENDIF
5645 ENDDO
5646ENDIF
5647IF (optio_log(lsort_timerange)) THEN
5648 DO i = 2, SIZE(this%timerange)
5649 IF (this%timerange(i) < this%timerange(i-1)) THEN
5650 to_be_sorted = .true.
5651 EXIT
5652 ENDIF
5653 ENDDO
5654ENDIF
5655IF (optio_log(lsort_level)) THEN
5656 DO i = 2, SIZE(this%level)
5657 IF (this%level(i) < this%level(i-1)) THEN
5658 to_be_sorted = .true.
5659 EXIT
5660 ENDIF
5661 ENDDO
5662ENDIF
5663
5664IF (to_be_sorted) CALL vol7d_reform(this, &
5665 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
5666
5667END SUBROUTINE vol7d_smart_sort
5668
5676SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
5677TYPE(vol7d),INTENT(inout) :: this
5678CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
5679CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
5680TYPE(vol7d_network),OPTIONAL :: nl(:)
5681TYPE(datetime),INTENT(in),OPTIONAL :: s_d
5682TYPE(datetime),INTENT(in),OPTIONAL :: e_d
5683
5684INTEGER :: i
5685
5686IF (PRESENT(avl)) THEN
5687 IF (SIZE(avl) > 0) THEN
5688
5689 IF (ASSOCIATED(this%anavar%r)) THEN
5690 DO i = 1, SIZE(this%anavar%r)
5691 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
5692 ENDDO
5693 ENDIF
5694
5695 IF (ASSOCIATED(this%anavar%i)) THEN
5696 DO i = 1, SIZE(this%anavar%i)
5697 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
5698 ENDDO
5699 ENDIF
5700
5701 IF (ASSOCIATED(this%anavar%b)) THEN
5702 DO i = 1, SIZE(this%anavar%b)
5703 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
5704 ENDDO
5705 ENDIF
5706
5707 IF (ASSOCIATED(this%anavar%d)) THEN
5708 DO i = 1, SIZE(this%anavar%d)
5709 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
5710 ENDDO
5711 ENDIF
5712
5713 IF (ASSOCIATED(this%anavar%c)) THEN
5714 DO i = 1, SIZE(this%anavar%c)
5715 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
5716 ENDDO
5717 ENDIF
5718
5719 ENDIF
5720ENDIF
5721
5722
5723IF (PRESENT(vl)) THEN
5724 IF (size(vl) > 0) THEN
5725 IF (ASSOCIATED(this%dativar%r)) THEN
5726 DO i = 1, SIZE(this%dativar%r)
5727 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
5728 ENDDO
5729 ENDIF
5730
5731 IF (ASSOCIATED(this%dativar%i)) THEN
5732 DO i = 1, SIZE(this%dativar%i)
5733 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
5734 ENDDO
5735 ENDIF
5736
5737 IF (ASSOCIATED(this%dativar%b)) THEN
5738 DO i = 1, SIZE(this%dativar%b)
5739 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
5740 ENDDO
5741 ENDIF
5742
5743 IF (ASSOCIATED(this%dativar%d)) THEN
5744 DO i = 1, SIZE(this%dativar%d)
5745 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
5746 ENDDO
5747 ENDIF
5748
5749 IF (ASSOCIATED(this%dativar%c)) THEN
5750 DO i = 1, SIZE(this%dativar%c)
5751 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5752 ENDDO
5753 ENDIF
5754
5755 IF (ASSOCIATED(this%dativar%c)) THEN
5756 DO i = 1, SIZE(this%dativar%c)
5757 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
5758 ENDDO
5759 ENDIF
5760
5761 ENDIF
5762ENDIF
5763
5764IF (PRESENT(nl)) THEN
5765 IF (SIZE(nl) > 0) THEN
5766 DO i = 1, SIZE(this%network)
5767 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
5768 ENDDO
5769 ENDIF
5770ENDIF
5771
5772IF (PRESENT(s_d)) THEN
5774 WHERE (this%time < s_d)
5775 this%time = datetime_miss
5776 END WHERE
5777 ENDIF
5778ENDIF
5779
5780IF (PRESENT(e_d)) THEN
5782 WHERE (this%time > e_d)
5783 this%time = datetime_miss
5784 END WHERE
5785 ENDIF
5786ENDIF
5787
5788CALL vol7d_reform(this, miss=.true.)
5789
5790END SUBROUTINE vol7d_filter
5791
5792
5799SUBROUTINE vol7d_convr(this, that, anaconv)
5800TYPE(vol7d),INTENT(IN) :: this
5801TYPE(vol7d),INTENT(INOUT) :: that
5802LOGICAL,OPTIONAL,INTENT(in) :: anaconv
5803INTEGER :: i
5804LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
5805TYPE(vol7d) :: v7d_tmp
5806
5807IF (optio_log(anaconv)) THEN
5808 acp=fv
5809 acn=tv
5810ELSE
5811 acp=tv
5812 acn=fv
5813ENDIF
5814
5815! Volume con solo i dati reali e tutti gli attributi
5816! l'anagrafica e` copiata interamente se necessario
5817CALL vol7d_copy(this, that, &
5818 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
5819 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
5820
5821! Volume solo di dati double
5822CALL vol7d_copy(this, v7d_tmp, &
5823 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
5824 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5825 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5826 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
5827 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5828 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5829
5830! converto a dati reali
5831IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
5832
5833 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
5834! alloco i dati reali e vi trasferisco i double
5835 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
5836 SIZE(v7d_tmp%volanad, 3)))
5837 DO i = 1, SIZE(v7d_tmp%anavar%d)
5838 v7d_tmp%volanar(:,i,:) = &
5839 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
5840 ENDDO
5841 DEALLOCATE(v7d_tmp%volanad)
5842! trasferisco le variabili
5843 v7d_tmp%anavar%r => v7d_tmp%anavar%d
5844 NULLIFY(v7d_tmp%anavar%d)
5845 ENDIF
5846
5847 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
5848! alloco i dati reali e vi trasferisco i double
5849 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
5850 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
5851 SIZE(v7d_tmp%voldatid, 6)))
5852 DO i = 1, SIZE(v7d_tmp%dativar%d)
5853 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5854 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
5855 ENDDO
5856 DEALLOCATE(v7d_tmp%voldatid)
5857! trasferisco le variabili
5858 v7d_tmp%dativar%r => v7d_tmp%dativar%d
5859 NULLIFY(v7d_tmp%dativar%d)
5860 ENDIF
5861
5862! fondo con il volume definitivo
5863 CALL vol7d_merge(that, v7d_tmp)
5864ELSE
5866ENDIF
5867
5868
5869! Volume solo di dati interi
5870CALL vol7d_copy(this, v7d_tmp, &
5871 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
5872 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5873 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5874 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
5875 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5876 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5877
5878! converto a dati reali
5879IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
5880
5881 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
5882! alloco i dati reali e vi trasferisco gli interi
5883 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
5884 SIZE(v7d_tmp%volanai, 3)))
5885 DO i = 1, SIZE(v7d_tmp%anavar%i)
5886 v7d_tmp%volanar(:,i,:) = &
5887 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
5888 ENDDO
5889 DEALLOCATE(v7d_tmp%volanai)
5890! trasferisco le variabili
5891 v7d_tmp%anavar%r => v7d_tmp%anavar%i
5892 NULLIFY(v7d_tmp%anavar%i)
5893 ENDIF
5894
5895 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
5896! alloco i dati reali e vi trasferisco gli interi
5897 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
5898 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
5899 SIZE(v7d_tmp%voldatii, 6)))
5900 DO i = 1, SIZE(v7d_tmp%dativar%i)
5901 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5902 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
5903 ENDDO
5904 DEALLOCATE(v7d_tmp%voldatii)
5905! trasferisco le variabili
5906 v7d_tmp%dativar%r => v7d_tmp%dativar%i
5907 NULLIFY(v7d_tmp%dativar%i)
5908 ENDIF
5909
5910! fondo con il volume definitivo
5911 CALL vol7d_merge(that, v7d_tmp)
5912ELSE
5914ENDIF
5915
5916
5917! Volume solo di dati byte
5918CALL vol7d_copy(this, v7d_tmp, &
5919 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
5920 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5921 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5922 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
5923 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5924 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5925
5926! converto a dati reali
5927IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
5928
5929 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
5930! alloco i dati reali e vi trasferisco i byte
5931 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
5932 SIZE(v7d_tmp%volanab, 3)))
5933 DO i = 1, SIZE(v7d_tmp%anavar%b)
5934 v7d_tmp%volanar(:,i,:) = &
5935 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
5936 ENDDO
5937 DEALLOCATE(v7d_tmp%volanab)
5938! trasferisco le variabili
5939 v7d_tmp%anavar%r => v7d_tmp%anavar%b
5940 NULLIFY(v7d_tmp%anavar%b)
5941 ENDIF
5942
5943 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
5944! alloco i dati reali e vi trasferisco i byte
5945 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
5946 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
5947 SIZE(v7d_tmp%voldatib, 6)))
5948 DO i = 1, SIZE(v7d_tmp%dativar%b)
5949 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5950 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
5951 ENDDO
5952 DEALLOCATE(v7d_tmp%voldatib)
5953! trasferisco le variabili
5954 v7d_tmp%dativar%r => v7d_tmp%dativar%b
5955 NULLIFY(v7d_tmp%dativar%b)
5956 ENDIF
5957
5958! fondo con il volume definitivo
5959 CALL vol7d_merge(that, v7d_tmp)
5960ELSE
5962ENDIF
5963
5964
5965! Volume solo di dati character
5966CALL vol7d_copy(this, v7d_tmp, &
5967 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
5968 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
5969 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
5970 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
5971 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
5972 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
5973
5974! converto a dati reali
5975IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
5976
5977 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
5978! alloco i dati reali e vi trasferisco i character
5979 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
5980 SIZE(v7d_tmp%volanac, 3)))
5981 DO i = 1, SIZE(v7d_tmp%anavar%c)
5982 v7d_tmp%volanar(:,i,:) = &
5983 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
5984 ENDDO
5985 DEALLOCATE(v7d_tmp%volanac)
5986! trasferisco le variabili
5987 v7d_tmp%anavar%r => v7d_tmp%anavar%c
5988 NULLIFY(v7d_tmp%anavar%c)
5989 ENDIF
5990
5991 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
5992! alloco i dati reali e vi trasferisco i character
5993 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
5994 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
5995 SIZE(v7d_tmp%voldatic, 6)))
5996 DO i = 1, SIZE(v7d_tmp%dativar%c)
5997 v7d_tmp%voldatir(:,:,:,:,i,:) = &
5998 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
5999 ENDDO
6000 DEALLOCATE(v7d_tmp%voldatic)
6001! trasferisco le variabili
6002 v7d_tmp%dativar%r => v7d_tmp%dativar%c
6003 NULLIFY(v7d_tmp%dativar%c)
6004 ENDIF
6005
6006! fondo con il volume definitivo
6007 CALL vol7d_merge(that, v7d_tmp)
6008ELSE
6010ENDIF
6011
6012END SUBROUTINE vol7d_convr
6013
6014
6018SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
6019TYPE(vol7d),INTENT(IN) :: this
6020TYPE(vol7d),INTENT(OUT) :: that
6021logical , optional, intent(in) :: data_only
6022logical , optional, intent(in) :: ana
6023logical :: ldata_only,lana
6024
6025IF (PRESENT(data_only)) THEN
6026 ldata_only = data_only
6027ELSE
6028 ldata_only = .false.
6029ENDIF
6030
6031IF (PRESENT(ana)) THEN
6032 lana = ana
6033ELSE
6034 lana = .false.
6035ENDIF
6036
6037
6038#undef VOL7D_POLY_ARRAY
6039#define VOL7D_POLY_ARRAY voldati
6040#include "vol7d_class_diff.F90"
6041#undef VOL7D_POLY_ARRAY
6042#define VOL7D_POLY_ARRAY voldatiattr
6043#include "vol7d_class_diff.F90"
6044#undef VOL7D_POLY_ARRAY
6045
6046if ( .not. ldata_only) then
6047
6048#define VOL7D_POLY_ARRAY volana
6049#include "vol7d_class_diff.F90"
6050#undef VOL7D_POLY_ARRAY
6051#define VOL7D_POLY_ARRAY volanaattr
6052#include "vol7d_class_diff.F90"
6053#undef VOL7D_POLY_ARRAY
6054
6055 if(lana)then
6056 where ( this%ana == that%ana )
6057 that%ana = vol7d_ana_miss
6058 end where
6059 end if
6060
6061end if
6062
6063
6064
6065END SUBROUTINE vol7d_diff_only
6066
6067
6068
6069! Creo le routine da ripetere per i vari tipi di dati di v7d
6070! tramite un template e il preprocessore
6071#undef VOL7D_POLY_TYPE
6072#undef VOL7D_POLY_TYPES
6073#define VOL7D_POLY_TYPE REAL
6074#define VOL7D_POLY_TYPES r
6075#include "vol7d_class_type_templ.F90"
6076#undef VOL7D_POLY_TYPE
6077#undef VOL7D_POLY_TYPES
6078#define VOL7D_POLY_TYPE DOUBLE PRECISION
6079#define VOL7D_POLY_TYPES d
6080#include "vol7d_class_type_templ.F90"
6081#undef VOL7D_POLY_TYPE
6082#undef VOL7D_POLY_TYPES
6083#define VOL7D_POLY_TYPE INTEGER
6084#define VOL7D_POLY_TYPES i
6085#include "vol7d_class_type_templ.F90"
6086#undef VOL7D_POLY_TYPE
6087#undef VOL7D_POLY_TYPES
6088#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
6089#define VOL7D_POLY_TYPES b
6090#include "vol7d_class_type_templ.F90"
6091#undef VOL7D_POLY_TYPE
6092#undef VOL7D_POLY_TYPES
6093#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
6094#define VOL7D_POLY_TYPES c
6095#include "vol7d_class_type_templ.F90"
6096
6097! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
6098! tramite un template e il preprocessore
6099#define VOL7D_SORT
6100#undef VOL7D_NO_ZERO_ALLOC
6101#undef VOL7D_POLY_TYPE
6102#define VOL7D_POLY_TYPE datetime
6103#include "vol7d_class_desc_templ.F90"
6104#undef VOL7D_POLY_TYPE
6105#define VOL7D_POLY_TYPE vol7d_timerange
6106#include "vol7d_class_desc_templ.F90"
6107#undef VOL7D_POLY_TYPE
6108#define VOL7D_POLY_TYPE vol7d_level
6109#include "vol7d_class_desc_templ.F90"
6110#undef VOL7D_SORT
6111#undef VOL7D_POLY_TYPE
6112#define VOL7D_POLY_TYPE vol7d_network
6113#include "vol7d_class_desc_templ.F90"
6114#undef VOL7D_POLY_TYPE
6115#define VOL7D_POLY_TYPE vol7d_ana
6116#include "vol7d_class_desc_templ.F90"
6117#define VOL7D_NO_ZERO_ALLOC
6118#undef VOL7D_POLY_TYPE
6119#define VOL7D_POLY_TYPE vol7d_var
6120#include "vol7d_class_desc_templ.F90"
6121
6131subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6132
6133TYPE(vol7d),INTENT(IN) :: this
6134integer,optional,intent(inout) :: unit
6135character(len=*),intent(in),optional :: filename
6136character(len=*),intent(out),optional :: filename_auto
6137character(len=*),INTENT(IN),optional :: description
6138
6139integer :: lunit
6140character(len=254) :: ldescription,arg,lfilename
6141integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6142 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6143 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6144 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6145 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6146 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6147 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6148!integer :: im,id,iy
6149integer :: tarray(8)
6150logical :: opened,exist
6151
6152 nana=0
6153 ntime=0
6154 ntimerange=0
6155 nlevel=0
6156 nnetwork=0
6157 ndativarr=0
6158 ndativari=0
6159 ndativarb=0
6160 ndativard=0
6161 ndativarc=0
6162 ndatiattrr=0
6163 ndatiattri=0
6164 ndatiattrb=0
6165 ndatiattrd=0
6166 ndatiattrc=0
6167 ndativarattrr=0
6168 ndativarattri=0
6169 ndativarattrb=0
6170 ndativarattrd=0
6171 ndativarattrc=0
6172 nanavarr=0
6173 nanavari=0
6174 nanavarb=0
6175 nanavard=0
6176 nanavarc=0
6177 nanaattrr=0
6178 nanaattri=0
6179 nanaattrb=0
6180 nanaattrd=0
6181 nanaattrc=0
6182 nanavarattrr=0
6183 nanavarattri=0
6184 nanavarattrb=0
6185 nanavarattrd=0
6186 nanavarattrc=0
6187
6188
6189!call idate(im,id,iy)
6190call date_and_time(values=tarray)
6191call getarg(0,arg)
6192
6193if (present(description))then
6194 ldescription=description
6195else
6196 ldescription="Vol7d generated by: "//trim(arg)
6197end if
6198
6199if (.not. present(unit))then
6200 lunit=getunit()
6201else
6202 if (unit==0)then
6203 lunit=getunit()
6204 unit=lunit
6205 else
6206 lunit=unit
6207 end if
6208end if
6209
6210lfilename=trim(arg)//".v7d"
6212
6213if (present(filename))then
6214 if (filename /= "")then
6215 lfilename=filename
6216 end if
6217end if
6218
6219if (present(filename_auto))filename_auto=lfilename
6220
6221
6222inquire(unit=lunit,opened=opened)
6223if (.not. opened) then
6224! inquire(file=lfilename, EXIST=exist)
6225! IF (exist) THEN
6226! CALL l4f_log(L4F_FATAL, &
6227! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6228! CALL raise_fatal_error()
6229! ENDIF
6230 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6231 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6232end if
6233
6234if (associated(this%ana)) nana=size(this%ana)
6235if (associated(this%time)) ntime=size(this%time)
6236if (associated(this%timerange)) ntimerange=size(this%timerange)
6237if (associated(this%level)) nlevel=size(this%level)
6238if (associated(this%network)) nnetwork=size(this%network)
6239
6240if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6241if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6242if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6243if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6244if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6245
6246if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6247if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6248if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6249if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6250if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6251
6252if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6253if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6254if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6255if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6256if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6257
6258if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6259if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6260if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6261if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6262if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6263
6264if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6265if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6266if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6267if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6268if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6269
6270if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6271if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6272if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6273if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6274if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6275
6276write(unit=lunit)ldescription
6277write(unit=lunit)tarray
6278
6279write(unit=lunit)&
6280 nana, ntime, ntimerange, nlevel, nnetwork, &
6281 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6282 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6283 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6284 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6285 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6286 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6287 this%time_definition
6288
6289
6290!write(unit=lunit)this
6291
6292
6293!! prime 5 dimensioni
6296if (associated(this%level)) write(unit=lunit)this%level
6297if (associated(this%timerange)) write(unit=lunit)this%timerange
6298if (associated(this%network)) write(unit=lunit)this%network
6299
6300 !! 6a dimensione: variabile dell'anagrafica e dei dati
6301 !! con relativi attributi e in 5 tipi diversi
6302
6303if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6304if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6305if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6306if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6307if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6308
6309if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6310if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6311if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6312if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6313if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6314
6315if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6316if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6317if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6318if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6319if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6320
6321if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6322if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6323if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6324if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6325if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6326
6327if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6328if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6329if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6330if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6331if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6332
6333if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6334if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6335if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6336if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6337if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6338
6339!! Volumi di valori e attributi per anagrafica e dati
6340
6341if (associated(this%volanar)) write(unit=lunit)this%volanar
6342if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6343if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6344if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6345
6346if (associated(this%volanai)) write(unit=lunit)this%volanai
6347if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6348if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6349if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6350
6351if (associated(this%volanab)) write(unit=lunit)this%volanab
6352if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6353if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6354if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6355
6356if (associated(this%volanad)) write(unit=lunit)this%volanad
6357if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6358if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6359if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6360
6361if (associated(this%volanac)) write(unit=lunit)this%volanac
6362if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6363if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6364if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6365
6366if (.not. present(unit)) close(unit=lunit)
6367
6368end subroutine vol7d_write_on_file
6369
6370
6377
6378
6379subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6380
6381TYPE(vol7d),INTENT(OUT) :: this
6382integer,intent(inout),optional :: unit
6383character(len=*),INTENT(in),optional :: filename
6384character(len=*),intent(out),optional :: filename_auto
6385character(len=*),INTENT(out),optional :: description
6386integer,intent(out),optional :: tarray(8)
6387
6388
6389integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6390 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6391 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6392 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6393 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6394 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6395 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6396
6397character(len=254) :: ldescription,lfilename,arg
6398integer :: ltarray(8),lunit,ios
6399logical :: opened,exist
6400
6401
6402call getarg(0,arg)
6403
6404if (.not. present(unit))then
6405 lunit=getunit()
6406else
6407 if (unit==0)then
6408 lunit=getunit()
6409 unit=lunit
6410 else
6411 lunit=unit
6412 end if
6413end if
6414
6415lfilename=trim(arg)//".v7d"
6417
6418if (present(filename))then
6419 if (filename /= "")then
6420 lfilename=filename
6421 end if
6422end if
6423
6424if (present(filename_auto))filename_auto=lfilename
6425
6426
6427inquire(unit=lunit,opened=opened)
6428IF (.NOT. opened) THEN
6429 inquire(file=lfilename,exist=exist)
6430 IF (.NOT.exist) THEN
6431 CALL l4f_log(l4f_fatal, &
6432 'in vol7d_read_from_file, file does not exists, cannot open')
6433 CALL raise_fatal_error()
6434 ENDIF
6435 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6436 status='OLD', action='READ')
6437 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6438end if
6439
6440
6442read(unit=lunit,iostat=ios)ldescription
6443
6444if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6445 call vol7d_alloc (this)
6446 call vol7d_alloc_vol (this)
6447 if (present(description))description=ldescription
6448 if (present(tarray))tarray=ltarray
6449 if (.not. present(unit)) close(unit=lunit)
6450end if
6451
6452read(unit=lunit)ltarray
6453
6454CALL l4f_log(l4f_info, 'Reading vol7d from file')
6455CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6458
6459if (present(description))description=ldescription
6460if (present(tarray))tarray=ltarray
6461
6462read(unit=lunit)&
6463 nana, ntime, ntimerange, nlevel, nnetwork, &
6464 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6465 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6466 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6467 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6468 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6469 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6470 this%time_definition
6471
6472call vol7d_alloc (this, &
6473 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6474 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6475 ndativard=ndativard, ndativarc=ndativarc,&
6476 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6477 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6478 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6479 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6480 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6481 nanavard=nanavard, nanavarc=nanavarc,&
6482 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6483 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6484 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
6485 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
6486
6487
6490if (associated(this%level)) read(unit=lunit)this%level
6491if (associated(this%timerange)) read(unit=lunit)this%timerange
6492if (associated(this%network)) read(unit=lunit)this%network
6493
6494if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
6495if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
6496if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
6497if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
6498if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
6499
6500if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
6501if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
6502if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
6503if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
6504if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
6505
6506if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
6507if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
6508if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
6509if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
6510if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
6511
6512if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
6513if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
6514if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
6515if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
6516if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
6517
6518if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
6519if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
6520if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
6521if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
6522if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
6523
6524if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
6525if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
6526if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
6527if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
6528if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
6529
6530call vol7d_alloc_vol (this)
6531
6532!! Volumi di valori e attributi per anagrafica e dati
6533
6534if (associated(this%volanar)) read(unit=lunit)this%volanar
6535if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
6536if (associated(this%voldatir)) read(unit=lunit)this%voldatir
6537if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
6538
6539if (associated(this%volanai)) read(unit=lunit)this%volanai
6540if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
6541if (associated(this%voldatii)) read(unit=lunit)this%voldatii
6542if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
6543
6544if (associated(this%volanab)) read(unit=lunit)this%volanab
6545if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
6546if (associated(this%voldatib)) read(unit=lunit)this%voldatib
6547if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
6548
6549if (associated(this%volanad)) read(unit=lunit)this%volanad
6550if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
6551if (associated(this%voldatid)) read(unit=lunit)this%voldatid
6552if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
6553
6554if (associated(this%volanac)) read(unit=lunit)this%volanac
6555if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
6556if (associated(this%voldatic)) read(unit=lunit)this%voldatic
6557if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
6558
6559if (.not. present(unit)) close(unit=lunit)
6560
6561end subroutine vol7d_read_from_file
6562
6563
6564! to double precision
6565elemental doubleprecision function doubledatd(voldat,var)
6566doubleprecision,intent(in) :: voldat
6567type(vol7d_var),intent(in) :: var
6568
6569doubledatd=voldat
6570
6571end function doubledatd
6572
6573
6574elemental doubleprecision function doubledatr(voldat,var)
6575real,intent(in) :: voldat
6576type(vol7d_var),intent(in) :: var
6577
6579 doubledatr=dble(voldat)
6580else
6581 doubledatr=dmiss
6582end if
6583
6584end function doubledatr
6585
6586
6587elemental doubleprecision function doubledati(voldat,var)
6588integer,intent(in) :: voldat
6589type(vol7d_var),intent(in) :: var
6590
6593 doubledati=dble(voldat)/10.d0**var%scalefactor
6594 else
6595 doubledati=dble(voldat)
6596 endif
6597else
6598 doubledati=dmiss
6599end if
6600
6601end function doubledati
6602
6603
6604elemental doubleprecision function doubledatb(voldat,var)
6605integer(kind=int_b),intent(in) :: voldat
6606type(vol7d_var),intent(in) :: var
6607
6610 doubledatb=dble(voldat)/10.d0**var%scalefactor
6611 else
6612 doubledatb=dble(voldat)
6613 endif
6614else
6615 doubledatb=dmiss
6616end if
6617
6618end function doubledatb
6619
6620
6621elemental doubleprecision function doubledatc(voldat,var)
6622CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6623type(vol7d_var),intent(in) :: var
6624
6625doubledatc = c2d(voldat)
6627 doubledatc=doubledatc/10.d0**var%scalefactor
6628end if
6629
6630end function doubledatc
6631
6632
6633! to integer
6634elemental integer function integerdatd(voldat,var)
6635doubleprecision,intent(in) :: voldat
6636type(vol7d_var),intent(in) :: var
6637
6640 integerdatd=nint(voldat*10d0**var%scalefactor)
6641 else
6642 integerdatd=nint(voldat)
6643 endif
6644else
6645 integerdatd=imiss
6646end if
6647
6648end function integerdatd
6649
6650
6651elemental integer function integerdatr(voldat,var)
6652real,intent(in) :: voldat
6653type(vol7d_var),intent(in) :: var
6654
6657 integerdatr=nint(voldat*10d0**var%scalefactor)
6658 else
6659 integerdatr=nint(voldat)
6660 endif
6661else
6662 integerdatr=imiss
6663end if
6664
6665end function integerdatr
6666
6667
6668elemental integer function integerdati(voldat,var)
6669integer,intent(in) :: voldat
6670type(vol7d_var),intent(in) :: var
6671
6672integerdati=voldat
6673
6674end function integerdati
6675
6676
6677elemental integer function integerdatb(voldat,var)
6678integer(kind=int_b),intent(in) :: voldat
6679type(vol7d_var),intent(in) :: var
6680
6682 integerdatb=voldat
6683else
6684 integerdatb=imiss
6685end if
6686
6687end function integerdatb
6688
6689
6690elemental integer function integerdatc(voldat,var)
6691CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6692type(vol7d_var),intent(in) :: var
6693
6694integerdatc=c2i(voldat)
6695
6696end function integerdatc
6697
6698
6699! to real
6700elemental real function realdatd(voldat,var)
6701doubleprecision,intent(in) :: voldat
6702type(vol7d_var),intent(in) :: var
6703
6705 realdatd=real(voldat)
6706else
6707 realdatd=rmiss
6708end if
6709
6710end function realdatd
6711
6712
6713elemental real function realdatr(voldat,var)
6714real,intent(in) :: voldat
6715type(vol7d_var),intent(in) :: var
6716
6717realdatr=voldat
6718
6719end function realdatr
6720
6721
6722elemental real function realdati(voldat,var)
6723integer,intent(in) :: voldat
6724type(vol7d_var),intent(in) :: var
6725
6728 realdati=float(voldat)/10.**var%scalefactor
6729 else
6730 realdati=float(voldat)
6731 endif
6732else
6733 realdati=rmiss
6734end if
6735
6736end function realdati
6737
6738
6739elemental real function realdatb(voldat,var)
6740integer(kind=int_b),intent(in) :: voldat
6741type(vol7d_var),intent(in) :: var
6742
6745 realdatb=float(voldat)/10**var%scalefactor
6746 else
6747 realdatb=float(voldat)
6748 endif
6749else
6750 realdatb=rmiss
6751end if
6752
6753end function realdatb
6754
6755
6756elemental real function realdatc(voldat,var)
6757CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
6758type(vol7d_var),intent(in) :: var
6759
6760realdatc=c2r(voldat)
6762 realdatc=realdatc/10.**var%scalefactor
6763end if
6764
6765end function realdatc
6766
6767
6773FUNCTION realanavol(this, var) RESULT(vol)
6774TYPE(vol7d),INTENT(in) :: this
6775TYPE(vol7d_var),INTENT(in) :: var
6776REAL :: vol(SIZE(this%ana),size(this%network))
6777
6778CHARACTER(len=1) :: dtype
6779INTEGER :: indvar
6780
6781dtype = cmiss
6782indvar = index(this%anavar, var, type=dtype)
6783
6784IF (indvar > 0) THEN
6785 SELECT CASE (dtype)
6786 CASE("d")
6787 vol = realdat(this%volanad(:,indvar,:), var)
6788 CASE("r")
6789 vol = this%volanar(:,indvar,:)
6790 CASE("i")
6791 vol = realdat(this%volanai(:,indvar,:), var)
6792 CASE("b")
6793 vol = realdat(this%volanab(:,indvar,:), var)
6794 CASE("c")
6795 vol = realdat(this%volanac(:,indvar,:), var)
6796 CASE default
6797 vol = rmiss
6798 END SELECT
6799ELSE
6800 vol = rmiss
6801ENDIF
6802
6803END FUNCTION realanavol
6804
6805
6811FUNCTION integeranavol(this, var) RESULT(vol)
6812TYPE(vol7d),INTENT(in) :: this
6813TYPE(vol7d_var),INTENT(in) :: var
6814INTEGER :: vol(SIZE(this%ana),size(this%network))
6815
6816CHARACTER(len=1) :: dtype
6817INTEGER :: indvar
6818
6819dtype = cmiss
6820indvar = index(this%anavar, var, type=dtype)
6821
6822IF (indvar > 0) THEN
6823 SELECT CASE (dtype)
6824 CASE("d")
6825 vol = integerdat(this%volanad(:,indvar,:), var)
6826 CASE("r")
6827 vol = integerdat(this%volanar(:,indvar,:), var)
6828 CASE("i")
6829 vol = this%volanai(:,indvar,:)
6830 CASE("b")
6831 vol = integerdat(this%volanab(:,indvar,:), var)
6832 CASE("c")
6833 vol = integerdat(this%volanac(:,indvar,:), var)
6834 CASE default
6835 vol = imiss
6836 END SELECT
6837ELSE
6838 vol = imiss
6839ENDIF
6840
6841END FUNCTION integeranavol
6842
6843
6849subroutine move_datac (v7d,&
6850 indana,indtime,indlevel,indtimerange,indnetwork,&
6851 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6852
6853TYPE(vol7d),intent(inout) :: v7d
6854
6855integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6856integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6857integer :: inddativar,inddativarattr
6858
6859
6860do inddativar=1,size(v7d%dativar%c)
6861
6863 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6864 ) then
6865
6866 ! dati
6867 v7d%voldatic &
6868 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6869 v7d%voldatic &
6870 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6871
6872
6873 ! attributi
6874 if (associated (v7d%dativarattr%i)) then
6875 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
6876 if (inddativarattr > 0 ) then
6877 v7d%voldatiattri &
6878 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6879 v7d%voldatiattri &
6880 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6881 end if
6882 end if
6883
6884 if (associated (v7d%dativarattr%r)) then
6885 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
6886 if (inddativarattr > 0 ) then
6887 v7d%voldatiattrr &
6888 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6889 v7d%voldatiattrr &
6890 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6891 end if
6892 end if
6893
6894 if (associated (v7d%dativarattr%d)) then
6895 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
6896 if (inddativarattr > 0 ) then
6897 v7d%voldatiattrd &
6898 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6899 v7d%voldatiattrd &
6900 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6901 end if
6902 end if
6903
6904 if (associated (v7d%dativarattr%b)) then
6905 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
6906 if (inddativarattr > 0 ) then
6907 v7d%voldatiattrb &
6908 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6909 v7d%voldatiattrb &
6910 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6911 end if
6912 end if
6913
6914 if (associated (v7d%dativarattr%c)) then
6915 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
6916 if (inddativarattr > 0 ) then
6917 v7d%voldatiattrc &
6918 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6919 v7d%voldatiattrc &
6920 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6921 end if
6922 end if
6923
6924 end if
6925
6926end do
6927
6928end subroutine move_datac
6929
6935subroutine move_datar (v7d,&
6936 indana,indtime,indlevel,indtimerange,indnetwork,&
6937 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
6938
6939TYPE(vol7d),intent(inout) :: v7d
6940
6941integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
6942integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
6943integer :: inddativar,inddativarattr
6944
6945
6946do inddativar=1,size(v7d%dativar%r)
6947
6949 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
6950 ) then
6951
6952 ! dati
6953 v7d%voldatir &
6954 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
6955 v7d%voldatir &
6956 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
6957
6958
6959 ! attributi
6960 if (associated (v7d%dativarattr%i)) then
6961 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
6962 if (inddativarattr > 0 ) then
6963 v7d%voldatiattri &
6964 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6965 v7d%voldatiattri &
6966 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6967 end if
6968 end if
6969
6970 if (associated (v7d%dativarattr%r)) then
6971 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
6972 if (inddativarattr > 0 ) then
6973 v7d%voldatiattrr &
6974 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6975 v7d%voldatiattrr &
6976 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6977 end if
6978 end if
6979
6980 if (associated (v7d%dativarattr%d)) then
6981 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
6982 if (inddativarattr > 0 ) then
6983 v7d%voldatiattrd &
6984 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6985 v7d%voldatiattrd &
6986 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6987 end if
6988 end if
6989
6990 if (associated (v7d%dativarattr%b)) then
6991 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
6992 if (inddativarattr > 0 ) then
6993 v7d%voldatiattrb &
6994 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
6995 v7d%voldatiattrb &
6996 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
6997 end if
6998 end if
6999
7000 if (associated (v7d%dativarattr%c)) then
7001 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
7002 if (inddativarattr > 0 ) then
7003 v7d%voldatiattrc &
7004 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7005 v7d%voldatiattrc &
7006 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7007 end if
7008 end if
7009
7010 end if
7011
7012end do
7013
7014end subroutine move_datar
7015
7016
7030subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
7031type(vol7d),intent(inout) :: v7din
7032type(vol7d),intent(out) :: v7dout
7033type(vol7d_level),intent(in),optional :: level(:)
7034type(vol7d_timerange),intent(in),optional :: timerange(:)
7035!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
7036!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
7037logical,intent(in),optional :: nostatproc
7038
7039integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
7040integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
7041type(vol7d_level) :: roundlevel(size(v7din%level))
7042type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
7043type(vol7d) :: v7d_tmp
7044
7045
7046nbin=0
7047
7048if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
7049if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
7050if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
7051if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
7052
7054
7055roundlevel=v7din%level
7056
7057if (present(level))then
7058 do ilevel = 1, size(v7din%level)
7059 if ((any(v7din%level(ilevel) .almosteq. level))) then
7060 roundlevel(ilevel)=level(1)
7061 end if
7062 end do
7063end if
7064
7065roundtimerange=v7din%timerange
7066
7067if (present(timerange))then
7068 do itimerange = 1, size(v7din%timerange)
7069 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
7070 roundtimerange(itimerange)=timerange(1)
7071 end if
7072 end do
7073end if
7074
7075!set istantaneous values everywere
7076!preserve p1 for forecast time
7077if (optio_log(nostatproc)) then
7078 roundtimerange(:)%timerange=254
7079 roundtimerange(:)%p2=0
7080end if
7081
7082
7083nana=size(v7din%ana)
7084nlevel=count_distinct(roundlevel,back=.true.)
7085ntime=size(v7din%time)
7086ntimerange=count_distinct(roundtimerange,back=.true.)
7087nnetwork=size(v7din%network)
7088
7090
7091if (nbin == 0) then
7093else
7094 call vol7d_convr(v7din,v7d_tmp)
7095end if
7096
7097v7d_tmp%level=roundlevel
7098v7d_tmp%timerange=roundtimerange
7099
7100do ilevel=1, size(v7d_tmp%level)
7101 indl=index(v7d_tmp%level,roundlevel(ilevel))
7102 do itimerange=1,size(v7d_tmp%timerange)
7103 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
7104
7105 if (indl /= ilevel .or. indt /= itimerange) then
7106
7107 do iana=1, nana
7108 do itime=1,ntime
7109 do inetwork=1,nnetwork
7110
7111 if (nbin > 0) then
7112 call move_datar (v7d_tmp,&
7113 iana,itime,ilevel,itimerange,inetwork,&
7114 iana,itime,indl,indt,inetwork)
7115 else
7116 call move_datac (v7d_tmp,&
7117 iana,itime,ilevel,itimerange,inetwork,&
7118 iana,itime,indl,indt,inetwork)
7119 end if
7120
7121 end do
7122 end do
7123 end do
7124
7125 end if
7126
7127 end do
7128end do
7129
7130! set to missing level and time > nlevel
7131do ilevel=nlevel+1,size(v7d_tmp%level)
7133end do
7134
7135do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7137end do
7138
7139!copy with remove
7142
7143!call display(v7dout)
7144
7145end subroutine v7d_rounding
7146
7147
7149
7155
7156
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 |