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