libsim Versione 7.1.11

◆ vol7d_get_voldatiattrd()

subroutine vol7d_get_voldatiattrd ( type(vol7d), intent(in)  this,
integer, dimension(:), intent(in)  dimlist,
double precision, dimension(:), optional, pointer  vol1dp,
double precision, dimension(:,:), optional, pointer  vol2dp,
double precision, dimension(:,:,:), optional, pointer  vol3dp,
double precision, dimension(:,:,:,:), optional, pointer  vol4dp,
double precision, dimension(:,:,:,:,:), optional, pointer  vol5dp,
double precision, dimension(:,:,:,:,:,:), optional, pointer  vol6dp,
double precision, dimension(:,:,:,:,:,:,:), optional, pointer  vol7dp 
)

Crea una vista a dimensione ridotta di un volume di attributi di dati di tipo DOUBLE PRECISION.

È 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:

DOUBLE PRECISION, POINTER :: vol2d(:,:)
...
CALL vol7d_get_voldatiattrd(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
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_d ... vol7d_attr_d, 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
vol5dparray che in uscita conterrà la vista 5d
vol6dparray che in uscita conterrà la vista 6d
vol7dparray che in uscita conterrà la vista 7d

Definizione alla linea 4383 del file vol7d_class.F90.

4385! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
4386! authors:
4387! Davide Cesari <dcesari@arpa.emr.it>
4388! Paolo Patruno <ppatruno@arpa.emr.it>
4389
4390! This program is free software; you can redistribute it and/or
4391! modify it under the terms of the GNU General Public License as
4392! published by the Free Software Foundation; either version 2 of
4393! the License, or (at your option) any later version.
4394
4395! This program is distributed in the hope that it will be useful,
4396! but WITHOUT ANY WARRANTY; without even the implied warranty of
4397! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4398! GNU General Public License for more details.
4399
4400! You should have received a copy of the GNU General Public License
4401! along with this program. If not, see <http://www.gnu.org/licenses/>.
4402#include "config.h"
4403
4415
4469MODULE vol7d_class
4470USE kinds
4474USE log4fortran
4475USE err_handling
4476USE io_units
4483IMPLICIT NONE
4484
4485
4486INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
4487 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
4488
4489INTEGER, PARAMETER :: vol7d_ana_a=1
4490INTEGER, PARAMETER :: vol7d_var_a=2
4491INTEGER, PARAMETER :: vol7d_network_a=3
4492INTEGER, PARAMETER :: vol7d_attr_a=4
4493INTEGER, PARAMETER :: vol7d_ana_d=1
4494INTEGER, PARAMETER :: vol7d_time_d=2
4495INTEGER, PARAMETER :: vol7d_level_d=3
4496INTEGER, PARAMETER :: vol7d_timerange_d=4
4497INTEGER, PARAMETER :: vol7d_var_d=5
4498INTEGER, PARAMETER :: vol7d_network_d=6
4499INTEGER, PARAMETER :: vol7d_attr_d=7
4500INTEGER, PARAMETER :: vol7d_cdatalen=32
4501
4502TYPE vol7d_varmap
4503 INTEGER :: r, d, i, b, c
4504END TYPE vol7d_varmap
4505
4508TYPE vol7d
4510 TYPE(vol7d_ana),POINTER :: ana(:)
4512 TYPE(datetime),POINTER :: time(:)
4514 TYPE(vol7d_level),POINTER :: level(:)
4516 TYPE(vol7d_timerange),POINTER :: timerange(:)
4518 TYPE(vol7d_network),POINTER :: network(:)
4520 TYPE(vol7d_varvect) :: anavar
4522 TYPE(vol7d_varvect) :: anaattr
4524 TYPE(vol7d_varvect) :: anavarattr
4526 TYPE(vol7d_varvect) :: dativar
4528 TYPE(vol7d_varvect) :: datiattr
4530 TYPE(vol7d_varvect) :: dativarattr
4531
4533 REAL,POINTER :: volanar(:,:,:)
4535 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
4537 INTEGER,POINTER :: volanai(:,:,:)
4539 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
4541 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
4542
4544 REAL,POINTER :: volanaattrr(:,:,:,:)
4546 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
4548 INTEGER,POINTER :: volanaattri(:,:,:,:)
4550 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
4552 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
4553
4555 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
4557 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
4559 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
4561 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
4563 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
4564
4566 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
4568 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
4570 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
4572 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
4574 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
4575
4577 integer :: time_definition
4578
4579END TYPE vol7d
4580
4584INTERFACE init
4585 MODULE PROCEDURE vol7d_init
4586END INTERFACE
4587
4589INTERFACE delete
4590 MODULE PROCEDURE vol7d_delete
4591END INTERFACE
4592
4594INTERFACE export
4595 MODULE PROCEDURE vol7d_write_on_file
4596END INTERFACE
4597
4599INTERFACE import
4600 MODULE PROCEDURE vol7d_read_from_file
4601END INTERFACE
4602
4604INTERFACE display
4605 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
4606END INTERFACE
4607
4609INTERFACE to_char
4610 MODULE PROCEDURE to_char_dat
4611END INTERFACE
4612
4614INTERFACE doubledat
4615 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4616END INTERFACE
4617
4619INTERFACE realdat
4620 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
4621END INTERFACE
4622
4624INTERFACE integerdat
4625 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
4626END INTERFACE
4627
4629INTERFACE copy
4630 MODULE PROCEDURE vol7d_copy
4631END INTERFACE
4632
4634INTERFACE c_e
4635 MODULE PROCEDURE vol7d_c_e
4636END INTERFACE
4637
4641INTERFACE check
4642 MODULE PROCEDURE vol7d_check
4643END INTERFACE
4644
4658INTERFACE rounding
4659 MODULE PROCEDURE v7d_rounding
4660END INTERFACE
4661
4662!!$INTERFACE get_volana
4663!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
4664!!$ vol7d_get_volanab, vol7d_get_volanac
4665!!$END INTERFACE
4666!!$
4667!!$INTERFACE get_voldati
4668!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
4669!!$ vol7d_get_voldatib, vol7d_get_voldatic
4670!!$END INTERFACE
4671!!$
4672!!$INTERFACE get_volanaattr
4673!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
4674!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
4675!!$END INTERFACE
4676!!$
4677!!$INTERFACE get_voldatiattr
4678!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
4679!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
4680!!$END INTERFACE
4681
4682PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
4683 vol7d_get_volc, &
4684 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
4685 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
4686 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
4687 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
4688 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
4689 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
4690 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
4691 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
4692 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
4693 vol7d_display, dat_display, dat_vect_display, &
4694 to_char_dat, vol7d_check
4695
4696PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4697
4698PRIVATE vol7d_c_e
4699
4700CONTAINS
4701
4702
4707SUBROUTINE vol7d_init(this,time_definition)
4708TYPE(vol7d),intent(out) :: this
4709integer,INTENT(IN),OPTIONAL :: time_definition
4710
4711CALL init(this%anavar)
4712CALL init(this%anaattr)
4713CALL init(this%anavarattr)
4714CALL init(this%dativar)
4715CALL init(this%datiattr)
4716CALL init(this%dativarattr)
4717CALL vol7d_var_features_init() ! initialise var features table once
4718
4719NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
4720
4721NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
4722NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
4723NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
4724NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
4725NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
4726
4727if(present(time_definition)) then
4728 this%time_definition=time_definition
4729else
4730 this%time_definition=1 !default to validity time
4731end if
4732
4733END SUBROUTINE vol7d_init
4734
4735
4739ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
4740TYPE(vol7d),intent(inout) :: this
4741LOGICAL, INTENT(in), OPTIONAL :: dataonly
4742
4743
4744IF (.NOT. optio_log(dataonly)) THEN
4745 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
4746 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
4747 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
4748 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
4749 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
4750 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
4751 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
4752 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
4753 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
4754 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
4755ENDIF
4756IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
4757IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
4758IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
4759IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
4760IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
4761IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
4762IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
4763IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
4764IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
4765IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
4766
4767IF (.NOT. optio_log(dataonly)) THEN
4768 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4769 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4770ENDIF
4771IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4772IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4773IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4774
4775IF (.NOT. optio_log(dataonly)) THEN
4776 CALL delete(this%anavar)
4777 CALL delete(this%anaattr)
4778 CALL delete(this%anavarattr)
4779ENDIF
4780CALL delete(this%dativar)
4781CALL delete(this%datiattr)
4782CALL delete(this%dativarattr)
4783
4784END SUBROUTINE vol7d_delete
4785
4786
4787
4788integer function vol7d_check(this)
4789TYPE(vol7d),intent(in) :: this
4790integer :: i,j,k,l,m,n
4791
4792vol7d_check=0
4793
4794if (associated(this%voldatii)) then
4795do i = 1,size(this%voldatii,1)
4796 do j = 1,size(this%voldatii,2)
4797 do k = 1,size(this%voldatii,3)
4798 do l = 1,size(this%voldatii,4)
4799 do m = 1,size(this%voldatii,5)
4800 do n = 1,size(this%voldatii,6)
4801 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4802 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4803 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4804 vol7d_check=1
4805 end if
4806 end do
4807 end do
4808 end do
4809 end do
4810 end do
4811end do
4812end if
4813
4814
4815if (associated(this%voldatir)) then
4816do i = 1,size(this%voldatir,1)
4817 do j = 1,size(this%voldatir,2)
4818 do k = 1,size(this%voldatir,3)
4819 do l = 1,size(this%voldatir,4)
4820 do m = 1,size(this%voldatir,5)
4821 do n = 1,size(this%voldatir,6)
4822 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4823 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4824 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4825 vol7d_check=2
4826 end if
4827 end do
4828 end do
4829 end do
4830 end do
4831 end do
4832end do
4833end if
4834
4835if (associated(this%voldatid)) then
4836do i = 1,size(this%voldatid,1)
4837 do j = 1,size(this%voldatid,2)
4838 do k = 1,size(this%voldatid,3)
4839 do l = 1,size(this%voldatid,4)
4840 do m = 1,size(this%voldatid,5)
4841 do n = 1,size(this%voldatid,6)
4842 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4843 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4844 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4845 vol7d_check=3
4846 end if
4847 end do
4848 end do
4849 end do
4850 end do
4851 end do
4852end do
4853end if
4854
4855if (associated(this%voldatib)) then
4856do i = 1,size(this%voldatib,1)
4857 do j = 1,size(this%voldatib,2)
4858 do k = 1,size(this%voldatib,3)
4859 do l = 1,size(this%voldatib,4)
4860 do m = 1,size(this%voldatib,5)
4861 do n = 1,size(this%voldatib,6)
4862 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4863 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4864 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4865 vol7d_check=4
4866 end if
4867 end do
4868 end do
4869 end do
4870 end do
4871 end do
4872end do
4873end if
4874
4875end function vol7d_check
4876
4877
4878
4879!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4881SUBROUTINE vol7d_display(this)
4882TYPE(vol7d),intent(in) :: this
4883integer :: i
4884
4885REAL :: rdat
4886DOUBLE PRECISION :: ddat
4887INTEGER :: idat
4888INTEGER(kind=int_b) :: bdat
4889CHARACTER(len=vol7d_cdatalen) :: cdat
4890
4891
4892print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4893if (this%time_definition == 0) then
4894 print*,"TIME DEFINITION: time is reference time"
4895else if (this%time_definition == 1) then
4896 print*,"TIME DEFINITION: time is validity time"
4897else
4898 print*,"Time definition have a wrong walue:", this%time_definition
4899end if
4900
4901IF (ASSOCIATED(this%network))then
4902 print*,"---- network vector ----"
4903 print*,"elements=",size(this%network)
4904 do i=1, size(this%network)
4905 call display(this%network(i))
4906 end do
4907end IF
4908
4909IF (ASSOCIATED(this%ana))then
4910 print*,"---- ana vector ----"
4911 print*,"elements=",size(this%ana)
4912 do i=1, size(this%ana)
4913 call display(this%ana(i))
4914 end do
4915end IF
4916
4917IF (ASSOCIATED(this%time))then
4918 print*,"---- time vector ----"
4919 print*,"elements=",size(this%time)
4920 do i=1, size(this%time)
4921 call display(this%time(i))
4922 end do
4923end if
4924
4925IF (ASSOCIATED(this%level)) then
4926 print*,"---- level vector ----"
4927 print*,"elements=",size(this%level)
4928 do i =1,size(this%level)
4929 call display(this%level(i))
4930 end do
4931end if
4932
4933IF (ASSOCIATED(this%timerange))then
4934 print*,"---- timerange vector ----"
4935 print*,"elements=",size(this%timerange)
4936 do i =1,size(this%timerange)
4937 call display(this%timerange(i))
4938 end do
4939end if
4940
4941
4942print*,"---- ana vector ----"
4943print*,""
4944print*,"->>>>>>>>> anavar -"
4945call display(this%anavar)
4946print*,""
4947print*,"->>>>>>>>> anaattr -"
4948call display(this%anaattr)
4949print*,""
4950print*,"->>>>>>>>> anavarattr -"
4951call display(this%anavarattr)
4952
4953print*,"-- ana data section (first point) --"
4954
4955idat=imiss
4956rdat=rmiss
4957ddat=dmiss
4958bdat=ibmiss
4959cdat=cmiss
4960
4961!ntime = MIN(SIZE(this%time),nprint)
4962!ntimerange = MIN(SIZE(this%timerange),nprint)
4963!nlevel = MIN(SIZE(this%level),nprint)
4964!nnetwork = MIN(SIZE(this%network),nprint)
4965!nana = MIN(SIZE(this%ana),nprint)
4966
4967IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4968if (associated(this%volanai)) then
4969 do i=1,size(this%anavar%i)
4970 idat=this%volanai(1,i,1)
4971 if (associated(this%anavar%i)) call display(this%anavar%i(i),idat,rdat,ddat,bdat,cdat)
4972 end do
4973end if
4974idat=imiss
4975
4976if (associated(this%volanar)) then
4977 do i=1,size(this%anavar%r)
4978 rdat=this%volanar(1,i,1)
4979 if (associated(this%anavar%r)) call display(this%anavar%r(i),idat,rdat,ddat,bdat,cdat)
4980 end do
4981end if
4982rdat=rmiss
4983
4984if (associated(this%volanad)) then
4985 do i=1,size(this%anavar%d)
4986 ddat=this%volanad(1,i,1)
4987 if (associated(this%anavar%d)) call display(this%anavar%d(i),idat,rdat,ddat,bdat,cdat)
4988 end do
4989end if
4990ddat=dmiss
4991
4992if (associated(this%volanab)) then
4993 do i=1,size(this%anavar%b)
4994 bdat=this%volanab(1,i,1)
4995 if (associated(this%anavar%b)) call display(this%anavar%b(i),idat,rdat,ddat,bdat,cdat)
4996 end do
4997end if
4998bdat=ibmiss
4999
5000if (associated(this%volanac)) then
5001 do i=1,size(this%anavar%c)
5002 cdat=this%volanac(1,i,1)
5003 if (associated(this%anavar%c)) call display(this%anavar%c(i),idat,rdat,ddat,bdat,cdat)
5004 end do
5005end if
5006cdat=cmiss
5007ENDIF
5008
5009print*,"---- data vector ----"
5010print*,""
5011print*,"->>>>>>>>> dativar -"
5012call display(this%dativar)
5013print*,""
5014print*,"->>>>>>>>> datiattr -"
5015call display(this%datiattr)
5016print*,""
5017print*,"->>>>>>>>> dativarattr -"
5018call display(this%dativarattr)
5019
5020print*,"-- data data section (first point) --"
5021
5022idat=imiss
5023rdat=rmiss
5024ddat=dmiss
5025bdat=ibmiss
5026cdat=cmiss
5027
5028IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
5029 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
5030if (associated(this%voldatii)) then
5031 do i=1,size(this%dativar%i)
5032 idat=this%voldatii(1,1,1,1,i,1)
5033 if (associated(this%dativar%i)) call display(this%dativar%i(i),idat,rdat,ddat,bdat,cdat)
5034 end do
5035end if
5036idat=imiss
5037
5038if (associated(this%voldatir)) then
5039 do i=1,size(this%dativar%r)
5040 rdat=this%voldatir(1,1,1,1,i,1)
5041 if (associated(this%dativar%r)) call display(this%dativar%r(i),idat,rdat,ddat,bdat,cdat)
5042 end do
5043end if
5044rdat=rmiss
5045
5046if (associated(this%voldatid)) then
5047 do i=1,size(this%dativar%d)
5048 ddat=this%voldatid(1,1,1,1,i,1)
5049 if (associated(this%dativar%d)) call display(this%dativar%d(i),idat,rdat,ddat,bdat,cdat)
5050 end do
5051end if
5052ddat=dmiss
5053
5054if (associated(this%voldatib)) then
5055 do i=1,size(this%dativar%b)
5056 bdat=this%voldatib(1,1,1,1,i,1)
5057 if (associated(this%dativar%b)) call display(this%dativar%b(i),idat,rdat,ddat,bdat,cdat)
5058 end do
5059end if
5060bdat=ibmiss
5061
5062if (associated(this%voldatic)) then
5063 do i=1,size(this%dativar%c)
5064 cdat=this%voldatic(1,1,1,1,i,1)
5065 if (associated(this%dativar%c)) call display(this%dativar%c(i),idat,rdat,ddat,bdat,cdat)
5066 end do
5067end if
5068cdat=cmiss
5069ENDIF
5070
5071print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
5072
5073END SUBROUTINE vol7d_display
5074
5075
5077SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
5078TYPE(vol7d_var),intent(in) :: this
5080REAL :: rdat
5082DOUBLE PRECISION :: ddat
5084INTEGER :: idat
5086INTEGER(kind=int_b) :: bdat
5088CHARACTER(len=*) :: cdat
5089
5090print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5091
5092end SUBROUTINE dat_display
5093
5095SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
5096
5097TYPE(vol7d_var),intent(in) :: this(:)
5099REAL :: rdat(:)
5101DOUBLE PRECISION :: ddat(:)
5103INTEGER :: idat(:)
5105INTEGER(kind=int_b) :: bdat(:)
5107CHARACTER(len=*):: cdat(:)
5108
5109integer :: i
5110
5111do i =1,size(this)
5112 call display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
5113end do
5114
5115end SUBROUTINE dat_vect_display
5116
5117
5118FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5119#ifdef HAVE_DBALLE
5120USE dballef
5121#endif
5122TYPE(vol7d_var),INTENT(in) :: this
5124REAL :: rdat
5126DOUBLE PRECISION :: ddat
5128INTEGER :: idat
5130INTEGER(kind=int_b) :: bdat
5132CHARACTER(len=*) :: cdat
5133CHARACTER(len=80) :: to_char_dat
5134
5135CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
5136
5137
5138#ifdef HAVE_DBALLE
5139INTEGER :: handle, ier
5140
5141handle = 0
5142to_char_dat="VALUE: "
5143
5144if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5145if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5146if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5147if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5148
5149if ( c_e(cdat))then
5150 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
5151 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
5152 ier = idba_fatto(handle)
5153 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
5154endif
5155
5156#else
5157
5158to_char_dat="VALUE: "
5159if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5160if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5161if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5162if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5163if (c_e(cdat)) to_char_dat=trim(to_char_dat)//" ;char> "//trim(cdat)
5164
5165#endif
5166
5167END FUNCTION to_char_dat
5168
5169
5172FUNCTION vol7d_c_e(this) RESULT(c_e)
5173TYPE(vol7d), INTENT(in) :: this
5174
5175LOGICAL :: c_e
5176
5177c_e = ASSOCIATED(this%ana) .OR. ASSOCIATED(this%time) .OR. &
5178 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5179 ASSOCIATED(this%network) .OR. &
5180 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5181 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5182 ASSOCIATED(this%anavar%c) .OR. &
5183 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5184 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5185 ASSOCIATED(this%anaattr%c) .OR. &
5186 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5187 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5188 ASSOCIATED(this%dativar%c) .OR. &
5189 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5190 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5191 ASSOCIATED(this%datiattr%c)
5192
5193END FUNCTION vol7d_c_e
5194
5195
5234SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5235 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5236 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5237 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5238 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5239 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5240 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5241 ini)
5242TYPE(vol7d),INTENT(inout) :: this
5243INTEGER,INTENT(in),OPTIONAL :: nana
5244INTEGER,INTENT(in),OPTIONAL :: ntime
5245INTEGER,INTENT(in),OPTIONAL :: nlevel
5246INTEGER,INTENT(in),OPTIONAL :: ntimerange
5247INTEGER,INTENT(in),OPTIONAL :: nnetwork
5249INTEGER,INTENT(in),OPTIONAL :: &
5250 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5251 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5252 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5253 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5254 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5255 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5256LOGICAL,INTENT(in),OPTIONAL :: ini
5257
5258INTEGER :: i
5259LOGICAL :: linit
5260
5261IF (PRESENT(ini)) THEN
5262 linit = ini
5263ELSE
5264 linit = .false.
5265ENDIF
5266
5267! Dimensioni principali
5268IF (PRESENT(nana)) THEN
5269 IF (nana >= 0) THEN
5270 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5271 ALLOCATE(this%ana(nana))
5272 IF (linit) THEN
5273 DO i = 1, nana
5274 CALL init(this%ana(i))
5275 ENDDO
5276 ENDIF
5277 ENDIF
5278ENDIF
5279IF (PRESENT(ntime)) THEN
5280 IF (ntime >= 0) THEN
5281 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5282 ALLOCATE(this%time(ntime))
5283 IF (linit) THEN
5284 DO i = 1, ntime
5285 CALL init(this%time(i))
5286 ENDDO
5287 ENDIF
5288 ENDIF
5289ENDIF
5290IF (PRESENT(nlevel)) THEN
5291 IF (nlevel >= 0) THEN
5292 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5293 ALLOCATE(this%level(nlevel))
5294 IF (linit) THEN
5295 DO i = 1, nlevel
5296 CALL init(this%level(i))
5297 ENDDO
5298 ENDIF
5299 ENDIF
5300ENDIF
5301IF (PRESENT(ntimerange)) THEN
5302 IF (ntimerange >= 0) THEN
5303 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5304 ALLOCATE(this%timerange(ntimerange))
5305 IF (linit) THEN
5306 DO i = 1, ntimerange
5307 CALL init(this%timerange(i))
5308 ENDDO
5309 ENDIF
5310 ENDIF
5311ENDIF
5312IF (PRESENT(nnetwork)) THEN
5313 IF (nnetwork >= 0) THEN
5314 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5315 ALLOCATE(this%network(nnetwork))
5316 IF (linit) THEN
5317 DO i = 1, nnetwork
5318 CALL init(this%network(i))
5319 ENDDO
5320 ENDIF
5321 ENDIF
5322ENDIF
5323! Dimensioni dei tipi delle variabili
5324CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5325 nanavari, nanavarb, nanavarc, ini)
5326CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5327 nanaattri, nanaattrb, nanaattrc, ini)
5328CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5329 nanavarattri, nanavarattrb, nanavarattrc, ini)
5330CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5331 ndativari, ndativarb, ndativarc, ini)
5332CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5333 ndatiattri, ndatiattrb, ndatiattrc, ini)
5334CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5335 ndativarattri, ndativarattrb, ndativarattrc, ini)
5336
5337END SUBROUTINE vol7d_alloc
5338
5339
5340FUNCTION vol7d_check_alloc_ana(this)
5341TYPE(vol7d),INTENT(in) :: this
5342LOGICAL :: vol7d_check_alloc_ana
5343
5344vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5345
5346END FUNCTION vol7d_check_alloc_ana
5347
5348SUBROUTINE vol7d_force_alloc_ana(this, ini)
5349TYPE(vol7d),INTENT(inout) :: this
5350LOGICAL,INTENT(in),OPTIONAL :: ini
5351
5352! Alloco i descrittori minimi per avere un volume di anagrafica
5353IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5354IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5355
5356END SUBROUTINE vol7d_force_alloc_ana
5357
5358
5359FUNCTION vol7d_check_alloc_dati(this)
5360TYPE(vol7d),INTENT(in) :: this
5361LOGICAL :: vol7d_check_alloc_dati
5362
5363vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5364 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5365 ASSOCIATED(this%timerange)
5366
5367END FUNCTION vol7d_check_alloc_dati
5368
5369SUBROUTINE vol7d_force_alloc_dati(this, ini)
5370TYPE(vol7d),INTENT(inout) :: this
5371LOGICAL,INTENT(in),OPTIONAL :: ini
5372
5373! Alloco i descrittori minimi per avere un volume di dati
5374CALL vol7d_force_alloc_ana(this, ini)
5375IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5376IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5377IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5378
5379END SUBROUTINE vol7d_force_alloc_dati
5380
5381
5382SUBROUTINE vol7d_force_alloc(this)
5383TYPE(vol7d),INTENT(inout) :: this
5384
5385! If anything really not allocated yet, allocate with size 0
5386IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
5387IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
5388IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
5389IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
5390IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
5391
5392END SUBROUTINE vol7d_force_alloc
5393
5394
5395FUNCTION vol7d_check_vol(this)
5396TYPE(vol7d),INTENT(in) :: this
5397LOGICAL :: vol7d_check_vol
5398
5399vol7d_check_vol = c_e(this)
5400
5401! Anagrafica
5402IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5403 vol7d_check_vol = .false.
5404ENDIF
5405
5406IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5407 vol7d_check_vol = .false.
5408ENDIF
5409
5410IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5411 vol7d_check_vol = .false.
5412ENDIF
5413
5414IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5415 vol7d_check_vol = .false.
5416ENDIF
5417
5418IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5419 vol7d_check_vol = .false.
5420ENDIF
5421IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5422 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5423 ASSOCIATED(this%anavar%c)) THEN
5424 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
5425ENDIF
5426
5427! Attributi dell'anagrafica
5428IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5429 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5430 vol7d_check_vol = .false.
5431ENDIF
5432
5433IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5434 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5435 vol7d_check_vol = .false.
5436ENDIF
5437
5438IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5439 .NOT.ASSOCIATED(this%volanaattri)) THEN
5440 vol7d_check_vol = .false.
5441ENDIF
5442
5443IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5444 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5445 vol7d_check_vol = .false.
5446ENDIF
5447
5448IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5449 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5450 vol7d_check_vol = .false.
5451ENDIF
5452
5453! Dati
5454IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5455 vol7d_check_vol = .false.
5456ENDIF
5457
5458IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5459 vol7d_check_vol = .false.
5460ENDIF
5461
5462IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5463 vol7d_check_vol = .false.
5464ENDIF
5465
5466IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5467 vol7d_check_vol = .false.
5468ENDIF
5469
5470IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5471 vol7d_check_vol = .false.
5472ENDIF
5473
5474! Attributi dei dati
5475IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5476 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5477 vol7d_check_vol = .false.
5478ENDIF
5479
5480IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5481 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5482 vol7d_check_vol = .false.
5483ENDIF
5484
5485IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5486 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5487 vol7d_check_vol = .false.
5488ENDIF
5489
5490IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5491 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5492 vol7d_check_vol = .false.
5493ENDIF
5494
5495IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5496 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5497 vol7d_check_vol = .false.
5498ENDIF
5499IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5500 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5501 ASSOCIATED(this%dativar%c)) THEN
5502 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
5503ENDIF
5504
5505END FUNCTION vol7d_check_vol
5506
5507
5522SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
5523TYPE(vol7d),INTENT(inout) :: this
5524LOGICAL,INTENT(in),OPTIONAL :: ini
5525LOGICAL,INTENT(in),OPTIONAL :: inivol
5526
5527LOGICAL :: linivol
5528
5529IF (PRESENT(inivol)) THEN
5530 linivol = inivol
5531ELSE
5532 linivol = .true.
5533ENDIF
5534
5535! Anagrafica
5536IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5537 CALL vol7d_force_alloc_ana(this, ini)
5538 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
5539 IF (linivol) this%volanar(:,:,:) = rmiss
5540ENDIF
5541
5542IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5543 CALL vol7d_force_alloc_ana(this, ini)
5544 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
5545 IF (linivol) this%volanad(:,:,:) = rdmiss
5546ENDIF
5547
5548IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5549 CALL vol7d_force_alloc_ana(this, ini)
5550 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
5551 IF (linivol) this%volanai(:,:,:) = imiss
5552ENDIF
5553
5554IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5555 CALL vol7d_force_alloc_ana(this, ini)
5556 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
5557 IF (linivol) this%volanab(:,:,:) = ibmiss
5558ENDIF
5559
5560IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5561 CALL vol7d_force_alloc_ana(this, ini)
5562 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
5563 IF (linivol) this%volanac(:,:,:) = cmiss
5564ENDIF
5565
5566! Attributi dell'anagrafica
5567IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5568 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5569 CALL vol7d_force_alloc_ana(this, ini)
5570 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
5571 SIZE(this%network), SIZE(this%anaattr%r)))
5572 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
5573ENDIF
5574
5575IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5576 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5577 CALL vol7d_force_alloc_ana(this, ini)
5578 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
5579 SIZE(this%network), SIZE(this%anaattr%d)))
5580 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
5581ENDIF
5582
5583IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5584 .NOT.ASSOCIATED(this%volanaattri)) THEN
5585 CALL vol7d_force_alloc_ana(this, ini)
5586 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
5587 SIZE(this%network), SIZE(this%anaattr%i)))
5588 IF (linivol) this%volanaattri(:,:,:,:) = imiss
5589ENDIF
5590
5591IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5592 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5593 CALL vol7d_force_alloc_ana(this, ini)
5594 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
5595 SIZE(this%network), SIZE(this%anaattr%b)))
5596 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
5597ENDIF
5598
5599IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5600 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5601 CALL vol7d_force_alloc_ana(this, ini)
5602 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
5603 SIZE(this%network), SIZE(this%anaattr%c)))
5604 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
5605ENDIF
5606
5607! Dati
5608IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5609 CALL vol7d_force_alloc_dati(this, ini)
5610 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5611 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
5612 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
5613ENDIF
5614
5615IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5616 CALL vol7d_force_alloc_dati(this, ini)
5617 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5618 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
5619 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
5620ENDIF
5621
5622IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5623 CALL vol7d_force_alloc_dati(this, ini)
5624 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5625 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
5626 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
5627ENDIF
5628
5629IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5630 CALL vol7d_force_alloc_dati(this, ini)
5631 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5632 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
5633 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
5634ENDIF
5635
5636IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5637 CALL vol7d_force_alloc_dati(this, ini)
5638 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5639 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
5640 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
5641ENDIF
5642
5643! Attributi dei dati
5644IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5645 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5646 CALL vol7d_force_alloc_dati(this, ini)
5647 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5648 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
5649 SIZE(this%datiattr%r)))
5650 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
5651ENDIF
5652
5653IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5654 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5655 CALL vol7d_force_alloc_dati(this, ini)
5656 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5657 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
5658 SIZE(this%datiattr%d)))
5659 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
5660ENDIF
5661
5662IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5663 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5664 CALL vol7d_force_alloc_dati(this, ini)
5665 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5666 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
5667 SIZE(this%datiattr%i)))
5668 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
5669ENDIF
5670
5671IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5672 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5673 CALL vol7d_force_alloc_dati(this, ini)
5674 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5675 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
5676 SIZE(this%datiattr%b)))
5677 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
5678ENDIF
5679
5680IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5681 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5682 CALL vol7d_force_alloc_dati(this, ini)
5683 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5684 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
5685 SIZE(this%datiattr%c)))
5686 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
5687ENDIF
5688
5689! Catch-all method
5690CALL vol7d_force_alloc(this)
5691
5692! Creo gli indici var-attr
5693
5694#ifdef DEBUG
5695CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
5696#endif
5697
5698CALL vol7d_set_attr_ind(this)
5699
5700
5701
5702END SUBROUTINE vol7d_alloc_vol
5703
5704
5711SUBROUTINE vol7d_set_attr_ind(this)
5712TYPE(vol7d),INTENT(inout) :: this
5713
5714INTEGER :: i
5715
5716! real
5717IF (ASSOCIATED(this%dativar%r)) THEN
5718 IF (ASSOCIATED(this%dativarattr%r)) THEN
5719 DO i = 1, SIZE(this%dativar%r)
5720 this%dativar%r(i)%r = &
5721 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
5722 ENDDO
5723 ENDIF
5724
5725 IF (ASSOCIATED(this%dativarattr%d)) THEN
5726 DO i = 1, SIZE(this%dativar%r)
5727 this%dativar%r(i)%d = &
5728 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
5729 ENDDO
5730 ENDIF
5731
5732 IF (ASSOCIATED(this%dativarattr%i)) THEN
5733 DO i = 1, SIZE(this%dativar%r)
5734 this%dativar%r(i)%i = &
5735 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
5736 ENDDO
5737 ENDIF
5738
5739 IF (ASSOCIATED(this%dativarattr%b)) THEN
5740 DO i = 1, SIZE(this%dativar%r)
5741 this%dativar%r(i)%b = &
5742 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
5743 ENDDO
5744 ENDIF
5745
5746 IF (ASSOCIATED(this%dativarattr%c)) THEN
5747 DO i = 1, SIZE(this%dativar%r)
5748 this%dativar%r(i)%c = &
5749 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
5750 ENDDO
5751 ENDIF
5752ENDIF
5753! double
5754IF (ASSOCIATED(this%dativar%d)) THEN
5755 IF (ASSOCIATED(this%dativarattr%r)) THEN
5756 DO i = 1, SIZE(this%dativar%d)
5757 this%dativar%d(i)%r = &
5758 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
5759 ENDDO
5760 ENDIF
5761
5762 IF (ASSOCIATED(this%dativarattr%d)) THEN
5763 DO i = 1, SIZE(this%dativar%d)
5764 this%dativar%d(i)%d = &
5765 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
5766 ENDDO
5767 ENDIF
5768
5769 IF (ASSOCIATED(this%dativarattr%i)) THEN
5770 DO i = 1, SIZE(this%dativar%d)
5771 this%dativar%d(i)%i = &
5772 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
5773 ENDDO
5774 ENDIF
5775
5776 IF (ASSOCIATED(this%dativarattr%b)) THEN
5777 DO i = 1, SIZE(this%dativar%d)
5778 this%dativar%d(i)%b = &
5779 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
5780 ENDDO
5781 ENDIF
5782
5783 IF (ASSOCIATED(this%dativarattr%c)) THEN
5784 DO i = 1, SIZE(this%dativar%d)
5785 this%dativar%d(i)%c = &
5786 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
5787 ENDDO
5788 ENDIF
5789ENDIF
5790! integer
5791IF (ASSOCIATED(this%dativar%i)) THEN
5792 IF (ASSOCIATED(this%dativarattr%r)) THEN
5793 DO i = 1, SIZE(this%dativar%i)
5794 this%dativar%i(i)%r = &
5795 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5796 ENDDO
5797 ENDIF
5798
5799 IF (ASSOCIATED(this%dativarattr%d)) THEN
5800 DO i = 1, SIZE(this%dativar%i)
5801 this%dativar%i(i)%d = &
5802 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5803 ENDDO
5804 ENDIF
5805
5806 IF (ASSOCIATED(this%dativarattr%i)) THEN
5807 DO i = 1, SIZE(this%dativar%i)
5808 this%dativar%i(i)%i = &
5809 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5810 ENDDO
5811 ENDIF
5812
5813 IF (ASSOCIATED(this%dativarattr%b)) THEN
5814 DO i = 1, SIZE(this%dativar%i)
5815 this%dativar%i(i)%b = &
5816 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5817 ENDDO
5818 ENDIF
5819
5820 IF (ASSOCIATED(this%dativarattr%c)) THEN
5821 DO i = 1, SIZE(this%dativar%i)
5822 this%dativar%i(i)%c = &
5823 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5824 ENDDO
5825 ENDIF
5826ENDIF
5827! byte
5828IF (ASSOCIATED(this%dativar%b)) THEN
5829 IF (ASSOCIATED(this%dativarattr%r)) THEN
5830 DO i = 1, SIZE(this%dativar%b)
5831 this%dativar%b(i)%r = &
5832 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5833 ENDDO
5834 ENDIF
5835
5836 IF (ASSOCIATED(this%dativarattr%d)) THEN
5837 DO i = 1, SIZE(this%dativar%b)
5838 this%dativar%b(i)%d = &
5839 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5840 ENDDO
5841 ENDIF
5842
5843 IF (ASSOCIATED(this%dativarattr%i)) THEN
5844 DO i = 1, SIZE(this%dativar%b)
5845 this%dativar%b(i)%i = &
5846 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5847 ENDDO
5848 ENDIF
5849
5850 IF (ASSOCIATED(this%dativarattr%b)) THEN
5851 DO i = 1, SIZE(this%dativar%b)
5852 this%dativar%b(i)%b = &
5853 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5854 ENDDO
5855 ENDIF
5856
5857 IF (ASSOCIATED(this%dativarattr%c)) THEN
5858 DO i = 1, SIZE(this%dativar%b)
5859 this%dativar%b(i)%c = &
5860 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5861 ENDDO
5862 ENDIF
5863ENDIF
5864! character
5865IF (ASSOCIATED(this%dativar%c)) THEN
5866 IF (ASSOCIATED(this%dativarattr%r)) THEN
5867 DO i = 1, SIZE(this%dativar%c)
5868 this%dativar%c(i)%r = &
5869 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5870 ENDDO
5871 ENDIF
5872
5873 IF (ASSOCIATED(this%dativarattr%d)) THEN
5874 DO i = 1, SIZE(this%dativar%c)
5875 this%dativar%c(i)%d = &
5876 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5877 ENDDO
5878 ENDIF
5879
5880 IF (ASSOCIATED(this%dativarattr%i)) THEN
5881 DO i = 1, SIZE(this%dativar%c)
5882 this%dativar%c(i)%i = &
5883 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5884 ENDDO
5885 ENDIF
5886
5887 IF (ASSOCIATED(this%dativarattr%b)) THEN
5888 DO i = 1, SIZE(this%dativar%c)
5889 this%dativar%c(i)%b = &
5890 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5891 ENDDO
5892 ENDIF
5893
5894 IF (ASSOCIATED(this%dativarattr%c)) THEN
5895 DO i = 1, SIZE(this%dativar%c)
5896 this%dativar%c(i)%c = &
5897 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5898 ENDDO
5899 ENDIF
5900ENDIF
5901
5902END SUBROUTINE vol7d_set_attr_ind
5903
5904
5909SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5910 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5911TYPE(vol7d),INTENT(INOUT) :: this
5912TYPE(vol7d),INTENT(INOUT) :: that
5913LOGICAL,INTENT(IN),OPTIONAL :: sort
5914LOGICAL,INTENT(in),OPTIONAL :: bestdata
5915LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5916
5917TYPE(vol7d) :: v7d_clean
5918
5919
5920IF (.NOT.c_e(this)) THEN ! speedup
5921 this = that
5922 CALL init(v7d_clean)
5923 that = v7d_clean ! destroy that without deallocating
5924ELSE ! Append that to this and destroy that
5925 CALL vol7d_append(this, that, sort, bestdata, &
5926 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5927 CALL delete(that)
5928ENDIF
5929
5930END SUBROUTINE vol7d_merge
5931
5932
5961SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5962 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5963TYPE(vol7d),INTENT(INOUT) :: this
5964TYPE(vol7d),INTENT(IN) :: that
5965LOGICAL,INTENT(IN),OPTIONAL :: sort
5966! experimental, please do not use outside the library now, they force the use
5967! of a simplified mapping algorithm which is valid only whene the dimension
5968! content is the same in both volumes , or when one of them is empty
5969LOGICAL,INTENT(in),OPTIONAL :: bestdata
5970LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5971
5972
5973TYPE(vol7d) :: v7dtmp
5974LOGICAL :: lsort, lbestdata
5975INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5976 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5977
5978IF (.NOT.c_e(that)) RETURN ! speedup, nothing to do
5979IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5980IF (.NOT.c_e(this)) THEN ! this case is like a vol7d_copy, more efficient to copy?
5981 CALL vol7d_copy(that, this, sort=sort)
5982 RETURN
5983ENDIF
5984
5985IF (this%time_definition /= that%time_definition) THEN
5986 CALL l4f_log(l4f_fatal, &
5987 'in vol7d_append, cannot append volumes with different &
5988 &time definition')
5989 CALL raise_fatal_error()
5990ENDIF
5991
5992! Completo l'allocazione per avere volumi a norma
5993CALL vol7d_alloc_vol(this)
5994
5995CALL init(v7dtmp, time_definition=this%time_definition)
5996CALL optio(sort, lsort)
5997CALL optio(bestdata, lbestdata)
5998
5999! Calcolo le mappature tra volumi vecchi e volume nuovo
6000! I puntatori remap* vengono tutti o allocati o nullificati
6001IF (optio_log(ltimesimple)) THEN
6002 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
6003 lsort, remapt1, remapt2)
6004ELSE
6005 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
6006 lsort, remapt1, remapt2)
6007ENDIF
6008IF (optio_log(ltimerangesimple)) THEN
6009 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
6010 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6011ELSE
6012 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
6013 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6014ENDIF
6015IF (optio_log(llevelsimple)) THEN
6016 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
6017 lsort, remapl1, remapl2)
6018ELSE
6019 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
6020 lsort, remapl1, remapl2)
6021ENDIF
6022IF (optio_log(lanasimple)) THEN
6023 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6024 .false., remapa1, remapa2)
6025ELSE
6026 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6027 .false., remapa1, remapa2)
6028ENDIF
6029IF (optio_log(lnetworksimple)) THEN
6030 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
6031 .false., remapn1, remapn2)
6032ELSE
6033 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
6034 .false., remapn1, remapn2)
6035ENDIF
6036
6037! Faccio la fusione fisica dei volumi
6038CALL vol7d_merge_finalr(this, that, v7dtmp, &
6039 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6040 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6041CALL vol7d_merge_finald(this, that, v7dtmp, &
6042 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6043 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6044CALL vol7d_merge_finali(this, that, v7dtmp, &
6045 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6046 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6047CALL vol7d_merge_finalb(this, that, v7dtmp, &
6048 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6049 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6050CALL vol7d_merge_finalc(this, that, v7dtmp, &
6051 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6052 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6053
6054! Dealloco i vettori di rimappatura
6055IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
6056IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
6057IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
6058IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
6059IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
6060IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
6061IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
6062IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
6063IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
6064IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
6065
6066! Distruggo il vecchio volume e assegno il nuovo a this
6067CALL delete(this)
6068this = v7dtmp
6069! Ricreo gli indici var-attr
6070CALL vol7d_set_attr_ind(this)
6071
6072END SUBROUTINE vol7d_append
6073
6074
6107SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
6108 lsort_time, lsort_timerange, lsort_level, &
6109 ltime, ltimerange, llevel, lana, lnetwork, &
6110 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6111 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6112 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6113 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6114 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6115 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6116TYPE(vol7d),INTENT(IN) :: this
6117TYPE(vol7d),INTENT(INOUT) :: that
6118LOGICAL,INTENT(IN),OPTIONAL :: sort
6119LOGICAL,INTENT(IN),OPTIONAL :: unique
6120LOGICAL,INTENT(IN),OPTIONAL :: miss
6121LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6122LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6123LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6131LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6133LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6135LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6137LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6139LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6141LOGICAL,INTENT(in),OPTIONAL :: &
6142 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6143 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6144 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6145 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6146 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6147 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6148
6149LOGICAL :: lsort, lunique, lmiss
6150INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
6151
6152CALL init(that)
6153IF (.NOT.c_e(this)) RETURN ! speedup, nothing to do
6154IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
6155
6156CALL optio(sort, lsort)
6157CALL optio(unique, lunique)
6158CALL optio(miss, lmiss)
6159
6160! Calcolo le mappature tra volume vecchio e volume nuovo
6161! I puntatori remap* vengono tutti o allocati o nullificati
6162CALL vol7d_remap1_datetime(this%time, that%time, &
6163 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6164CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6165 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6166CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6167 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6168CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6169 lsort, lunique, lmiss, remapa, lana)
6170CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6171 lsort, lunique, lmiss, remapn, lnetwork)
6172
6173! lanavari, lanavarb, lanavarc, &
6174! lanaattri, lanaattrb, lanaattrc, &
6175! lanavarattri, lanavarattrb, lanavarattrc, &
6176! ldativari, ldativarb, ldativarc, &
6177! ldatiattri, ldatiattrb, ldatiattrc, &
6178! ldativarattri, ldativarattrb, ldativarattrc
6179! Faccio la riforma fisica dei volumi
6180CALL vol7d_reform_finalr(this, that, &
6181 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6182 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6183CALL vol7d_reform_finald(this, that, &
6184 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6185 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6186CALL vol7d_reform_finali(this, that, &
6187 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6188 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6189CALL vol7d_reform_finalb(this, that, &
6190 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6191 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6192CALL vol7d_reform_finalc(this, that, &
6193 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6194 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6195
6196! Dealloco i vettori di rimappatura
6197IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6198IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6199IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6200IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6201IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6202
6203! Ricreo gli indici var-attr
6204CALL vol7d_set_attr_ind(that)
6205that%time_definition = this%time_definition
6206
6207END SUBROUTINE vol7d_copy
6208
6209
6220SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6221 lsort_time, lsort_timerange, lsort_level, &
6222 ltime, ltimerange, llevel, lana, lnetwork, &
6223 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6224 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6225 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6226 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6227 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6228 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6229 ,purgeana)
6230TYPE(vol7d),INTENT(INOUT) :: this
6231LOGICAL,INTENT(IN),OPTIONAL :: sort
6232LOGICAL,INTENT(IN),OPTIONAL :: unique
6233LOGICAL,INTENT(IN),OPTIONAL :: miss
6234LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6235LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6236LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6244LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6245LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6246LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6247LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6248LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6250LOGICAL,INTENT(in),OPTIONAL :: &
6251 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6252 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6253 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6254 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6255 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6256 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6257LOGICAL,INTENT(IN),OPTIONAL :: purgeana
6258
6259TYPE(vol7d) :: v7dtmp
6260logical,allocatable :: llana(:)
6261integer :: i
6262
6263CALL vol7d_copy(this, v7dtmp, sort, unique, miss, &
6264 lsort_time, lsort_timerange, lsort_level, &
6265 ltime, ltimerange, llevel, lana, lnetwork, &
6266 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6267 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6268 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6269 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6270 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6271 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6272
6273! destroy old volume
6274CALL delete(this)
6275
6276if (optio_log(purgeana)) then
6277 allocate(llana(size(v7dtmp%ana)))
6278 llana =.false.
6279 do i =1,size(v7dtmp%ana)
6280 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6281 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6282 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6283 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6284 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6285 end do
6286 CALL vol7d_copy(v7dtmp, this,lana=llana)
6287 CALL delete(v7dtmp)
6288 deallocate(llana)
6289else
6290 this=v7dtmp
6291end if
6292
6293END SUBROUTINE vol7d_reform
6294
6295
6303SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6304TYPE(vol7d),INTENT(INOUT) :: this
6305LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
6306LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
6307LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
6308
6309INTEGER :: i
6310LOGICAL :: to_be_sorted
6311
6312to_be_sorted = .false.
6313CALL vol7d_alloc_vol(this) ! usual safety check
6314
6315IF (optio_log(lsort_time)) THEN
6316 DO i = 2, SIZE(this%time)
6317 IF (this%time(i) < this%time(i-1)) THEN
6318 to_be_sorted = .true.
6319 EXIT
6320 ENDIF
6321 ENDDO
6322ENDIF
6323IF (optio_log(lsort_timerange)) THEN
6324 DO i = 2, SIZE(this%timerange)
6325 IF (this%timerange(i) < this%timerange(i-1)) THEN
6326 to_be_sorted = .true.
6327 EXIT
6328 ENDIF
6329 ENDDO
6330ENDIF
6331IF (optio_log(lsort_level)) THEN
6332 DO i = 2, SIZE(this%level)
6333 IF (this%level(i) < this%level(i-1)) THEN
6334 to_be_sorted = .true.
6335 EXIT
6336 ENDIF
6337 ENDDO
6338ENDIF
6339
6340IF (to_be_sorted) CALL vol7d_reform(this, &
6341 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6342
6343END SUBROUTINE vol7d_smart_sort
6344
6352SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6353TYPE(vol7d),INTENT(inout) :: this
6354CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
6355CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
6356TYPE(vol7d_network),OPTIONAL :: nl(:)
6357TYPE(datetime),INTENT(in),OPTIONAL :: s_d
6358TYPE(datetime),INTENT(in),OPTIONAL :: e_d
6359
6360INTEGER :: i
6361
6362IF (PRESENT(avl)) THEN
6363 IF (SIZE(avl) > 0) THEN
6364
6365 IF (ASSOCIATED(this%anavar%r)) THEN
6366 DO i = 1, SIZE(this%anavar%r)
6367 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6368 ENDDO
6369 ENDIF
6370
6371 IF (ASSOCIATED(this%anavar%i)) THEN
6372 DO i = 1, SIZE(this%anavar%i)
6373 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6374 ENDDO
6375 ENDIF
6376
6377 IF (ASSOCIATED(this%anavar%b)) THEN
6378 DO i = 1, SIZE(this%anavar%b)
6379 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6380 ENDDO
6381 ENDIF
6382
6383 IF (ASSOCIATED(this%anavar%d)) THEN
6384 DO i = 1, SIZE(this%anavar%d)
6385 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
6386 ENDDO
6387 ENDIF
6388
6389 IF (ASSOCIATED(this%anavar%c)) THEN
6390 DO i = 1, SIZE(this%anavar%c)
6391 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
6392 ENDDO
6393 ENDIF
6394
6395 ENDIF
6396ENDIF
6397
6398
6399IF (PRESENT(vl)) THEN
6400 IF (size(vl) > 0) THEN
6401 IF (ASSOCIATED(this%dativar%r)) THEN
6402 DO i = 1, SIZE(this%dativar%r)
6403 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
6404 ENDDO
6405 ENDIF
6406
6407 IF (ASSOCIATED(this%dativar%i)) THEN
6408 DO i = 1, SIZE(this%dativar%i)
6409 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
6410 ENDDO
6411 ENDIF
6412
6413 IF (ASSOCIATED(this%dativar%b)) THEN
6414 DO i = 1, SIZE(this%dativar%b)
6415 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
6416 ENDDO
6417 ENDIF
6418
6419 IF (ASSOCIATED(this%dativar%d)) THEN
6420 DO i = 1, SIZE(this%dativar%d)
6421 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
6422 ENDDO
6423 ENDIF
6424
6425 IF (ASSOCIATED(this%dativar%c)) THEN
6426 DO i = 1, SIZE(this%dativar%c)
6427 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6428 ENDDO
6429 ENDIF
6430
6431 IF (ASSOCIATED(this%dativar%c)) THEN
6432 DO i = 1, SIZE(this%dativar%c)
6433 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6434 ENDDO
6435 ENDIF
6436
6437 ENDIF
6438ENDIF
6439
6440IF (PRESENT(nl)) THEN
6441 IF (SIZE(nl) > 0) THEN
6442 DO i = 1, SIZE(this%network)
6443 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
6444 ENDDO
6445 ENDIF
6446ENDIF
6447
6448IF (PRESENT(s_d)) THEN
6449 IF (c_e(s_d)) THEN
6450 WHERE (this%time < s_d)
6451 this%time = datetime_miss
6452 END WHERE
6453 ENDIF
6454ENDIF
6455
6456IF (PRESENT(e_d)) THEN
6457 IF (c_e(e_d)) THEN
6458 WHERE (this%time > e_d)
6459 this%time = datetime_miss
6460 END WHERE
6461 ENDIF
6462ENDIF
6463
6464CALL vol7d_reform(this, miss=.true.)
6465
6466END SUBROUTINE vol7d_filter
6467
6468
6475SUBROUTINE vol7d_convr(this, that, anaconv)
6476TYPE(vol7d),INTENT(IN) :: this
6477TYPE(vol7d),INTENT(INOUT) :: that
6478LOGICAL,OPTIONAL,INTENT(in) :: anaconv
6479INTEGER :: i
6480LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
6481TYPE(vol7d) :: v7d_tmp
6482
6483IF (optio_log(anaconv)) THEN
6484 acp=fv
6485 acn=tv
6486ELSE
6487 acp=tv
6488 acn=fv
6489ENDIF
6490
6491! Volume con solo i dati reali e tutti gli attributi
6492! l'anagrafica e` copiata interamente se necessario
6493CALL vol7d_copy(this, that, &
6494 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
6495 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
6496
6497! Volume solo di dati double
6498CALL vol7d_copy(this, v7d_tmp, &
6499 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
6500 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6501 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6502 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
6503 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6504 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6505
6506! converto a dati reali
6507IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
6508
6509 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
6510! alloco i dati reali e vi trasferisco i double
6511 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
6512 SIZE(v7d_tmp%volanad, 3)))
6513 DO i = 1, SIZE(v7d_tmp%anavar%d)
6514 v7d_tmp%volanar(:,i,:) = &
6515 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
6516 ENDDO
6517 DEALLOCATE(v7d_tmp%volanad)
6518! trasferisco le variabili
6519 v7d_tmp%anavar%r => v7d_tmp%anavar%d
6520 NULLIFY(v7d_tmp%anavar%d)
6521 ENDIF
6522
6523 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
6524! alloco i dati reali e vi trasferisco i double
6525 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
6526 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
6527 SIZE(v7d_tmp%voldatid, 6)))
6528 DO i = 1, SIZE(v7d_tmp%dativar%d)
6529 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6530 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
6531 ENDDO
6532 DEALLOCATE(v7d_tmp%voldatid)
6533! trasferisco le variabili
6534 v7d_tmp%dativar%r => v7d_tmp%dativar%d
6535 NULLIFY(v7d_tmp%dativar%d)
6536 ENDIF
6537
6538! fondo con il volume definitivo
6539 CALL vol7d_merge(that, v7d_tmp)
6540ELSE
6541 CALL delete(v7d_tmp)
6542ENDIF
6543
6544
6545! Volume solo di dati interi
6546CALL vol7d_copy(this, v7d_tmp, &
6547 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
6548 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6549 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6550 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
6551 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6552 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6553
6554! converto a dati reali
6555IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
6556
6557 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
6558! alloco i dati reali e vi trasferisco gli interi
6559 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
6560 SIZE(v7d_tmp%volanai, 3)))
6561 DO i = 1, SIZE(v7d_tmp%anavar%i)
6562 v7d_tmp%volanar(:,i,:) = &
6563 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
6564 ENDDO
6565 DEALLOCATE(v7d_tmp%volanai)
6566! trasferisco le variabili
6567 v7d_tmp%anavar%r => v7d_tmp%anavar%i
6568 NULLIFY(v7d_tmp%anavar%i)
6569 ENDIF
6570
6571 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
6572! alloco i dati reali e vi trasferisco gli interi
6573 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
6574 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
6575 SIZE(v7d_tmp%voldatii, 6)))
6576 DO i = 1, SIZE(v7d_tmp%dativar%i)
6577 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6578 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
6579 ENDDO
6580 DEALLOCATE(v7d_tmp%voldatii)
6581! trasferisco le variabili
6582 v7d_tmp%dativar%r => v7d_tmp%dativar%i
6583 NULLIFY(v7d_tmp%dativar%i)
6584 ENDIF
6585
6586! fondo con il volume definitivo
6587 CALL vol7d_merge(that, v7d_tmp)
6588ELSE
6589 CALL delete(v7d_tmp)
6590ENDIF
6591
6592
6593! Volume solo di dati byte
6594CALL vol7d_copy(this, v7d_tmp, &
6595 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
6596 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6597 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6598 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
6599 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6600 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6601
6602! converto a dati reali
6603IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
6604
6605 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
6606! alloco i dati reali e vi trasferisco i byte
6607 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
6608 SIZE(v7d_tmp%volanab, 3)))
6609 DO i = 1, SIZE(v7d_tmp%anavar%b)
6610 v7d_tmp%volanar(:,i,:) = &
6611 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
6612 ENDDO
6613 DEALLOCATE(v7d_tmp%volanab)
6614! trasferisco le variabili
6615 v7d_tmp%anavar%r => v7d_tmp%anavar%b
6616 NULLIFY(v7d_tmp%anavar%b)
6617 ENDIF
6618
6619 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
6620! alloco i dati reali e vi trasferisco i byte
6621 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
6622 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
6623 SIZE(v7d_tmp%voldatib, 6)))
6624 DO i = 1, SIZE(v7d_tmp%dativar%b)
6625 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6626 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
6627 ENDDO
6628 DEALLOCATE(v7d_tmp%voldatib)
6629! trasferisco le variabili
6630 v7d_tmp%dativar%r => v7d_tmp%dativar%b
6631 NULLIFY(v7d_tmp%dativar%b)
6632 ENDIF
6633
6634! fondo con il volume definitivo
6635 CALL vol7d_merge(that, v7d_tmp)
6636ELSE
6637 CALL delete(v7d_tmp)
6638ENDIF
6639
6640
6641! Volume solo di dati character
6642CALL vol7d_copy(this, v7d_tmp, &
6643 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
6644 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6645 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6646 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
6647 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6648 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6649
6650! converto a dati reali
6651IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
6652
6653 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
6654! alloco i dati reali e vi trasferisco i character
6655 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
6656 SIZE(v7d_tmp%volanac, 3)))
6657 DO i = 1, SIZE(v7d_tmp%anavar%c)
6658 v7d_tmp%volanar(:,i,:) = &
6659 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
6660 ENDDO
6661 DEALLOCATE(v7d_tmp%volanac)
6662! trasferisco le variabili
6663 v7d_tmp%anavar%r => v7d_tmp%anavar%c
6664 NULLIFY(v7d_tmp%anavar%c)
6665 ENDIF
6666
6667 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
6668! alloco i dati reali e vi trasferisco i character
6669 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
6670 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
6671 SIZE(v7d_tmp%voldatic, 6)))
6672 DO i = 1, SIZE(v7d_tmp%dativar%c)
6673 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6674 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
6675 ENDDO
6676 DEALLOCATE(v7d_tmp%voldatic)
6677! trasferisco le variabili
6678 v7d_tmp%dativar%r => v7d_tmp%dativar%c
6679 NULLIFY(v7d_tmp%dativar%c)
6680 ENDIF
6681
6682! fondo con il volume definitivo
6683 CALL vol7d_merge(that, v7d_tmp)
6684ELSE
6685 CALL delete(v7d_tmp)
6686ENDIF
6687
6688END SUBROUTINE vol7d_convr
6689
6690
6694SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
6695TYPE(vol7d),INTENT(IN) :: this
6696TYPE(vol7d),INTENT(OUT) :: that
6697logical , optional, intent(in) :: data_only
6698logical , optional, intent(in) :: ana
6699logical :: ldata_only,lana
6700
6701IF (PRESENT(data_only)) THEN
6702 ldata_only = data_only
6703ELSE
6704 ldata_only = .false.
6705ENDIF
6706
6707IF (PRESENT(ana)) THEN
6708 lana = ana
6709ELSE
6710 lana = .false.
6711ENDIF
6712
6713
6714#undef VOL7D_POLY_ARRAY
6715#define VOL7D_POLY_ARRAY voldati
6716#include "vol7d_class_diff.F90"
6717#undef VOL7D_POLY_ARRAY
6718#define VOL7D_POLY_ARRAY voldatiattr
6719#include "vol7d_class_diff.F90"
6720#undef VOL7D_POLY_ARRAY
6721
6722if ( .not. ldata_only) then
6723
6724#define VOL7D_POLY_ARRAY volana
6725#include "vol7d_class_diff.F90"
6726#undef VOL7D_POLY_ARRAY
6727#define VOL7D_POLY_ARRAY volanaattr
6728#include "vol7d_class_diff.F90"
6729#undef VOL7D_POLY_ARRAY
6730
6731 if(lana)then
6732 where ( this%ana == that%ana )
6733 that%ana = vol7d_ana_miss
6734 end where
6735 end if
6736
6737end if
6738
6739
6740
6741END SUBROUTINE vol7d_diff_only
6742
6743
6744
6745! Creo le routine da ripetere per i vari tipi di dati di v7d
6746! tramite un template e il preprocessore
6747#undef VOL7D_POLY_TYPE
6748#undef VOL7D_POLY_TYPES
6749#define VOL7D_POLY_TYPE REAL
6750#define VOL7D_POLY_TYPES r
6751#include "vol7d_class_type_templ.F90"
6752#undef VOL7D_POLY_TYPE
6753#undef VOL7D_POLY_TYPES
6754#define VOL7D_POLY_TYPE DOUBLE PRECISION
6755#define VOL7D_POLY_TYPES d
6756#include "vol7d_class_type_templ.F90"
6757#undef VOL7D_POLY_TYPE
6758#undef VOL7D_POLY_TYPES
6759#define VOL7D_POLY_TYPE INTEGER
6760#define VOL7D_POLY_TYPES i
6761#include "vol7d_class_type_templ.F90"
6762#undef VOL7D_POLY_TYPE
6763#undef VOL7D_POLY_TYPES
6764#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
6765#define VOL7D_POLY_TYPES b
6766#include "vol7d_class_type_templ.F90"
6767#undef VOL7D_POLY_TYPE
6768#undef VOL7D_POLY_TYPES
6769#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
6770#define VOL7D_POLY_TYPES c
6771#include "vol7d_class_type_templ.F90"
6772
6773! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
6774! tramite un template e il preprocessore
6775#define VOL7D_SORT
6776#undef VOL7D_NO_ZERO_ALLOC
6777#undef VOL7D_POLY_TYPE
6778#define VOL7D_POLY_TYPE datetime
6779#include "vol7d_class_desc_templ.F90"
6780#undef VOL7D_POLY_TYPE
6781#define VOL7D_POLY_TYPE vol7d_timerange
6782#include "vol7d_class_desc_templ.F90"
6783#undef VOL7D_POLY_TYPE
6784#define VOL7D_POLY_TYPE vol7d_level
6785#include "vol7d_class_desc_templ.F90"
6786#undef VOL7D_SORT
6787#undef VOL7D_POLY_TYPE
6788#define VOL7D_POLY_TYPE vol7d_network
6789#include "vol7d_class_desc_templ.F90"
6790#undef VOL7D_POLY_TYPE
6791#define VOL7D_POLY_TYPE vol7d_ana
6792#include "vol7d_class_desc_templ.F90"
6793#define VOL7D_NO_ZERO_ALLOC
6794#undef VOL7D_POLY_TYPE
6795#define VOL7D_POLY_TYPE vol7d_var
6796#include "vol7d_class_desc_templ.F90"
6797
6807subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6808
6809TYPE(vol7d),INTENT(IN) :: this
6810integer,optional,intent(inout) :: unit
6811character(len=*),intent(in),optional :: filename
6812character(len=*),intent(out),optional :: filename_auto
6813character(len=*),INTENT(IN),optional :: description
6814
6815integer :: lunit
6816character(len=254) :: ldescription,arg,lfilename
6817integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6818 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6819 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6820 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6821 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6822 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6823 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6824!integer :: im,id,iy
6825integer :: tarray(8)
6826logical :: opened,exist
6827
6828 nana=0
6829 ntime=0
6830 ntimerange=0
6831 nlevel=0
6832 nnetwork=0
6833 ndativarr=0
6834 ndativari=0
6835 ndativarb=0
6836 ndativard=0
6837 ndativarc=0
6838 ndatiattrr=0
6839 ndatiattri=0
6840 ndatiattrb=0
6841 ndatiattrd=0
6842 ndatiattrc=0
6843 ndativarattrr=0
6844 ndativarattri=0
6845 ndativarattrb=0
6846 ndativarattrd=0
6847 ndativarattrc=0
6848 nanavarr=0
6849 nanavari=0
6850 nanavarb=0
6851 nanavard=0
6852 nanavarc=0
6853 nanaattrr=0
6854 nanaattri=0
6855 nanaattrb=0
6856 nanaattrd=0
6857 nanaattrc=0
6858 nanavarattrr=0
6859 nanavarattri=0
6860 nanavarattrb=0
6861 nanavarattrd=0
6862 nanavarattrc=0
6863
6864
6865!call idate(im,id,iy)
6866call date_and_time(values=tarray)
6867call getarg(0,arg)
6868
6869if (present(description))then
6870 ldescription=description
6871else
6872 ldescription="Vol7d generated by: "//trim(arg)
6873end if
6874
6875if (.not. present(unit))then
6876 lunit=getunit()
6877else
6878 if (unit==0)then
6879 lunit=getunit()
6880 unit=lunit
6881 else
6882 lunit=unit
6883 end if
6884end if
6885
6886lfilename=trim(arg)//".v7d"
6887if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
6888
6889if (present(filename))then
6890 if (filename /= "")then
6891 lfilename=filename
6892 end if
6893end if
6894
6895if (present(filename_auto))filename_auto=lfilename
6896
6897
6898inquire(unit=lunit,opened=opened)
6899if (.not. opened) then
6900! inquire(file=lfilename, EXIST=exist)
6901! IF (exist) THEN
6902! CALL l4f_log(L4F_FATAL, &
6903! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6904! CALL raise_fatal_error()
6905! ENDIF
6906 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6907 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6908end if
6909
6910if (associated(this%ana)) nana=size(this%ana)
6911if (associated(this%time)) ntime=size(this%time)
6912if (associated(this%timerange)) ntimerange=size(this%timerange)
6913if (associated(this%level)) nlevel=size(this%level)
6914if (associated(this%network)) nnetwork=size(this%network)
6915
6916if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6917if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6918if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6919if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6920if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6921
6922if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6923if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6924if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6925if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6926if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6927
6928if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6929if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6930if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6931if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6932if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6933
6934if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6935if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6936if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6937if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6938if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6939
6940if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6941if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6942if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6943if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6944if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6945
6946if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6947if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6948if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6949if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6950if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6951
6952write(unit=lunit)ldescription
6953write(unit=lunit)tarray
6954
6955write(unit=lunit)&
6956 nana, ntime, ntimerange, nlevel, nnetwork, &
6957 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6958 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6959 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6960 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6961 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6962 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6963 this%time_definition
6964
6965
6966!write(unit=lunit)this
6967
6968
6969!! prime 5 dimensioni
6970if (associated(this%ana)) call write_unit(this%ana, lunit)
6971if (associated(this%time)) call write_unit(this%time, lunit)
6972if (associated(this%level)) write(unit=lunit)this%level
6973if (associated(this%timerange)) write(unit=lunit)this%timerange
6974if (associated(this%network)) write(unit=lunit)this%network
6975
6976 !! 6a dimensione: variabile dell'anagrafica e dei dati
6977 !! con relativi attributi e in 5 tipi diversi
6978
6979if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6980if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6981if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6982if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6983if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6984
6985if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6986if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6987if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6988if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6989if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6990
6991if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6992if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6993if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6994if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6995if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6996
6997if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6998if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6999if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
7000if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
7001if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
7002
7003if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
7004if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
7005if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
7006if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
7007if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
7008
7009if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
7010if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
7011if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
7012if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
7013if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
7014
7015!! Volumi di valori e attributi per anagrafica e dati
7016
7017if (associated(this%volanar)) write(unit=lunit)this%volanar
7018if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
7019if (associated(this%voldatir)) write(unit=lunit)this%voldatir
7020if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
7021
7022if (associated(this%volanai)) write(unit=lunit)this%volanai
7023if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
7024if (associated(this%voldatii)) write(unit=lunit)this%voldatii
7025if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
7026
7027if (associated(this%volanab)) write(unit=lunit)this%volanab
7028if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
7029if (associated(this%voldatib)) write(unit=lunit)this%voldatib
7030if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
7031
7032if (associated(this%volanad)) write(unit=lunit)this%volanad
7033if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
7034if (associated(this%voldatid)) write(unit=lunit)this%voldatid
7035if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
7036
7037if (associated(this%volanac)) write(unit=lunit)this%volanac
7038if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
7039if (associated(this%voldatic)) write(unit=lunit)this%voldatic
7040if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
7041
7042if (.not. present(unit)) close(unit=lunit)
7043
7044end subroutine vol7d_write_on_file
7045
7046
7053
7054
7055subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
7056
7057TYPE(vol7d),INTENT(OUT) :: this
7058integer,intent(inout),optional :: unit
7059character(len=*),INTENT(in),optional :: filename
7060character(len=*),intent(out),optional :: filename_auto
7061character(len=*),INTENT(out),optional :: description
7062integer,intent(out),optional :: tarray(8)
7063
7064
7065integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7066 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7067 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7068 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7069 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7070 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7071 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7072
7073character(len=254) :: ldescription,lfilename,arg
7074integer :: ltarray(8),lunit,ios
7075logical :: opened,exist
7076
7077
7078call getarg(0,arg)
7079
7080if (.not. present(unit))then
7081 lunit=getunit()
7082else
7083 if (unit==0)then
7084 lunit=getunit()
7085 unit=lunit
7086 else
7087 lunit=unit
7088 end if
7089end if
7090
7091lfilename=trim(arg)//".v7d"
7092if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
7093
7094if (present(filename))then
7095 if (filename /= "")then
7096 lfilename=filename
7097 end if
7098end if
7099
7100if (present(filename_auto))filename_auto=lfilename
7101
7102
7103inquire(unit=lunit,opened=opened)
7104IF (.NOT. opened) THEN
7105 inquire(file=lfilename,exist=exist)
7106 IF (.NOT.exist) THEN
7107 CALL l4f_log(l4f_fatal, &
7108 'in vol7d_read_from_file, file does not exists, cannot open')
7109 CALL raise_fatal_error()
7110 ENDIF
7111 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
7112 status='OLD', action='READ')
7113 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7114end if
7115
7116
7117call init(this)
7118read(unit=lunit,iostat=ios)ldescription
7119
7120if (ios < 0) then ! A negative value indicates that the End of File or End of Record
7121 call vol7d_alloc (this)
7122 call vol7d_alloc_vol (this)
7123 if (present(description))description=ldescription
7124 if (present(tarray))tarray=ltarray
7125 if (.not. present(unit)) close(unit=lunit)
7126end if
7127
7128read(unit=lunit)ltarray
7129
7130CALL l4f_log(l4f_info, 'Reading vol7d from file')
7131CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
7132CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
7133 trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
7134
7135if (present(description))description=ldescription
7136if (present(tarray))tarray=ltarray
7137
7138read(unit=lunit)&
7139 nana, ntime, ntimerange, nlevel, nnetwork, &
7140 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7141 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7142 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7143 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7144 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7145 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7146 this%time_definition
7147
7148call vol7d_alloc (this, &
7149 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
7150 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
7151 ndativard=ndativard, ndativarc=ndativarc,&
7152 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
7153 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
7154 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
7155 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
7156 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
7157 nanavard=nanavard, nanavarc=nanavarc,&
7158 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
7159 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
7160 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7161 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7162
7163
7164if (associated(this%ana)) call read_unit(this%ana, lunit)
7165if (associated(this%time)) call read_unit(this%time, lunit)
7166if (associated(this%level)) read(unit=lunit)this%level
7167if (associated(this%timerange)) read(unit=lunit)this%timerange
7168if (associated(this%network)) read(unit=lunit)this%network
7169
7170if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7171if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7172if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7173if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7174if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7175
7176if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7177if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7178if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7179if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7180if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7181
7182if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7183if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7184if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7185if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7186if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7187
7188if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7189if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7190if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7191if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7192if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7193
7194if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7195if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7196if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7197if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7198if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7199
7200if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7201if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7202if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7203if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7204if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7205
7206call vol7d_alloc_vol (this)
7207
7208!! Volumi di valori e attributi per anagrafica e dati
7209
7210if (associated(this%volanar)) read(unit=lunit)this%volanar
7211if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7212if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7213if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7214
7215if (associated(this%volanai)) read(unit=lunit)this%volanai
7216if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7217if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7218if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7219
7220if (associated(this%volanab)) read(unit=lunit)this%volanab
7221if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7222if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7223if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7224
7225if (associated(this%volanad)) read(unit=lunit)this%volanad
7226if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7227if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7228if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7229
7230if (associated(this%volanac)) read(unit=lunit)this%volanac
7231if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7232if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7233if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7234
7235if (.not. present(unit)) close(unit=lunit)
7236
7237end subroutine vol7d_read_from_file
7238
7239
7240! to double precision
7241elemental doubleprecision function doubledatd(voldat,var)
7242doubleprecision,intent(in) :: voldat
7243type(vol7d_var),intent(in) :: var
7244
7245doubledatd=voldat
7246
7247end function doubledatd
7248
7249
7250elemental doubleprecision function doubledatr(voldat,var)
7251real,intent(in) :: voldat
7252type(vol7d_var),intent(in) :: var
7253
7254if (c_e(voldat))then
7255 doubledatr=dble(voldat)
7256else
7257 doubledatr=dmiss
7258end if
7259
7260end function doubledatr
7261
7262
7263elemental doubleprecision function doubledati(voldat,var)
7264integer,intent(in) :: voldat
7265type(vol7d_var),intent(in) :: var
7266
7267if (c_e(voldat)) then
7268 if (c_e(var%scalefactor))then
7269 doubledati=dble(voldat)/10.d0**var%scalefactor
7270 else
7271 doubledati=dble(voldat)
7272 endif
7273else
7274 doubledati=dmiss
7275end if
7276
7277end function doubledati
7278
7279
7280elemental doubleprecision function doubledatb(voldat,var)
7281integer(kind=int_b),intent(in) :: voldat
7282type(vol7d_var),intent(in) :: var
7283
7284if (c_e(voldat)) then
7285 if (c_e(var%scalefactor))then
7286 doubledatb=dble(voldat)/10.d0**var%scalefactor
7287 else
7288 doubledatb=dble(voldat)
7289 endif
7290else
7291 doubledatb=dmiss
7292end if
7293
7294end function doubledatb
7295
7296
7297elemental doubleprecision function doubledatc(voldat,var)
7298CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7299type(vol7d_var),intent(in) :: var
7300
7301doubledatc = c2d(voldat)
7302if (c_e(doubledatc) .and. c_e(var%scalefactor))then
7303 doubledatc=doubledatc/10.d0**var%scalefactor
7304end if
7305
7306end function doubledatc
7307
7308
7309! to integer
7310elemental integer function integerdatd(voldat,var)
7311doubleprecision,intent(in) :: voldat
7312type(vol7d_var),intent(in) :: var
7313
7314if (c_e(voldat))then
7315 if (c_e(var%scalefactor)) then
7316 integerdatd=nint(voldat*10d0**var%scalefactor)
7317 else
7318 integerdatd=nint(voldat)
7319 endif
7320else
7321 integerdatd=imiss
7322end if
7323
7324end function integerdatd
7325
7326
7327elemental integer function integerdatr(voldat,var)
7328real,intent(in) :: voldat
7329type(vol7d_var),intent(in) :: var
7330
7331if (c_e(voldat))then
7332 if (c_e(var%scalefactor)) then
7333 integerdatr=nint(voldat*10d0**var%scalefactor)
7334 else
7335 integerdatr=nint(voldat)
7336 endif
7337else
7338 integerdatr=imiss
7339end if
7340
7341end function integerdatr
7342
7343
7344elemental integer function integerdati(voldat,var)
7345integer,intent(in) :: voldat
7346type(vol7d_var),intent(in) :: var
7347
7348integerdati=voldat
7349
7350end function integerdati
7351
7352
7353elemental integer function integerdatb(voldat,var)
7354integer(kind=int_b),intent(in) :: voldat
7355type(vol7d_var),intent(in) :: var
7356
7357if (c_e(voldat))then
7358 integerdatb=voldat
7359else
7360 integerdatb=imiss
7361end if
7362
7363end function integerdatb
7364
7365
7366elemental integer function integerdatc(voldat,var)
7367CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7368type(vol7d_var),intent(in) :: var
7369
7370integerdatc=c2i(voldat)
7371
7372end function integerdatc
7373
7374
7375! to real
7376elemental real function realdatd(voldat,var)
7377doubleprecision,intent(in) :: voldat
7378type(vol7d_var),intent(in) :: var
7379
7380if (c_e(voldat))then
7381 realdatd=real(voldat)
7382else
7383 realdatd=rmiss
7384end if
7385
7386end function realdatd
7387
7388
7389elemental real function realdatr(voldat,var)
7390real,intent(in) :: voldat
7391type(vol7d_var),intent(in) :: var
7392
7393realdatr=voldat
7394
7395end function realdatr
7396
7397
7398elemental real function realdati(voldat,var)
7399integer,intent(in) :: voldat
7400type(vol7d_var),intent(in) :: var
7401
7402if (c_e(voldat)) then
7403 if (c_e(var%scalefactor))then
7404 realdati=float(voldat)/10.**var%scalefactor
7405 else
7406 realdati=float(voldat)
7407 endif
7408else
7409 realdati=rmiss
7410end if
7411
7412end function realdati
7413
7414
7415elemental real function realdatb(voldat,var)
7416integer(kind=int_b),intent(in) :: voldat
7417type(vol7d_var),intent(in) :: var
7418
7419if (c_e(voldat)) then
7420 if (c_e(var%scalefactor))then
7421 realdatb=float(voldat)/10**var%scalefactor
7422 else
7423 realdatb=float(voldat)
7424 endif
7425else
7426 realdatb=rmiss
7427end if
7428
7429end function realdatb
7430
7431
7432elemental real function realdatc(voldat,var)
7433CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7434type(vol7d_var),intent(in) :: var
7435
7436realdatc=c2r(voldat)
7437if (c_e(realdatc) .and. c_e(var%scalefactor))then
7438 realdatc=realdatc/10.**var%scalefactor
7439end if
7440
7441end function realdatc
7442
7443
7449FUNCTION realanavol(this, var) RESULT(vol)
7450TYPE(vol7d),INTENT(in) :: this
7451TYPE(vol7d_var),INTENT(in) :: var
7452REAL :: vol(SIZE(this%ana),size(this%network))
7453
7454CHARACTER(len=1) :: dtype
7455INTEGER :: indvar
7456
7457dtype = cmiss
7458indvar = index(this%anavar, var, type=dtype)
7459
7460IF (indvar > 0) THEN
7461 SELECT CASE (dtype)
7462 CASE("d")
7463 vol = realdat(this%volanad(:,indvar,:), var)
7464 CASE("r")
7465 vol = this%volanar(:,indvar,:)
7466 CASE("i")
7467 vol = realdat(this%volanai(:,indvar,:), var)
7468 CASE("b")
7469 vol = realdat(this%volanab(:,indvar,:), var)
7470 CASE("c")
7471 vol = realdat(this%volanac(:,indvar,:), var)
7472 CASE default
7473 vol = rmiss
7474 END SELECT
7475ELSE
7476 vol = rmiss
7477ENDIF
7478
7479END FUNCTION realanavol
7480
7481
7487FUNCTION integeranavol(this, var) RESULT(vol)
7488TYPE(vol7d),INTENT(in) :: this
7489TYPE(vol7d_var),INTENT(in) :: var
7490INTEGER :: vol(SIZE(this%ana),size(this%network))
7491
7492CHARACTER(len=1) :: dtype
7493INTEGER :: indvar
7494
7495dtype = cmiss
7496indvar = index(this%anavar, var, type=dtype)
7497
7498IF (indvar > 0) THEN
7499 SELECT CASE (dtype)
7500 CASE("d")
7501 vol = integerdat(this%volanad(:,indvar,:), var)
7502 CASE("r")
7503 vol = integerdat(this%volanar(:,indvar,:), var)
7504 CASE("i")
7505 vol = this%volanai(:,indvar,:)
7506 CASE("b")
7507 vol = integerdat(this%volanab(:,indvar,:), var)
7508 CASE("c")
7509 vol = integerdat(this%volanac(:,indvar,:), var)
7510 CASE default
7511 vol = imiss
7512 END SELECT
7513ELSE
7514 vol = imiss
7515ENDIF
7516
7517END FUNCTION integeranavol
7518
7519
7525subroutine move_datac (v7d,&
7526 indana,indtime,indlevel,indtimerange,indnetwork,&
7527 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7528
7529TYPE(vol7d),intent(inout) :: v7d
7530
7531integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
7532integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
7533integer :: inddativar,inddativarattr
7534
7535
7536do inddativar=1,size(v7d%dativar%c)
7537
7538 if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
7539 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7540 ) then
7541
7542 ! dati
7543 v7d%voldatic &
7544 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7545 v7d%voldatic &
7546 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7547
7548
7549 ! attributi
7550 if (associated (v7d%dativarattr%i)) then
7551 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
7552 if (inddativarattr > 0 ) then
7553 v7d%voldatiattri &
7554 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7555 v7d%voldatiattri &
7556 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7557 end if
7558 end if
7559
7560 if (associated (v7d%dativarattr%r)) then
7561 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
7562 if (inddativarattr > 0 ) then
7563 v7d%voldatiattrr &
7564 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7565 v7d%voldatiattrr &
7566 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7567 end if
7568 end if
7569
7570 if (associated (v7d%dativarattr%d)) then
7571 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
7572 if (inddativarattr > 0 ) then
7573 v7d%voldatiattrd &
7574 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7575 v7d%voldatiattrd &
7576 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7577 end if
7578 end if
7579
7580 if (associated (v7d%dativarattr%b)) then
7581 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
7582 if (inddativarattr > 0 ) then
7583 v7d%voldatiattrb &
7584 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7585 v7d%voldatiattrb &
7586 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7587 end if
7588 end if
7589
7590 if (associated (v7d%dativarattr%c)) then
7591 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
7592 if (inddativarattr > 0 ) then
7593 v7d%voldatiattrc &
7594 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7595 v7d%voldatiattrc &
7596 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7597 end if
7598 end if
7599
7600 end if
7601
7602end do
7603
7604end subroutine move_datac
7605
7611subroutine move_datar (v7d,&
7612 indana,indtime,indlevel,indtimerange,indnetwork,&
7613 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7614
7615TYPE(vol7d),intent(inout) :: v7d
7616
7617integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
7618integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
7619integer :: inddativar,inddativarattr
7620
7621
7622do inddativar=1,size(v7d%dativar%r)
7623
7624 if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
7625 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7626 ) then
7627
7628 ! dati
7629 v7d%voldatir &
7630 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7631 v7d%voldatir &
7632 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7633
7634
7635 ! attributi
7636 if (associated (v7d%dativarattr%i)) then
7637 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
7638 if (inddativarattr > 0 ) then
7639 v7d%voldatiattri &
7640 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7641 v7d%voldatiattri &
7642 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7643 end if
7644 end if
7645
7646 if (associated (v7d%dativarattr%r)) then
7647 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
7648 if (inddativarattr > 0 ) then
7649 v7d%voldatiattrr &
7650 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7651 v7d%voldatiattrr &
7652 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7653 end if
7654 end if
7655
7656 if (associated (v7d%dativarattr%d)) then
7657 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
7658 if (inddativarattr > 0 ) then
7659 v7d%voldatiattrd &
7660 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7661 v7d%voldatiattrd &
7662 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7663 end if
7664 end if
7665
7666 if (associated (v7d%dativarattr%b)) then
7667 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
7668 if (inddativarattr > 0 ) then
7669 v7d%voldatiattrb &
7670 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7671 v7d%voldatiattrb &
7672 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7673 end if
7674 end if
7675
7676 if (associated (v7d%dativarattr%c)) then
7677 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
7678 if (inddativarattr > 0 ) then
7679 v7d%voldatiattrc &
7680 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7681 v7d%voldatiattrc &
7682 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7683 end if
7684 end if
7685
7686 end if
7687
7688end do
7689
7690end subroutine move_datar
7691
7692
7706subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
7707type(vol7d),intent(inout) :: v7din
7708type(vol7d),intent(out) :: v7dout
7709type(vol7d_level),intent(in),optional :: level(:)
7710type(vol7d_timerange),intent(in),optional :: timerange(:)
7711!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
7712!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
7713logical,intent(in),optional :: nostatproc
7714
7715integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
7716integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
7717type(vol7d_level) :: roundlevel(size(v7din%level))
7718type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
7719type(vol7d) :: v7d_tmp
7720
7721
7722nbin=0
7723
7724if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
7725if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
7726if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
7727if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
7728
7729call init(v7d_tmp)
7730
7731roundlevel=v7din%level
7732
7733if (present(level))then
7734 do ilevel = 1, size(v7din%level)
7735 if ((any(v7din%level(ilevel) .almosteq. level))) then
7736 roundlevel(ilevel)=level(1)
7737 end if
7738 end do
7739end if
7740
7741roundtimerange=v7din%timerange
7742
7743if (present(timerange))then
7744 do itimerange = 1, size(v7din%timerange)
7745 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
7746 roundtimerange(itimerange)=timerange(1)
7747 end if
7748 end do
7749end if
7750
7751!set istantaneous values everywere
7752!preserve p1 for forecast time
7753if (optio_log(nostatproc)) then
7754 roundtimerange(:)%timerange=254
7755 roundtimerange(:)%p2=0
7756end if
7757
7758
7759nana=size(v7din%ana)
7760nlevel=count_distinct(roundlevel,back=.true.)
7761ntime=size(v7din%time)
7762ntimerange=count_distinct(roundtimerange,back=.true.)
7763nnetwork=size(v7din%network)
7764
7765call init(v7d_tmp)
7766
7767if (nbin == 0) then
7768 call copy(v7din,v7d_tmp)
7769else
7770 call vol7d_convr(v7din,v7d_tmp)
7771end if
7772
7773v7d_tmp%level=roundlevel
7774v7d_tmp%timerange=roundtimerange
7775
7776do ilevel=1, size(v7d_tmp%level)
7777 indl=index(v7d_tmp%level,roundlevel(ilevel))
7778 do itimerange=1,size(v7d_tmp%timerange)
7779 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
7780
7781 if (indl /= ilevel .or. indt /= itimerange) then
7782
7783 do iana=1, nana
7784 do itime=1,ntime
7785 do inetwork=1,nnetwork
7786
7787 if (nbin > 0) then
7788 call move_datar (v7d_tmp,&
7789 iana,itime,ilevel,itimerange,inetwork,&
7790 iana,itime,indl,indt,inetwork)
7791 else
7792 call move_datac (v7d_tmp,&
7793 iana,itime,ilevel,itimerange,inetwork,&
7794 iana,itime,indl,indt,inetwork)
7795 end if
7796
7797 end do
7798 end do
7799 end do
7800
7801 end if
7802
7803 end do
7804end do
7805
7806! set to missing level and time > nlevel
7807do ilevel=nlevel+1,size(v7d_tmp%level)
7808 call init (v7d_tmp%level(ilevel))
7809end do
7810
7811do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7812 call init (v7d_tmp%timerange(itimerange))
7813end do
7814
7815!copy with remove
7816CALL copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
7817CALL delete(v7d_tmp)
7818
7819!call display(v7dout)
7820
7821end subroutine v7d_rounding
7822
7823
7824END MODULE vol7d_class
7825
7831
7832
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.