libsim Versione 7.1.11

◆ vol7d_get_volanaattrr()

subroutine vol7d_get_volanaattrr ( type(vol7d), intent(in)  this,
integer, dimension(:), intent(in)  dimlist,
real, dimension(:), optional, pointer  vol1dp,
real, dimension(:,:), optional, pointer  vol2dp,
real, dimension(:,:,:), optional, pointer  vol3dp,
real, dimension(:,:,:,:), optional, pointer  vol4dp 
)

Crea una vista a dimensione ridotta di un volume di attributi di anagrafica di tipo REAL.

È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio:

REAL, POINTER :: vol1d(:)
...
CALL vol7d_get_volanaattrr(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d

Definizione alla linea 3598 del file vol7d_class.F90.

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

Generated with Doxygen.