libsim Versione 7.1.11

◆ vol7d_get_volanaattrd()

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

Crea una vista a dimensione ridotta di un volume di attributi di anagrafica 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 :: vol1d(:)
...
CALL vol7d_get_volanaattrd(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d

Definizione alla linea 4274 del file vol7d_class.F90.

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

Generated with Doxygen.