libsim Versione 7.2.1

◆ vol7d_get_voldatid()

subroutine vol7d_get_voldatid ( 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 )

Crea una vista a dimensione ridotta di un volume 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_voldatid(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

Definizione alla linea 4321 del file vol7d_class.F90.

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