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