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