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