libsim Versione 7.1.11
|
◆ vol7d_get_volanad()
Crea una vista a dimensione ridotta di un volume di anagrafica di tipo DOUBLE PRECISION. È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio: DOUBLE PRECISION, POINTER :: vol1d(:)
...
CALL vol7d_get_volanad(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 4222 del file vol7d_class.F90. 4224! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
4225! authors:
4226! Davide Cesari <dcesari@arpa.emr.it>
4227! Paolo Patruno <ppatruno@arpa.emr.it>
4228
4229! This program is free software; you can redistribute it and/or
4230! modify it under the terms of the GNU General Public License as
4231! published by the Free Software Foundation; either version 2 of
4232! the License, or (at your option) any later version.
4233
4234! This program is distributed in the hope that it will be useful,
4235! but WITHOUT ANY WARRANTY; without even the implied warranty of
4236! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4237! GNU General Public License for more details.
4238
4239! You should have received a copy of the GNU General Public License
4240! along with this program. If not, see <http://www.gnu.org/licenses/>.
4241#include "config.h"
4242
4254
4322IMPLICIT NONE
4323
4324
4325INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
4326 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
4327
4328INTEGER, PARAMETER :: vol7d_ana_a=1
4329INTEGER, PARAMETER :: vol7d_var_a=2
4330INTEGER, PARAMETER :: vol7d_network_a=3
4331INTEGER, PARAMETER :: vol7d_attr_a=4
4332INTEGER, PARAMETER :: vol7d_ana_d=1
4333INTEGER, PARAMETER :: vol7d_time_d=2
4334INTEGER, PARAMETER :: vol7d_level_d=3
4335INTEGER, PARAMETER :: vol7d_timerange_d=4
4336INTEGER, PARAMETER :: vol7d_var_d=5
4337INTEGER, PARAMETER :: vol7d_network_d=6
4338INTEGER, PARAMETER :: vol7d_attr_d=7
4339INTEGER, PARAMETER :: vol7d_cdatalen=32
4340
4341TYPE vol7d_varmap
4342 INTEGER :: r, d, i, b, c
4343END TYPE vol7d_varmap
4344
4349 TYPE(vol7d_ana),POINTER :: ana(:)
4351 TYPE(datetime),POINTER :: time(:)
4353 TYPE(vol7d_level),POINTER :: level(:)
4355 TYPE(vol7d_timerange),POINTER :: timerange(:)
4357 TYPE(vol7d_network),POINTER :: network(:)
4359 TYPE(vol7d_varvect) :: anavar
4361 TYPE(vol7d_varvect) :: anaattr
4363 TYPE(vol7d_varvect) :: anavarattr
4365 TYPE(vol7d_varvect) :: dativar
4367 TYPE(vol7d_varvect) :: datiattr
4369 TYPE(vol7d_varvect) :: dativarattr
4370
4372 REAL,POINTER :: volanar(:,:,:)
4374 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
4376 INTEGER,POINTER :: volanai(:,:,:)
4378 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
4380 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
4381
4383 REAL,POINTER :: volanaattrr(:,:,:,:)
4385 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
4387 INTEGER,POINTER :: volanaattri(:,:,:,:)
4389 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
4391 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
4392
4394 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
4396 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
4398 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
4400 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
4402 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
4403
4405 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
4407 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
4409 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
4411 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
4413 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
4414
4416 integer :: time_definition
4417
4419
4424 MODULE PROCEDURE vol7d_init
4425END INTERFACE
4426
4429 MODULE PROCEDURE vol7d_delete
4430END INTERFACE
4431
4434 MODULE PROCEDURE vol7d_write_on_file
4435END INTERFACE
4436
4438INTERFACE import
4439 MODULE PROCEDURE vol7d_read_from_file
4440END INTERFACE
4441
4444 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
4445END INTERFACE
4446
4449 MODULE PROCEDURE to_char_dat
4450END INTERFACE
4451
4454 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4455END INTERFACE
4456
4459 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
4460END INTERFACE
4461
4464 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
4465END INTERFACE
4466
4469 MODULE PROCEDURE vol7d_copy
4470END INTERFACE
4471
4474 MODULE PROCEDURE vol7d_c_e
4475END INTERFACE
4476
4481 MODULE PROCEDURE vol7d_check
4482END INTERFACE
4483
4498 MODULE PROCEDURE v7d_rounding
4499END INTERFACE
4500
4501!!$INTERFACE get_volana
4502!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
4503!!$ vol7d_get_volanab, vol7d_get_volanac
4504!!$END INTERFACE
4505!!$
4506!!$INTERFACE get_voldati
4507!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
4508!!$ vol7d_get_voldatib, vol7d_get_voldatic
4509!!$END INTERFACE
4510!!$
4511!!$INTERFACE get_volanaattr
4512!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
4513!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
4514!!$END INTERFACE
4515!!$
4516!!$INTERFACE get_voldatiattr
4517!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
4518!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
4519!!$END INTERFACE
4520
4521PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
4522 vol7d_get_volc, &
4523 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
4524 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
4525 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
4526 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
4527 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
4528 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
4529 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
4530 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
4531 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
4532 vol7d_display, dat_display, dat_vect_display, &
4533 to_char_dat, vol7d_check
4534
4535PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4536
4537PRIVATE vol7d_c_e
4538
4539CONTAINS
4540
4541
4546SUBROUTINE vol7d_init(this,time_definition)
4547TYPE(vol7d),intent(out) :: this
4548integer,INTENT(IN),OPTIONAL :: time_definition
4549
4556CALL vol7d_var_features_init() ! initialise var features table once
4557
4558NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
4559
4560NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
4561NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
4562NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
4563NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
4564NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
4565
4566if(present(time_definition)) then
4567 this%time_definition=time_definition
4568else
4569 this%time_definition=1 !default to validity time
4570end if
4571
4572END SUBROUTINE vol7d_init
4573
4574
4578ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
4579TYPE(vol7d),intent(inout) :: this
4580LOGICAL, INTENT(in), OPTIONAL :: dataonly
4581
4582
4583IF (.NOT. optio_log(dataonly)) THEN
4584 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
4585 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
4586 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
4587 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
4588 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
4589 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
4590 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
4591 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
4592 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
4593 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
4594ENDIF
4595IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
4596IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
4597IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
4598IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
4599IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
4600IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
4601IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
4602IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
4603IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
4604IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
4605
4606IF (.NOT. optio_log(dataonly)) THEN
4607 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4608 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4609ENDIF
4610IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4611IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4612IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4613
4614IF (.NOT. optio_log(dataonly)) THEN
4618ENDIF
4622
4623END SUBROUTINE vol7d_delete
4624
4625
4626
4627integer function vol7d_check(this)
4628TYPE(vol7d),intent(in) :: this
4629integer :: i,j,k,l,m,n
4630
4631vol7d_check=0
4632
4633if (associated(this%voldatii)) then
4634do i = 1,size(this%voldatii,1)
4635 do j = 1,size(this%voldatii,2)
4636 do k = 1,size(this%voldatii,3)
4637 do l = 1,size(this%voldatii,4)
4638 do m = 1,size(this%voldatii,5)
4639 do n = 1,size(this%voldatii,6)
4640 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4641 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4643 vol7d_check=1
4644 end if
4645 end do
4646 end do
4647 end do
4648 end do
4649 end do
4650end do
4651end if
4652
4653
4654if (associated(this%voldatir)) then
4655do i = 1,size(this%voldatir,1)
4656 do j = 1,size(this%voldatir,2)
4657 do k = 1,size(this%voldatir,3)
4658 do l = 1,size(this%voldatir,4)
4659 do m = 1,size(this%voldatir,5)
4660 do n = 1,size(this%voldatir,6)
4661 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4662 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4664 vol7d_check=2
4665 end if
4666 end do
4667 end do
4668 end do
4669 end do
4670 end do
4671end do
4672end if
4673
4674if (associated(this%voldatid)) then
4675do i = 1,size(this%voldatid,1)
4676 do j = 1,size(this%voldatid,2)
4677 do k = 1,size(this%voldatid,3)
4678 do l = 1,size(this%voldatid,4)
4679 do m = 1,size(this%voldatid,5)
4680 do n = 1,size(this%voldatid,6)
4681 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4682 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4684 vol7d_check=3
4685 end if
4686 end do
4687 end do
4688 end do
4689 end do
4690 end do
4691end do
4692end if
4693
4694if (associated(this%voldatib)) then
4695do i = 1,size(this%voldatib,1)
4696 do j = 1,size(this%voldatib,2)
4697 do k = 1,size(this%voldatib,3)
4698 do l = 1,size(this%voldatib,4)
4699 do m = 1,size(this%voldatib,5)
4700 do n = 1,size(this%voldatib,6)
4701 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4702 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4704 vol7d_check=4
4705 end if
4706 end do
4707 end do
4708 end do
4709 end do
4710 end do
4711end do
4712end if
4713
4714end function vol7d_check
4715
4716
4717
4718!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4720SUBROUTINE vol7d_display(this)
4721TYPE(vol7d),intent(in) :: this
4722integer :: i
4723
4724REAL :: rdat
4725DOUBLE PRECISION :: ddat
4726INTEGER :: idat
4727INTEGER(kind=int_b) :: bdat
4728CHARACTER(len=vol7d_cdatalen) :: cdat
4729
4730
4731print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4732if (this%time_definition == 0) then
4733 print*,"TIME DEFINITION: time is reference time"
4734else if (this%time_definition == 1) then
4735 print*,"TIME DEFINITION: time is validity time"
4736else
4737 print*,"Time definition have a wrong walue:", this%time_definition
4738end if
4739
4740IF (ASSOCIATED(this%network))then
4741 print*,"---- network vector ----"
4742 print*,"elements=",size(this%network)
4743 do i=1, size(this%network)
4745 end do
4746end IF
4747
4748IF (ASSOCIATED(this%ana))then
4749 print*,"---- ana vector ----"
4750 print*,"elements=",size(this%ana)
4751 do i=1, size(this%ana)
4753 end do
4754end IF
4755
4756IF (ASSOCIATED(this%time))then
4757 print*,"---- time vector ----"
4758 print*,"elements=",size(this%time)
4759 do i=1, size(this%time)
4761 end do
4762end if
4763
4764IF (ASSOCIATED(this%level)) then
4765 print*,"---- level vector ----"
4766 print*,"elements=",size(this%level)
4767 do i =1,size(this%level)
4769 end do
4770end if
4771
4772IF (ASSOCIATED(this%timerange))then
4773 print*,"---- timerange vector ----"
4774 print*,"elements=",size(this%timerange)
4775 do i =1,size(this%timerange)
4777 end do
4778end if
4779
4780
4781print*,"---- ana vector ----"
4782print*,""
4783print*,"->>>>>>>>> anavar -"
4785print*,""
4786print*,"->>>>>>>>> anaattr -"
4788print*,""
4789print*,"->>>>>>>>> anavarattr -"
4791
4792print*,"-- ana data section (first point) --"
4793
4794idat=imiss
4795rdat=rmiss
4796ddat=dmiss
4797bdat=ibmiss
4798cdat=cmiss
4799
4800!ntime = MIN(SIZE(this%time),nprint)
4801!ntimerange = MIN(SIZE(this%timerange),nprint)
4802!nlevel = MIN(SIZE(this%level),nprint)
4803!nnetwork = MIN(SIZE(this%network),nprint)
4804!nana = MIN(SIZE(this%ana),nprint)
4805
4806IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4807if (associated(this%volanai)) then
4808 do i=1,size(this%anavar%i)
4809 idat=this%volanai(1,i,1)
4811 end do
4812end if
4813idat=imiss
4814
4815if (associated(this%volanar)) then
4816 do i=1,size(this%anavar%r)
4817 rdat=this%volanar(1,i,1)
4819 end do
4820end if
4821rdat=rmiss
4822
4823if (associated(this%volanad)) then
4824 do i=1,size(this%anavar%d)
4825 ddat=this%volanad(1,i,1)
4827 end do
4828end if
4829ddat=dmiss
4830
4831if (associated(this%volanab)) then
4832 do i=1,size(this%anavar%b)
4833 bdat=this%volanab(1,i,1)
4835 end do
4836end if
4837bdat=ibmiss
4838
4839if (associated(this%volanac)) then
4840 do i=1,size(this%anavar%c)
4841 cdat=this%volanac(1,i,1)
4843 end do
4844end if
4845cdat=cmiss
4846ENDIF
4847
4848print*,"---- data vector ----"
4849print*,""
4850print*,"->>>>>>>>> dativar -"
4852print*,""
4853print*,"->>>>>>>>> datiattr -"
4855print*,""
4856print*,"->>>>>>>>> dativarattr -"
4858
4859print*,"-- data data section (first point) --"
4860
4861idat=imiss
4862rdat=rmiss
4863ddat=dmiss
4864bdat=ibmiss
4865cdat=cmiss
4866
4867IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4868 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4869if (associated(this%voldatii)) then
4870 do i=1,size(this%dativar%i)
4871 idat=this%voldatii(1,1,1,1,i,1)
4873 end do
4874end if
4875idat=imiss
4876
4877if (associated(this%voldatir)) then
4878 do i=1,size(this%dativar%r)
4879 rdat=this%voldatir(1,1,1,1,i,1)
4881 end do
4882end if
4883rdat=rmiss
4884
4885if (associated(this%voldatid)) then
4886 do i=1,size(this%dativar%d)
4887 ddat=this%voldatid(1,1,1,1,i,1)
4889 end do
4890end if
4891ddat=dmiss
4892
4893if (associated(this%voldatib)) then
4894 do i=1,size(this%dativar%b)
4895 bdat=this%voldatib(1,1,1,1,i,1)
4897 end do
4898end if
4899bdat=ibmiss
4900
4901if (associated(this%voldatic)) then
4902 do i=1,size(this%dativar%c)
4903 cdat=this%voldatic(1,1,1,1,i,1)
4905 end do
4906end if
4907cdat=cmiss
4908ENDIF
4909
4910print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
4911
4912END SUBROUTINE vol7d_display
4913
4914
4916SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
4917TYPE(vol7d_var),intent(in) :: this
4919REAL :: rdat
4921DOUBLE PRECISION :: ddat
4923INTEGER :: idat
4925INTEGER(kind=int_b) :: bdat
4927CHARACTER(len=*) :: cdat
4928
4929print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4930
4931end SUBROUTINE dat_display
4932
4934SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
4935
4936TYPE(vol7d_var),intent(in) :: this(:)
4938REAL :: rdat(:)
4940DOUBLE PRECISION :: ddat(:)
4942INTEGER :: idat(:)
4944INTEGER(kind=int_b) :: bdat(:)
4946CHARACTER(len=*):: cdat(:)
4947
4948integer :: i
4949
4950do i =1,size(this)
4952end do
4953
4954end SUBROUTINE dat_vect_display
4955
4956
4957FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
4958#ifdef HAVE_DBALLE
4959USE dballef
4960#endif
4961TYPE(vol7d_var),INTENT(in) :: this
4963REAL :: rdat
4965DOUBLE PRECISION :: ddat
4967INTEGER :: idat
4969INTEGER(kind=int_b) :: bdat
4971CHARACTER(len=*) :: cdat
4972CHARACTER(len=80) :: to_char_dat
4973
4974CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
4975
4976
4977#ifdef HAVE_DBALLE
4978INTEGER :: handle, ier
4979
4980handle = 0
4981to_char_dat="VALUE: "
4982
4987
4989 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
4990 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
4991 ier = idba_fatto(handle)
4992 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
4993endif
4994
4995#else
4996
4997to_char_dat="VALUE: "
5003
5004#endif
5005
5006END FUNCTION to_char_dat
5007
5008
5011FUNCTION vol7d_c_e(this) RESULT(c_e)
5012TYPE(vol7d), INTENT(in) :: this
5013
5014LOGICAL :: c_e
5015
5017 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5018 ASSOCIATED(this%network) .OR. &
5019 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5020 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5021 ASSOCIATED(this%anavar%c) .OR. &
5022 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5023 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5024 ASSOCIATED(this%anaattr%c) .OR. &
5025 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5026 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5027 ASSOCIATED(this%dativar%c) .OR. &
5028 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5029 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5030 ASSOCIATED(this%datiattr%c)
5031
5032END FUNCTION vol7d_c_e
5033
5034
5073SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5074 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5075 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5076 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5077 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5078 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5079 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5080 ini)
5081TYPE(vol7d),INTENT(inout) :: this
5082INTEGER,INTENT(in),OPTIONAL :: nana
5083INTEGER,INTENT(in),OPTIONAL :: ntime
5084INTEGER,INTENT(in),OPTIONAL :: nlevel
5085INTEGER,INTENT(in),OPTIONAL :: ntimerange
5086INTEGER,INTENT(in),OPTIONAL :: nnetwork
5088INTEGER,INTENT(in),OPTIONAL :: &
5089 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5090 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5091 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5092 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5093 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5094 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5095LOGICAL,INTENT(in),OPTIONAL :: ini
5096
5097INTEGER :: i
5098LOGICAL :: linit
5099
5100IF (PRESENT(ini)) THEN
5101 linit = ini
5102ELSE
5103 linit = .false.
5104ENDIF
5105
5106! Dimensioni principali
5107IF (PRESENT(nana)) THEN
5108 IF (nana >= 0) THEN
5109 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5110 ALLOCATE(this%ana(nana))
5111 IF (linit) THEN
5112 DO i = 1, nana
5114 ENDDO
5115 ENDIF
5116 ENDIF
5117ENDIF
5118IF (PRESENT(ntime)) THEN
5119 IF (ntime >= 0) THEN
5120 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5121 ALLOCATE(this%time(ntime))
5122 IF (linit) THEN
5123 DO i = 1, ntime
5125 ENDDO
5126 ENDIF
5127 ENDIF
5128ENDIF
5129IF (PRESENT(nlevel)) THEN
5130 IF (nlevel >= 0) THEN
5131 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5132 ALLOCATE(this%level(nlevel))
5133 IF (linit) THEN
5134 DO i = 1, nlevel
5136 ENDDO
5137 ENDIF
5138 ENDIF
5139ENDIF
5140IF (PRESENT(ntimerange)) THEN
5141 IF (ntimerange >= 0) THEN
5142 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5143 ALLOCATE(this%timerange(ntimerange))
5144 IF (linit) THEN
5145 DO i = 1, ntimerange
5147 ENDDO
5148 ENDIF
5149 ENDIF
5150ENDIF
5151IF (PRESENT(nnetwork)) THEN
5152 IF (nnetwork >= 0) THEN
5153 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5154 ALLOCATE(this%network(nnetwork))
5155 IF (linit) THEN
5156 DO i = 1, nnetwork
5158 ENDDO
5159 ENDIF
5160 ENDIF
5161ENDIF
5162! Dimensioni dei tipi delle variabili
5163CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5164 nanavari, nanavarb, nanavarc, ini)
5165CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5166 nanaattri, nanaattrb, nanaattrc, ini)
5167CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5168 nanavarattri, nanavarattrb, nanavarattrc, ini)
5169CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5170 ndativari, ndativarb, ndativarc, ini)
5171CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5172 ndatiattri, ndatiattrb, ndatiattrc, ini)
5173CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5174 ndativarattri, ndativarattrb, ndativarattrc, ini)
5175
5176END SUBROUTINE vol7d_alloc
5177
5178
5179FUNCTION vol7d_check_alloc_ana(this)
5180TYPE(vol7d),INTENT(in) :: this
5181LOGICAL :: vol7d_check_alloc_ana
5182
5183vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5184
5185END FUNCTION vol7d_check_alloc_ana
5186
5187SUBROUTINE vol7d_force_alloc_ana(this, ini)
5188TYPE(vol7d),INTENT(inout) :: this
5189LOGICAL,INTENT(in),OPTIONAL :: ini
5190
5191! Alloco i descrittori minimi per avere un volume di anagrafica
5192IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5193IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5194
5195END SUBROUTINE vol7d_force_alloc_ana
5196
5197
5198FUNCTION vol7d_check_alloc_dati(this)
5199TYPE(vol7d),INTENT(in) :: this
5200LOGICAL :: vol7d_check_alloc_dati
5201
5202vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5203 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5204 ASSOCIATED(this%timerange)
5205
5206END FUNCTION vol7d_check_alloc_dati
5207
5208SUBROUTINE vol7d_force_alloc_dati(this, ini)
5209TYPE(vol7d),INTENT(inout) :: this
5210LOGICAL,INTENT(in),OPTIONAL :: ini
5211
5212! Alloco i descrittori minimi per avere un volume di dati
5213CALL vol7d_force_alloc_ana(this, ini)
5214IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5215IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5216IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5217
5218END SUBROUTINE vol7d_force_alloc_dati
5219
5220
5221SUBROUTINE vol7d_force_alloc(this)
5222TYPE(vol7d),INTENT(inout) :: this
5223
5224! If anything really not allocated yet, allocate with size 0
5225IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
5226IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
5227IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
5228IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
5229IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
5230
5231END SUBROUTINE vol7d_force_alloc
5232
5233
5234FUNCTION vol7d_check_vol(this)
5235TYPE(vol7d),INTENT(in) :: this
5236LOGICAL :: vol7d_check_vol
5237
5238vol7d_check_vol = c_e(this)
5239
5240! Anagrafica
5241IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5242 vol7d_check_vol = .false.
5243ENDIF
5244
5245IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5246 vol7d_check_vol = .false.
5247ENDIF
5248
5249IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5250 vol7d_check_vol = .false.
5251ENDIF
5252
5253IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5254 vol7d_check_vol = .false.
5255ENDIF
5256
5257IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5258 vol7d_check_vol = .false.
5259ENDIF
5260IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5261 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5262 ASSOCIATED(this%anavar%c)) THEN
5263 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
5264ENDIF
5265
5266! Attributi dell'anagrafica
5267IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5268 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5269 vol7d_check_vol = .false.
5270ENDIF
5271
5272IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5273 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5274 vol7d_check_vol = .false.
5275ENDIF
5276
5277IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5278 .NOT.ASSOCIATED(this%volanaattri)) THEN
5279 vol7d_check_vol = .false.
5280ENDIF
5281
5282IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5283 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5284 vol7d_check_vol = .false.
5285ENDIF
5286
5287IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5288 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5289 vol7d_check_vol = .false.
5290ENDIF
5291
5292! Dati
5293IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5294 vol7d_check_vol = .false.
5295ENDIF
5296
5297IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5298 vol7d_check_vol = .false.
5299ENDIF
5300
5301IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5302 vol7d_check_vol = .false.
5303ENDIF
5304
5305IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5306 vol7d_check_vol = .false.
5307ENDIF
5308
5309IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5310 vol7d_check_vol = .false.
5311ENDIF
5312
5313! Attributi dei dati
5314IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5315 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5316 vol7d_check_vol = .false.
5317ENDIF
5318
5319IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5320 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5321 vol7d_check_vol = .false.
5322ENDIF
5323
5324IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5325 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5326 vol7d_check_vol = .false.
5327ENDIF
5328
5329IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5330 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5331 vol7d_check_vol = .false.
5332ENDIF
5333
5334IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5335 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5336 vol7d_check_vol = .false.
5337ENDIF
5338IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5339 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5340 ASSOCIATED(this%dativar%c)) THEN
5341 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
5342ENDIF
5343
5344END FUNCTION vol7d_check_vol
5345
5346
5361SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
5362TYPE(vol7d),INTENT(inout) :: this
5363LOGICAL,INTENT(in),OPTIONAL :: ini
5364LOGICAL,INTENT(in),OPTIONAL :: inivol
5365
5366LOGICAL :: linivol
5367
5368IF (PRESENT(inivol)) THEN
5369 linivol = inivol
5370ELSE
5371 linivol = .true.
5372ENDIF
5373
5374! Anagrafica
5375IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5376 CALL vol7d_force_alloc_ana(this, ini)
5377 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
5378 IF (linivol) this%volanar(:,:,:) = rmiss
5379ENDIF
5380
5381IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5382 CALL vol7d_force_alloc_ana(this, ini)
5383 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
5384 IF (linivol) this%volanad(:,:,:) = rdmiss
5385ENDIF
5386
5387IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5388 CALL vol7d_force_alloc_ana(this, ini)
5389 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
5390 IF (linivol) this%volanai(:,:,:) = imiss
5391ENDIF
5392
5393IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5394 CALL vol7d_force_alloc_ana(this, ini)
5395 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
5396 IF (linivol) this%volanab(:,:,:) = ibmiss
5397ENDIF
5398
5399IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5400 CALL vol7d_force_alloc_ana(this, ini)
5401 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
5402 IF (linivol) this%volanac(:,:,:) = cmiss
5403ENDIF
5404
5405! Attributi dell'anagrafica
5406IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5407 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5408 CALL vol7d_force_alloc_ana(this, ini)
5409 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
5410 SIZE(this%network), SIZE(this%anaattr%r)))
5411 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
5412ENDIF
5413
5414IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5415 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5416 CALL vol7d_force_alloc_ana(this, ini)
5417 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
5418 SIZE(this%network), SIZE(this%anaattr%d)))
5419 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
5420ENDIF
5421
5422IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5423 .NOT.ASSOCIATED(this%volanaattri)) THEN
5424 CALL vol7d_force_alloc_ana(this, ini)
5425 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
5426 SIZE(this%network), SIZE(this%anaattr%i)))
5427 IF (linivol) this%volanaattri(:,:,:,:) = imiss
5428ENDIF
5429
5430IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5431 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5432 CALL vol7d_force_alloc_ana(this, ini)
5433 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
5434 SIZE(this%network), SIZE(this%anaattr%b)))
5435 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
5436ENDIF
5437
5438IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5439 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5440 CALL vol7d_force_alloc_ana(this, ini)
5441 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
5442 SIZE(this%network), SIZE(this%anaattr%c)))
5443 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
5444ENDIF
5445
5446! Dati
5447IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5448 CALL vol7d_force_alloc_dati(this, ini)
5449 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5450 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
5451 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
5452ENDIF
5453
5454IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5455 CALL vol7d_force_alloc_dati(this, ini)
5456 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5457 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
5458 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
5459ENDIF
5460
5461IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5462 CALL vol7d_force_alloc_dati(this, ini)
5463 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5464 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
5465 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
5466ENDIF
5467
5468IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5469 CALL vol7d_force_alloc_dati(this, ini)
5470 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5471 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
5472 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
5473ENDIF
5474
5475IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5476 CALL vol7d_force_alloc_dati(this, ini)
5477 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5478 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
5479 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
5480ENDIF
5481
5482! Attributi dei dati
5483IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5484 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5485 CALL vol7d_force_alloc_dati(this, ini)
5486 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5487 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
5488 SIZE(this%datiattr%r)))
5489 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
5490ENDIF
5491
5492IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5493 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5494 CALL vol7d_force_alloc_dati(this, ini)
5495 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5496 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
5497 SIZE(this%datiattr%d)))
5498 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
5499ENDIF
5500
5501IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5502 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5503 CALL vol7d_force_alloc_dati(this, ini)
5504 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5505 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
5506 SIZE(this%datiattr%i)))
5507 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
5508ENDIF
5509
5510IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5511 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5512 CALL vol7d_force_alloc_dati(this, ini)
5513 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5514 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
5515 SIZE(this%datiattr%b)))
5516 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
5517ENDIF
5518
5519IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5520 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5521 CALL vol7d_force_alloc_dati(this, ini)
5522 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5523 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
5524 SIZE(this%datiattr%c)))
5525 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
5526ENDIF
5527
5528! Catch-all method
5529CALL vol7d_force_alloc(this)
5530
5531! Creo gli indici var-attr
5532
5533#ifdef DEBUG
5534CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
5535#endif
5536
5537CALL vol7d_set_attr_ind(this)
5538
5539
5540
5541END SUBROUTINE vol7d_alloc_vol
5542
5543
5550SUBROUTINE vol7d_set_attr_ind(this)
5551TYPE(vol7d),INTENT(inout) :: this
5552
5553INTEGER :: i
5554
5555! real
5556IF (ASSOCIATED(this%dativar%r)) THEN
5557 IF (ASSOCIATED(this%dativarattr%r)) THEN
5558 DO i = 1, SIZE(this%dativar%r)
5559 this%dativar%r(i)%r = &
5560 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
5561 ENDDO
5562 ENDIF
5563
5564 IF (ASSOCIATED(this%dativarattr%d)) THEN
5565 DO i = 1, SIZE(this%dativar%r)
5566 this%dativar%r(i)%d = &
5567 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
5568 ENDDO
5569 ENDIF
5570
5571 IF (ASSOCIATED(this%dativarattr%i)) THEN
5572 DO i = 1, SIZE(this%dativar%r)
5573 this%dativar%r(i)%i = &
5574 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
5575 ENDDO
5576 ENDIF
5577
5578 IF (ASSOCIATED(this%dativarattr%b)) THEN
5579 DO i = 1, SIZE(this%dativar%r)
5580 this%dativar%r(i)%b = &
5581 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
5582 ENDDO
5583 ENDIF
5584
5585 IF (ASSOCIATED(this%dativarattr%c)) THEN
5586 DO i = 1, SIZE(this%dativar%r)
5587 this%dativar%r(i)%c = &
5588 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
5589 ENDDO
5590 ENDIF
5591ENDIF
5592! double
5593IF (ASSOCIATED(this%dativar%d)) THEN
5594 IF (ASSOCIATED(this%dativarattr%r)) THEN
5595 DO i = 1, SIZE(this%dativar%d)
5596 this%dativar%d(i)%r = &
5597 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
5598 ENDDO
5599 ENDIF
5600
5601 IF (ASSOCIATED(this%dativarattr%d)) THEN
5602 DO i = 1, SIZE(this%dativar%d)
5603 this%dativar%d(i)%d = &
5604 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
5605 ENDDO
5606 ENDIF
5607
5608 IF (ASSOCIATED(this%dativarattr%i)) THEN
5609 DO i = 1, SIZE(this%dativar%d)
5610 this%dativar%d(i)%i = &
5611 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
5612 ENDDO
5613 ENDIF
5614
5615 IF (ASSOCIATED(this%dativarattr%b)) THEN
5616 DO i = 1, SIZE(this%dativar%d)
5617 this%dativar%d(i)%b = &
5618 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
5619 ENDDO
5620 ENDIF
5621
5622 IF (ASSOCIATED(this%dativarattr%c)) THEN
5623 DO i = 1, SIZE(this%dativar%d)
5624 this%dativar%d(i)%c = &
5625 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
5626 ENDDO
5627 ENDIF
5628ENDIF
5629! integer
5630IF (ASSOCIATED(this%dativar%i)) THEN
5631 IF (ASSOCIATED(this%dativarattr%r)) THEN
5632 DO i = 1, SIZE(this%dativar%i)
5633 this%dativar%i(i)%r = &
5634 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5635 ENDDO
5636 ENDIF
5637
5638 IF (ASSOCIATED(this%dativarattr%d)) THEN
5639 DO i = 1, SIZE(this%dativar%i)
5640 this%dativar%i(i)%d = &
5641 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5642 ENDDO
5643 ENDIF
5644
5645 IF (ASSOCIATED(this%dativarattr%i)) THEN
5646 DO i = 1, SIZE(this%dativar%i)
5647 this%dativar%i(i)%i = &
5648 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5649 ENDDO
5650 ENDIF
5651
5652 IF (ASSOCIATED(this%dativarattr%b)) THEN
5653 DO i = 1, SIZE(this%dativar%i)
5654 this%dativar%i(i)%b = &
5655 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5656 ENDDO
5657 ENDIF
5658
5659 IF (ASSOCIATED(this%dativarattr%c)) THEN
5660 DO i = 1, SIZE(this%dativar%i)
5661 this%dativar%i(i)%c = &
5662 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5663 ENDDO
5664 ENDIF
5665ENDIF
5666! byte
5667IF (ASSOCIATED(this%dativar%b)) THEN
5668 IF (ASSOCIATED(this%dativarattr%r)) THEN
5669 DO i = 1, SIZE(this%dativar%b)
5670 this%dativar%b(i)%r = &
5671 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5672 ENDDO
5673 ENDIF
5674
5675 IF (ASSOCIATED(this%dativarattr%d)) THEN
5676 DO i = 1, SIZE(this%dativar%b)
5677 this%dativar%b(i)%d = &
5678 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5679 ENDDO
5680 ENDIF
5681
5682 IF (ASSOCIATED(this%dativarattr%i)) THEN
5683 DO i = 1, SIZE(this%dativar%b)
5684 this%dativar%b(i)%i = &
5685 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5686 ENDDO
5687 ENDIF
5688
5689 IF (ASSOCIATED(this%dativarattr%b)) THEN
5690 DO i = 1, SIZE(this%dativar%b)
5691 this%dativar%b(i)%b = &
5692 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5693 ENDDO
5694 ENDIF
5695
5696 IF (ASSOCIATED(this%dativarattr%c)) THEN
5697 DO i = 1, SIZE(this%dativar%b)
5698 this%dativar%b(i)%c = &
5699 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5700 ENDDO
5701 ENDIF
5702ENDIF
5703! character
5704IF (ASSOCIATED(this%dativar%c)) THEN
5705 IF (ASSOCIATED(this%dativarattr%r)) THEN
5706 DO i = 1, SIZE(this%dativar%c)
5707 this%dativar%c(i)%r = &
5708 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5709 ENDDO
5710 ENDIF
5711
5712 IF (ASSOCIATED(this%dativarattr%d)) THEN
5713 DO i = 1, SIZE(this%dativar%c)
5714 this%dativar%c(i)%d = &
5715 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5716 ENDDO
5717 ENDIF
5718
5719 IF (ASSOCIATED(this%dativarattr%i)) THEN
5720 DO i = 1, SIZE(this%dativar%c)
5721 this%dativar%c(i)%i = &
5722 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5723 ENDDO
5724 ENDIF
5725
5726 IF (ASSOCIATED(this%dativarattr%b)) THEN
5727 DO i = 1, SIZE(this%dativar%c)
5728 this%dativar%c(i)%b = &
5729 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5730 ENDDO
5731 ENDIF
5732
5733 IF (ASSOCIATED(this%dativarattr%c)) THEN
5734 DO i = 1, SIZE(this%dativar%c)
5735 this%dativar%c(i)%c = &
5736 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5737 ENDDO
5738 ENDIF
5739ENDIF
5740
5741END SUBROUTINE vol7d_set_attr_ind
5742
5743
5748SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5749 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5750TYPE(vol7d),INTENT(INOUT) :: this
5751TYPE(vol7d),INTENT(INOUT) :: that
5752LOGICAL,INTENT(IN),OPTIONAL :: sort
5753LOGICAL,INTENT(in),OPTIONAL :: bestdata
5754LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5755
5756TYPE(vol7d) :: v7d_clean
5757
5758
5760 this = that
5762 that = v7d_clean ! destroy that without deallocating
5763ELSE ! Append that to this and destroy that
5765 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5767ENDIF
5768
5769END SUBROUTINE vol7d_merge
5770
5771
5800SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5801 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5802TYPE(vol7d),INTENT(INOUT) :: this
5803TYPE(vol7d),INTENT(IN) :: that
5804LOGICAL,INTENT(IN),OPTIONAL :: sort
5805! experimental, please do not use outside the library now, they force the use
5806! of a simplified mapping algorithm which is valid only whene the dimension
5807! content is the same in both volumes , or when one of them is empty
5808LOGICAL,INTENT(in),OPTIONAL :: bestdata
5809LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5810
5811
5812TYPE(vol7d) :: v7dtmp
5813LOGICAL :: lsort, lbestdata
5814INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5815 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5816
5818IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5821 RETURN
5822ENDIF
5823
5824IF (this%time_definition /= that%time_definition) THEN
5825 CALL l4f_log(l4f_fatal, &
5826 'in vol7d_append, cannot append volumes with different &
5827 &time definition')
5828 CALL raise_fatal_error()
5829ENDIF
5830
5831! Completo l'allocazione per avere volumi a norma
5832CALL vol7d_alloc_vol(this)
5833
5837
5838! Calcolo le mappature tra volumi vecchi e volume nuovo
5839! I puntatori remap* vengono tutti o allocati o nullificati
5840IF (optio_log(ltimesimple)) THEN
5841 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5842 lsort, remapt1, remapt2)
5843ELSE
5844 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5845 lsort, remapt1, remapt2)
5846ENDIF
5847IF (optio_log(ltimerangesimple)) THEN
5848 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5849 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5850ELSE
5851 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5852 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5853ENDIF
5854IF (optio_log(llevelsimple)) THEN
5855 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5856 lsort, remapl1, remapl2)
5857ELSE
5858 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5859 lsort, remapl1, remapl2)
5860ENDIF
5861IF (optio_log(lanasimple)) THEN
5862 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5863 .false., remapa1, remapa2)
5864ELSE
5865 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5866 .false., remapa1, remapa2)
5867ENDIF
5868IF (optio_log(lnetworksimple)) THEN
5869 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5870 .false., remapn1, remapn2)
5871ELSE
5872 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5873 .false., remapn1, remapn2)
5874ENDIF
5875
5876! Faccio la fusione fisica dei volumi
5877CALL vol7d_merge_finalr(this, that, v7dtmp, &
5878 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5879 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5880CALL vol7d_merge_finald(this, that, v7dtmp, &
5881 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5882 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5883CALL vol7d_merge_finali(this, that, v7dtmp, &
5884 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5885 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5886CALL vol7d_merge_finalb(this, that, v7dtmp, &
5887 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5888 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5889CALL vol7d_merge_finalc(this, that, v7dtmp, &
5890 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5891 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5892
5893! Dealloco i vettori di rimappatura
5894IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5895IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5896IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5897IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5898IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5899IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5900IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
5901IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
5902IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
5903IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
5904
5905! Distruggo il vecchio volume e assegno il nuovo a this
5907this = v7dtmp
5908! Ricreo gli indici var-attr
5909CALL vol7d_set_attr_ind(this)
5910
5911END SUBROUTINE vol7d_append
5912
5913
5946SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
5947 lsort_time, lsort_timerange, lsort_level, &
5948 ltime, ltimerange, llevel, lana, lnetwork, &
5949 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
5950 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
5951 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
5952 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
5953 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
5954 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
5955TYPE(vol7d),INTENT(IN) :: this
5956TYPE(vol7d),INTENT(INOUT) :: that
5957LOGICAL,INTENT(IN),OPTIONAL :: sort
5958LOGICAL,INTENT(IN),OPTIONAL :: unique
5959LOGICAL,INTENT(IN),OPTIONAL :: miss
5960LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
5961LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
5962LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
5970LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
5972LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
5974LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
5976LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
5978LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
5980LOGICAL,INTENT(in),OPTIONAL :: &
5981 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
5982 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
5983 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
5984 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
5985 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
5986 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
5987
5988LOGICAL :: lsort, lunique, lmiss
5989INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
5990
5993IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
5994
5998
5999! Calcolo le mappature tra volume vecchio e volume nuovo
6000! I puntatori remap* vengono tutti o allocati o nullificati
6001CALL vol7d_remap1_datetime(this%time, that%time, &
6002 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6003CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6004 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6005CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6006 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6007CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6008 lsort, lunique, lmiss, remapa, lana)
6009CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6010 lsort, lunique, lmiss, remapn, lnetwork)
6011
6012! lanavari, lanavarb, lanavarc, &
6013! lanaattri, lanaattrb, lanaattrc, &
6014! lanavarattri, lanavarattrb, lanavarattrc, &
6015! ldativari, ldativarb, ldativarc, &
6016! ldatiattri, ldatiattrb, ldatiattrc, &
6017! ldativarattri, ldativarattrb, ldativarattrc
6018! Faccio la riforma fisica dei volumi
6019CALL vol7d_reform_finalr(this, that, &
6020 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6021 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6022CALL vol7d_reform_finald(this, that, &
6023 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6024 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6025CALL vol7d_reform_finali(this, that, &
6026 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6027 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6028CALL vol7d_reform_finalb(this, that, &
6029 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6030 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6031CALL vol7d_reform_finalc(this, that, &
6032 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6033 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6034
6035! Dealloco i vettori di rimappatura
6036IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6037IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6038IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6039IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6040IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6041
6042! Ricreo gli indici var-attr
6043CALL vol7d_set_attr_ind(that)
6044that%time_definition = this%time_definition
6045
6046END SUBROUTINE vol7d_copy
6047
6048
6059SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6060 lsort_time, lsort_timerange, lsort_level, &
6061 ltime, ltimerange, llevel, lana, lnetwork, &
6062 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6063 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6064 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6065 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6066 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6067 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6068 ,purgeana)
6069TYPE(vol7d),INTENT(INOUT) :: this
6070LOGICAL,INTENT(IN),OPTIONAL :: sort
6071LOGICAL,INTENT(IN),OPTIONAL :: unique
6072LOGICAL,INTENT(IN),OPTIONAL :: miss
6073LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6074LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6075LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6083LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6084LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6085LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6086LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6087LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6089LOGICAL,INTENT(in),OPTIONAL :: &
6090 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6091 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6092 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6093 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6094 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6095 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6096LOGICAL,INTENT(IN),OPTIONAL :: purgeana
6097
6098TYPE(vol7d) :: v7dtmp
6099logical,allocatable :: llana(:)
6100integer :: i
6101
6103 lsort_time, lsort_timerange, lsort_level, &
6104 ltime, ltimerange, llevel, lana, lnetwork, &
6105 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6106 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6107 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6108 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6109 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6110 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6111
6112! destroy old volume
6114
6115if (optio_log(purgeana)) then
6116 allocate(llana(size(v7dtmp%ana)))
6117 llana =.false.
6118 do i =1,size(v7dtmp%ana)
6119 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6120 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6121 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6122 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6123 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6124 end do
6125 CALL vol7d_copy(v7dtmp, this,lana=llana)
6127 deallocate(llana)
6128else
6129 this=v7dtmp
6130end if
6131
6132END SUBROUTINE vol7d_reform
6133
6134
6142SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6143TYPE(vol7d),INTENT(INOUT) :: this
6144LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
6145LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
6146LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
6147
6148INTEGER :: i
6149LOGICAL :: to_be_sorted
6150
6151to_be_sorted = .false.
6152CALL vol7d_alloc_vol(this) ! usual safety check
6153
6154IF (optio_log(lsort_time)) THEN
6155 DO i = 2, SIZE(this%time)
6156 IF (this%time(i) < this%time(i-1)) THEN
6157 to_be_sorted = .true.
6158 EXIT
6159 ENDIF
6160 ENDDO
6161ENDIF
6162IF (optio_log(lsort_timerange)) THEN
6163 DO i = 2, SIZE(this%timerange)
6164 IF (this%timerange(i) < this%timerange(i-1)) THEN
6165 to_be_sorted = .true.
6166 EXIT
6167 ENDIF
6168 ENDDO
6169ENDIF
6170IF (optio_log(lsort_level)) THEN
6171 DO i = 2, SIZE(this%level)
6172 IF (this%level(i) < this%level(i-1)) THEN
6173 to_be_sorted = .true.
6174 EXIT
6175 ENDIF
6176 ENDDO
6177ENDIF
6178
6179IF (to_be_sorted) CALL vol7d_reform(this, &
6180 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6181
6182END SUBROUTINE vol7d_smart_sort
6183
6191SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6192TYPE(vol7d),INTENT(inout) :: this
6193CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
6194CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
6195TYPE(vol7d_network),OPTIONAL :: nl(:)
6196TYPE(datetime),INTENT(in),OPTIONAL :: s_d
6197TYPE(datetime),INTENT(in),OPTIONAL :: e_d
6198
6199INTEGER :: i
6200
6201IF (PRESENT(avl)) THEN
6202 IF (SIZE(avl) > 0) THEN
6203
6204 IF (ASSOCIATED(this%anavar%r)) THEN
6205 DO i = 1, SIZE(this%anavar%r)
6206 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6207 ENDDO
6208 ENDIF
6209
6210 IF (ASSOCIATED(this%anavar%i)) THEN
6211 DO i = 1, SIZE(this%anavar%i)
6212 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6213 ENDDO
6214 ENDIF
6215
6216 IF (ASSOCIATED(this%anavar%b)) THEN
6217 DO i = 1, SIZE(this%anavar%b)
6218 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6219 ENDDO
6220 ENDIF
6221
6222 IF (ASSOCIATED(this%anavar%d)) THEN
6223 DO i = 1, SIZE(this%anavar%d)
6224 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
6225 ENDDO
6226 ENDIF
6227
6228 IF (ASSOCIATED(this%anavar%c)) THEN
6229 DO i = 1, SIZE(this%anavar%c)
6230 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
6231 ENDDO
6232 ENDIF
6233
6234 ENDIF
6235ENDIF
6236
6237
6238IF (PRESENT(vl)) THEN
6239 IF (size(vl) > 0) THEN
6240 IF (ASSOCIATED(this%dativar%r)) THEN
6241 DO i = 1, SIZE(this%dativar%r)
6242 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
6243 ENDDO
6244 ENDIF
6245
6246 IF (ASSOCIATED(this%dativar%i)) THEN
6247 DO i = 1, SIZE(this%dativar%i)
6248 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
6249 ENDDO
6250 ENDIF
6251
6252 IF (ASSOCIATED(this%dativar%b)) THEN
6253 DO i = 1, SIZE(this%dativar%b)
6254 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
6255 ENDDO
6256 ENDIF
6257
6258 IF (ASSOCIATED(this%dativar%d)) THEN
6259 DO i = 1, SIZE(this%dativar%d)
6260 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
6261 ENDDO
6262 ENDIF
6263
6264 IF (ASSOCIATED(this%dativar%c)) THEN
6265 DO i = 1, SIZE(this%dativar%c)
6266 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6267 ENDDO
6268 ENDIF
6269
6270 IF (ASSOCIATED(this%dativar%c)) THEN
6271 DO i = 1, SIZE(this%dativar%c)
6272 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6273 ENDDO
6274 ENDIF
6275
6276 ENDIF
6277ENDIF
6278
6279IF (PRESENT(nl)) THEN
6280 IF (SIZE(nl) > 0) THEN
6281 DO i = 1, SIZE(this%network)
6282 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
6283 ENDDO
6284 ENDIF
6285ENDIF
6286
6287IF (PRESENT(s_d)) THEN
6289 WHERE (this%time < s_d)
6290 this%time = datetime_miss
6291 END WHERE
6292 ENDIF
6293ENDIF
6294
6295IF (PRESENT(e_d)) THEN
6297 WHERE (this%time > e_d)
6298 this%time = datetime_miss
6299 END WHERE
6300 ENDIF
6301ENDIF
6302
6303CALL vol7d_reform(this, miss=.true.)
6304
6305END SUBROUTINE vol7d_filter
6306
6307
6314SUBROUTINE vol7d_convr(this, that, anaconv)
6315TYPE(vol7d),INTENT(IN) :: this
6316TYPE(vol7d),INTENT(INOUT) :: that
6317LOGICAL,OPTIONAL,INTENT(in) :: anaconv
6318INTEGER :: i
6319LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
6320TYPE(vol7d) :: v7d_tmp
6321
6322IF (optio_log(anaconv)) THEN
6323 acp=fv
6324 acn=tv
6325ELSE
6326 acp=tv
6327 acn=fv
6328ENDIF
6329
6330! Volume con solo i dati reali e tutti gli attributi
6331! l'anagrafica e` copiata interamente se necessario
6332CALL vol7d_copy(this, that, &
6333 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
6334 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
6335
6336! Volume solo di dati double
6337CALL vol7d_copy(this, v7d_tmp, &
6338 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
6339 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6340 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6341 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
6342 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6343 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6344
6345! converto a dati reali
6346IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
6347
6348 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
6349! alloco i dati reali e vi trasferisco i double
6350 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
6351 SIZE(v7d_tmp%volanad, 3)))
6352 DO i = 1, SIZE(v7d_tmp%anavar%d)
6353 v7d_tmp%volanar(:,i,:) = &
6354 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
6355 ENDDO
6356 DEALLOCATE(v7d_tmp%volanad)
6357! trasferisco le variabili
6358 v7d_tmp%anavar%r => v7d_tmp%anavar%d
6359 NULLIFY(v7d_tmp%anavar%d)
6360 ENDIF
6361
6362 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
6363! alloco i dati reali e vi trasferisco i double
6364 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
6365 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
6366 SIZE(v7d_tmp%voldatid, 6)))
6367 DO i = 1, SIZE(v7d_tmp%dativar%d)
6368 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6369 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
6370 ENDDO
6371 DEALLOCATE(v7d_tmp%voldatid)
6372! trasferisco le variabili
6373 v7d_tmp%dativar%r => v7d_tmp%dativar%d
6374 NULLIFY(v7d_tmp%dativar%d)
6375 ENDIF
6376
6377! fondo con il volume definitivo
6378 CALL vol7d_merge(that, v7d_tmp)
6379ELSE
6381ENDIF
6382
6383
6384! Volume solo di dati interi
6385CALL vol7d_copy(this, v7d_tmp, &
6386 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
6387 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6388 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6389 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
6390 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6391 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6392
6393! converto a dati reali
6394IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
6395
6396 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
6397! alloco i dati reali e vi trasferisco gli interi
6398 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
6399 SIZE(v7d_tmp%volanai, 3)))
6400 DO i = 1, SIZE(v7d_tmp%anavar%i)
6401 v7d_tmp%volanar(:,i,:) = &
6402 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
6403 ENDDO
6404 DEALLOCATE(v7d_tmp%volanai)
6405! trasferisco le variabili
6406 v7d_tmp%anavar%r => v7d_tmp%anavar%i
6407 NULLIFY(v7d_tmp%anavar%i)
6408 ENDIF
6409
6410 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
6411! alloco i dati reali e vi trasferisco gli interi
6412 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
6413 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
6414 SIZE(v7d_tmp%voldatii, 6)))
6415 DO i = 1, SIZE(v7d_tmp%dativar%i)
6416 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6417 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
6418 ENDDO
6419 DEALLOCATE(v7d_tmp%voldatii)
6420! trasferisco le variabili
6421 v7d_tmp%dativar%r => v7d_tmp%dativar%i
6422 NULLIFY(v7d_tmp%dativar%i)
6423 ENDIF
6424
6425! fondo con il volume definitivo
6426 CALL vol7d_merge(that, v7d_tmp)
6427ELSE
6429ENDIF
6430
6431
6432! Volume solo di dati byte
6433CALL vol7d_copy(this, v7d_tmp, &
6434 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
6435 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6436 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6437 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
6438 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6439 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6440
6441! converto a dati reali
6442IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
6443
6444 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
6445! alloco i dati reali e vi trasferisco i byte
6446 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
6447 SIZE(v7d_tmp%volanab, 3)))
6448 DO i = 1, SIZE(v7d_tmp%anavar%b)
6449 v7d_tmp%volanar(:,i,:) = &
6450 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
6451 ENDDO
6452 DEALLOCATE(v7d_tmp%volanab)
6453! trasferisco le variabili
6454 v7d_tmp%anavar%r => v7d_tmp%anavar%b
6455 NULLIFY(v7d_tmp%anavar%b)
6456 ENDIF
6457
6458 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
6459! alloco i dati reali e vi trasferisco i byte
6460 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
6461 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
6462 SIZE(v7d_tmp%voldatib, 6)))
6463 DO i = 1, SIZE(v7d_tmp%dativar%b)
6464 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6465 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
6466 ENDDO
6467 DEALLOCATE(v7d_tmp%voldatib)
6468! trasferisco le variabili
6469 v7d_tmp%dativar%r => v7d_tmp%dativar%b
6470 NULLIFY(v7d_tmp%dativar%b)
6471 ENDIF
6472
6473! fondo con il volume definitivo
6474 CALL vol7d_merge(that, v7d_tmp)
6475ELSE
6477ENDIF
6478
6479
6480! Volume solo di dati character
6481CALL vol7d_copy(this, v7d_tmp, &
6482 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
6483 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6484 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6485 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
6486 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6487 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6488
6489! converto a dati reali
6490IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
6491
6492 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
6493! alloco i dati reali e vi trasferisco i character
6494 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
6495 SIZE(v7d_tmp%volanac, 3)))
6496 DO i = 1, SIZE(v7d_tmp%anavar%c)
6497 v7d_tmp%volanar(:,i,:) = &
6498 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
6499 ENDDO
6500 DEALLOCATE(v7d_tmp%volanac)
6501! trasferisco le variabili
6502 v7d_tmp%anavar%r => v7d_tmp%anavar%c
6503 NULLIFY(v7d_tmp%anavar%c)
6504 ENDIF
6505
6506 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
6507! alloco i dati reali e vi trasferisco i character
6508 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
6509 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
6510 SIZE(v7d_tmp%voldatic, 6)))
6511 DO i = 1, SIZE(v7d_tmp%dativar%c)
6512 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6513 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
6514 ENDDO
6515 DEALLOCATE(v7d_tmp%voldatic)
6516! trasferisco le variabili
6517 v7d_tmp%dativar%r => v7d_tmp%dativar%c
6518 NULLIFY(v7d_tmp%dativar%c)
6519 ENDIF
6520
6521! fondo con il volume definitivo
6522 CALL vol7d_merge(that, v7d_tmp)
6523ELSE
6525ENDIF
6526
6527END SUBROUTINE vol7d_convr
6528
6529
6533SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
6534TYPE(vol7d),INTENT(IN) :: this
6535TYPE(vol7d),INTENT(OUT) :: that
6536logical , optional, intent(in) :: data_only
6537logical , optional, intent(in) :: ana
6538logical :: ldata_only,lana
6539
6540IF (PRESENT(data_only)) THEN
6541 ldata_only = data_only
6542ELSE
6543 ldata_only = .false.
6544ENDIF
6545
6546IF (PRESENT(ana)) THEN
6547 lana = ana
6548ELSE
6549 lana = .false.
6550ENDIF
6551
6552
6553#undef VOL7D_POLY_ARRAY
6554#define VOL7D_POLY_ARRAY voldati
6555#include "vol7d_class_diff.F90"
6556#undef VOL7D_POLY_ARRAY
6557#define VOL7D_POLY_ARRAY voldatiattr
6558#include "vol7d_class_diff.F90"
6559#undef VOL7D_POLY_ARRAY
6560
6561if ( .not. ldata_only) then
6562
6563#define VOL7D_POLY_ARRAY volana
6564#include "vol7d_class_diff.F90"
6565#undef VOL7D_POLY_ARRAY
6566#define VOL7D_POLY_ARRAY volanaattr
6567#include "vol7d_class_diff.F90"
6568#undef VOL7D_POLY_ARRAY
6569
6570 if(lana)then
6571 where ( this%ana == that%ana )
6572 that%ana = vol7d_ana_miss
6573 end where
6574 end if
6575
6576end if
6577
6578
6579
6580END SUBROUTINE vol7d_diff_only
6581
6582
6583
6584! Creo le routine da ripetere per i vari tipi di dati di v7d
6585! tramite un template e il preprocessore
6586#undef VOL7D_POLY_TYPE
6587#undef VOL7D_POLY_TYPES
6588#define VOL7D_POLY_TYPE REAL
6589#define VOL7D_POLY_TYPES r
6590#include "vol7d_class_type_templ.F90"
6591#undef VOL7D_POLY_TYPE
6592#undef VOL7D_POLY_TYPES
6593#define VOL7D_POLY_TYPE DOUBLE PRECISION
6594#define VOL7D_POLY_TYPES d
6595#include "vol7d_class_type_templ.F90"
6596#undef VOL7D_POLY_TYPE
6597#undef VOL7D_POLY_TYPES
6598#define VOL7D_POLY_TYPE INTEGER
6599#define VOL7D_POLY_TYPES i
6600#include "vol7d_class_type_templ.F90"
6601#undef VOL7D_POLY_TYPE
6602#undef VOL7D_POLY_TYPES
6603#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
6604#define VOL7D_POLY_TYPES b
6605#include "vol7d_class_type_templ.F90"
6606#undef VOL7D_POLY_TYPE
6607#undef VOL7D_POLY_TYPES
6608#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
6609#define VOL7D_POLY_TYPES c
6610#include "vol7d_class_type_templ.F90"
6611
6612! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
6613! tramite un template e il preprocessore
6614#define VOL7D_SORT
6615#undef VOL7D_NO_ZERO_ALLOC
6616#undef VOL7D_POLY_TYPE
6617#define VOL7D_POLY_TYPE datetime
6618#include "vol7d_class_desc_templ.F90"
6619#undef VOL7D_POLY_TYPE
6620#define VOL7D_POLY_TYPE vol7d_timerange
6621#include "vol7d_class_desc_templ.F90"
6622#undef VOL7D_POLY_TYPE
6623#define VOL7D_POLY_TYPE vol7d_level
6624#include "vol7d_class_desc_templ.F90"
6625#undef VOL7D_SORT
6626#undef VOL7D_POLY_TYPE
6627#define VOL7D_POLY_TYPE vol7d_network
6628#include "vol7d_class_desc_templ.F90"
6629#undef VOL7D_POLY_TYPE
6630#define VOL7D_POLY_TYPE vol7d_ana
6631#include "vol7d_class_desc_templ.F90"
6632#define VOL7D_NO_ZERO_ALLOC
6633#undef VOL7D_POLY_TYPE
6634#define VOL7D_POLY_TYPE vol7d_var
6635#include "vol7d_class_desc_templ.F90"
6636
6646subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6647
6648TYPE(vol7d),INTENT(IN) :: this
6649integer,optional,intent(inout) :: unit
6650character(len=*),intent(in),optional :: filename
6651character(len=*),intent(out),optional :: filename_auto
6652character(len=*),INTENT(IN),optional :: description
6653
6654integer :: lunit
6655character(len=254) :: ldescription,arg,lfilename
6656integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6657 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6658 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6659 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6660 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6661 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6662 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6663!integer :: im,id,iy
6664integer :: tarray(8)
6665logical :: opened,exist
6666
6667 nana=0
6668 ntime=0
6669 ntimerange=0
6670 nlevel=0
6671 nnetwork=0
6672 ndativarr=0
6673 ndativari=0
6674 ndativarb=0
6675 ndativard=0
6676 ndativarc=0
6677 ndatiattrr=0
6678 ndatiattri=0
6679 ndatiattrb=0
6680 ndatiattrd=0
6681 ndatiattrc=0
6682 ndativarattrr=0
6683 ndativarattri=0
6684 ndativarattrb=0
6685 ndativarattrd=0
6686 ndativarattrc=0
6687 nanavarr=0
6688 nanavari=0
6689 nanavarb=0
6690 nanavard=0
6691 nanavarc=0
6692 nanaattrr=0
6693 nanaattri=0
6694 nanaattrb=0
6695 nanaattrd=0
6696 nanaattrc=0
6697 nanavarattrr=0
6698 nanavarattri=0
6699 nanavarattrb=0
6700 nanavarattrd=0
6701 nanavarattrc=0
6702
6703
6704!call idate(im,id,iy)
6705call date_and_time(values=tarray)
6706call getarg(0,arg)
6707
6708if (present(description))then
6709 ldescription=description
6710else
6711 ldescription="Vol7d generated by: "//trim(arg)
6712end if
6713
6714if (.not. present(unit))then
6715 lunit=getunit()
6716else
6717 if (unit==0)then
6718 lunit=getunit()
6719 unit=lunit
6720 else
6721 lunit=unit
6722 end if
6723end if
6724
6725lfilename=trim(arg)//".v7d"
6727
6728if (present(filename))then
6729 if (filename /= "")then
6730 lfilename=filename
6731 end if
6732end if
6733
6734if (present(filename_auto))filename_auto=lfilename
6735
6736
6737inquire(unit=lunit,opened=opened)
6738if (.not. opened) then
6739! inquire(file=lfilename, EXIST=exist)
6740! IF (exist) THEN
6741! CALL l4f_log(L4F_FATAL, &
6742! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6743! CALL raise_fatal_error()
6744! ENDIF
6745 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6746 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6747end if
6748
6749if (associated(this%ana)) nana=size(this%ana)
6750if (associated(this%time)) ntime=size(this%time)
6751if (associated(this%timerange)) ntimerange=size(this%timerange)
6752if (associated(this%level)) nlevel=size(this%level)
6753if (associated(this%network)) nnetwork=size(this%network)
6754
6755if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6756if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6757if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6758if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6759if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6760
6761if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6762if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6763if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6764if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6765if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6766
6767if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6768if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6769if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6770if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6771if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6772
6773if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6774if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6775if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6776if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6777if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6778
6779if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6780if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6781if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6782if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6783if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6784
6785if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6786if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6787if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6788if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6789if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6790
6791write(unit=lunit)ldescription
6792write(unit=lunit)tarray
6793
6794write(unit=lunit)&
6795 nana, ntime, ntimerange, nlevel, nnetwork, &
6796 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6797 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6798 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6799 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6800 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6801 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6802 this%time_definition
6803
6804
6805!write(unit=lunit)this
6806
6807
6808!! prime 5 dimensioni
6811if (associated(this%level)) write(unit=lunit)this%level
6812if (associated(this%timerange)) write(unit=lunit)this%timerange
6813if (associated(this%network)) write(unit=lunit)this%network
6814
6815 !! 6a dimensione: variabile dell'anagrafica e dei dati
6816 !! con relativi attributi e in 5 tipi diversi
6817
6818if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6819if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6820if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6821if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6822if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6823
6824if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6825if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6826if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6827if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6828if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6829
6830if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6831if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6832if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6833if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6834if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6835
6836if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6837if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6838if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6839if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6840if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6841
6842if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6843if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6844if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6845if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6846if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6847
6848if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6849if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6850if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6851if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6852if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6853
6854!! Volumi di valori e attributi per anagrafica e dati
6855
6856if (associated(this%volanar)) write(unit=lunit)this%volanar
6857if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6858if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6859if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6860
6861if (associated(this%volanai)) write(unit=lunit)this%volanai
6862if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6863if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6864if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6865
6866if (associated(this%volanab)) write(unit=lunit)this%volanab
6867if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6868if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6869if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6870
6871if (associated(this%volanad)) write(unit=lunit)this%volanad
6872if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6873if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6874if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6875
6876if (associated(this%volanac)) write(unit=lunit)this%volanac
6877if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6878if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6879if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6880
6881if (.not. present(unit)) close(unit=lunit)
6882
6883end subroutine vol7d_write_on_file
6884
6885
6892
6893
6894subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6895
6896TYPE(vol7d),INTENT(OUT) :: this
6897integer,intent(inout),optional :: unit
6898character(len=*),INTENT(in),optional :: filename
6899character(len=*),intent(out),optional :: filename_auto
6900character(len=*),INTENT(out),optional :: description
6901integer,intent(out),optional :: tarray(8)
6902
6903
6904integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6905 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6906 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6907 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6908 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6909 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6910 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6911
6912character(len=254) :: ldescription,lfilename,arg
6913integer :: ltarray(8),lunit,ios
6914logical :: opened,exist
6915
6916
6917call getarg(0,arg)
6918
6919if (.not. present(unit))then
6920 lunit=getunit()
6921else
6922 if (unit==0)then
6923 lunit=getunit()
6924 unit=lunit
6925 else
6926 lunit=unit
6927 end if
6928end if
6929
6930lfilename=trim(arg)//".v7d"
6932
6933if (present(filename))then
6934 if (filename /= "")then
6935 lfilename=filename
6936 end if
6937end if
6938
6939if (present(filename_auto))filename_auto=lfilename
6940
6941
6942inquire(unit=lunit,opened=opened)
6943IF (.NOT. opened) THEN
6944 inquire(file=lfilename,exist=exist)
6945 IF (.NOT.exist) THEN
6946 CALL l4f_log(l4f_fatal, &
6947 'in vol7d_read_from_file, file does not exists, cannot open')
6948 CALL raise_fatal_error()
6949 ENDIF
6950 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
6951 status='OLD', action='READ')
6952 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6953end if
6954
6955
6957read(unit=lunit,iostat=ios)ldescription
6958
6959if (ios < 0) then ! A negative value indicates that the End of File or End of Record
6960 call vol7d_alloc (this)
6961 call vol7d_alloc_vol (this)
6962 if (present(description))description=ldescription
6963 if (present(tarray))tarray=ltarray
6964 if (.not. present(unit)) close(unit=lunit)
6965end if
6966
6967read(unit=lunit)ltarray
6968
6969CALL l4f_log(l4f_info, 'Reading vol7d from file')
6970CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
6973
6974if (present(description))description=ldescription
6975if (present(tarray))tarray=ltarray
6976
6977read(unit=lunit)&
6978 nana, ntime, ntimerange, nlevel, nnetwork, &
6979 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6980 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6981 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6982 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6983 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6984 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6985 this%time_definition
6986
6987call vol7d_alloc (this, &
6988 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
6989 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
6990 ndativard=ndativard, ndativarc=ndativarc,&
6991 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
6992 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
6993 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
6994 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
6995 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
6996 nanavard=nanavard, nanavarc=nanavarc,&
6997 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
6998 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
6999 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7000 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7001
7002
7005if (associated(this%level)) read(unit=lunit)this%level
7006if (associated(this%timerange)) read(unit=lunit)this%timerange
7007if (associated(this%network)) read(unit=lunit)this%network
7008
7009if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7010if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7011if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7012if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7013if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7014
7015if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7016if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7017if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7018if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7019if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7020
7021if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7022if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7023if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7024if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7025if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7026
7027if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7028if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7029if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7030if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7031if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7032
7033if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7034if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7035if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7036if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7037if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7038
7039if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7040if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7041if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7042if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7043if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7044
7045call vol7d_alloc_vol (this)
7046
7047!! Volumi di valori e attributi per anagrafica e dati
7048
7049if (associated(this%volanar)) read(unit=lunit)this%volanar
7050if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7051if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7052if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7053
7054if (associated(this%volanai)) read(unit=lunit)this%volanai
7055if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7056if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7057if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7058
7059if (associated(this%volanab)) read(unit=lunit)this%volanab
7060if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7061if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7062if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7063
7064if (associated(this%volanad)) read(unit=lunit)this%volanad
7065if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7066if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7067if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7068
7069if (associated(this%volanac)) read(unit=lunit)this%volanac
7070if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7071if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7072if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7073
7074if (.not. present(unit)) close(unit=lunit)
7075
7076end subroutine vol7d_read_from_file
7077
7078
7079! to double precision
7080elemental doubleprecision function doubledatd(voldat,var)
7081doubleprecision,intent(in) :: voldat
7082type(vol7d_var),intent(in) :: var
7083
7084doubledatd=voldat
7085
7086end function doubledatd
7087
7088
7089elemental doubleprecision function doubledatr(voldat,var)
7090real,intent(in) :: voldat
7091type(vol7d_var),intent(in) :: var
7092
7094 doubledatr=dble(voldat)
7095else
7096 doubledatr=dmiss
7097end if
7098
7099end function doubledatr
7100
7101
7102elemental doubleprecision function doubledati(voldat,var)
7103integer,intent(in) :: voldat
7104type(vol7d_var),intent(in) :: var
7105
7108 doubledati=dble(voldat)/10.d0**var%scalefactor
7109 else
7110 doubledati=dble(voldat)
7111 endif
7112else
7113 doubledati=dmiss
7114end if
7115
7116end function doubledati
7117
7118
7119elemental doubleprecision function doubledatb(voldat,var)
7120integer(kind=int_b),intent(in) :: voldat
7121type(vol7d_var),intent(in) :: var
7122
7125 doubledatb=dble(voldat)/10.d0**var%scalefactor
7126 else
7127 doubledatb=dble(voldat)
7128 endif
7129else
7130 doubledatb=dmiss
7131end if
7132
7133end function doubledatb
7134
7135
7136elemental doubleprecision function doubledatc(voldat,var)
7137CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7138type(vol7d_var),intent(in) :: var
7139
7140doubledatc = c2d(voldat)
7142 doubledatc=doubledatc/10.d0**var%scalefactor
7143end if
7144
7145end function doubledatc
7146
7147
7148! to integer
7149elemental integer function integerdatd(voldat,var)
7150doubleprecision,intent(in) :: voldat
7151type(vol7d_var),intent(in) :: var
7152
7155 integerdatd=nint(voldat*10d0**var%scalefactor)
7156 else
7157 integerdatd=nint(voldat)
7158 endif
7159else
7160 integerdatd=imiss
7161end if
7162
7163end function integerdatd
7164
7165
7166elemental integer function integerdatr(voldat,var)
7167real,intent(in) :: voldat
7168type(vol7d_var),intent(in) :: var
7169
7172 integerdatr=nint(voldat*10d0**var%scalefactor)
7173 else
7174 integerdatr=nint(voldat)
7175 endif
7176else
7177 integerdatr=imiss
7178end if
7179
7180end function integerdatr
7181
7182
7183elemental integer function integerdati(voldat,var)
7184integer,intent(in) :: voldat
7185type(vol7d_var),intent(in) :: var
7186
7187integerdati=voldat
7188
7189end function integerdati
7190
7191
7192elemental integer function integerdatb(voldat,var)
7193integer(kind=int_b),intent(in) :: voldat
7194type(vol7d_var),intent(in) :: var
7195
7197 integerdatb=voldat
7198else
7199 integerdatb=imiss
7200end if
7201
7202end function integerdatb
7203
7204
7205elemental integer function integerdatc(voldat,var)
7206CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7207type(vol7d_var),intent(in) :: var
7208
7209integerdatc=c2i(voldat)
7210
7211end function integerdatc
7212
7213
7214! to real
7215elemental real function realdatd(voldat,var)
7216doubleprecision,intent(in) :: voldat
7217type(vol7d_var),intent(in) :: var
7218
7220 realdatd=real(voldat)
7221else
7222 realdatd=rmiss
7223end if
7224
7225end function realdatd
7226
7227
7228elemental real function realdatr(voldat,var)
7229real,intent(in) :: voldat
7230type(vol7d_var),intent(in) :: var
7231
7232realdatr=voldat
7233
7234end function realdatr
7235
7236
7237elemental real function realdati(voldat,var)
7238integer,intent(in) :: voldat
7239type(vol7d_var),intent(in) :: var
7240
7243 realdati=float(voldat)/10.**var%scalefactor
7244 else
7245 realdati=float(voldat)
7246 endif
7247else
7248 realdati=rmiss
7249end if
7250
7251end function realdati
7252
7253
7254elemental real function realdatb(voldat,var)
7255integer(kind=int_b),intent(in) :: voldat
7256type(vol7d_var),intent(in) :: var
7257
7260 realdatb=float(voldat)/10**var%scalefactor
7261 else
7262 realdatb=float(voldat)
7263 endif
7264else
7265 realdatb=rmiss
7266end if
7267
7268end function realdatb
7269
7270
7271elemental real function realdatc(voldat,var)
7272CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7273type(vol7d_var),intent(in) :: var
7274
7275realdatc=c2r(voldat)
7277 realdatc=realdatc/10.**var%scalefactor
7278end if
7279
7280end function realdatc
7281
7282
7288FUNCTION realanavol(this, var) RESULT(vol)
7289TYPE(vol7d),INTENT(in) :: this
7290TYPE(vol7d_var),INTENT(in) :: var
7291REAL :: vol(SIZE(this%ana),size(this%network))
7292
7293CHARACTER(len=1) :: dtype
7294INTEGER :: indvar
7295
7296dtype = cmiss
7297indvar = index(this%anavar, var, type=dtype)
7298
7299IF (indvar > 0) THEN
7300 SELECT CASE (dtype)
7301 CASE("d")
7302 vol = realdat(this%volanad(:,indvar,:), var)
7303 CASE("r")
7304 vol = this%volanar(:,indvar,:)
7305 CASE("i")
7306 vol = realdat(this%volanai(:,indvar,:), var)
7307 CASE("b")
7308 vol = realdat(this%volanab(:,indvar,:), var)
7309 CASE("c")
7310 vol = realdat(this%volanac(:,indvar,:), var)
7311 CASE default
7312 vol = rmiss
7313 END SELECT
7314ELSE
7315 vol = rmiss
7316ENDIF
7317
7318END FUNCTION realanavol
7319
7320
7326FUNCTION integeranavol(this, var) RESULT(vol)
7327TYPE(vol7d),INTENT(in) :: this
7328TYPE(vol7d_var),INTENT(in) :: var
7329INTEGER :: vol(SIZE(this%ana),size(this%network))
7330
7331CHARACTER(len=1) :: dtype
7332INTEGER :: indvar
7333
7334dtype = cmiss
7335indvar = index(this%anavar, var, type=dtype)
7336
7337IF (indvar > 0) THEN
7338 SELECT CASE (dtype)
7339 CASE("d")
7340 vol = integerdat(this%volanad(:,indvar,:), var)
7341 CASE("r")
7342 vol = integerdat(this%volanar(:,indvar,:), var)
7343 CASE("i")
7344 vol = this%volanai(:,indvar,:)
7345 CASE("b")
7346 vol = integerdat(this%volanab(:,indvar,:), var)
7347 CASE("c")
7348 vol = integerdat(this%volanac(:,indvar,:), var)
7349 CASE default
7350 vol = imiss
7351 END SELECT
7352ELSE
7353 vol = imiss
7354ENDIF
7355
7356END FUNCTION integeranavol
7357
7358
7364subroutine move_datac (v7d,&
7365 indana,indtime,indlevel,indtimerange,indnetwork,&
7366 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7367
7368TYPE(vol7d),intent(inout) :: v7d
7369
7370integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
7371integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
7372integer :: inddativar,inddativarattr
7373
7374
7375do inddativar=1,size(v7d%dativar%c)
7376
7378 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7379 ) then
7380
7381 ! dati
7382 v7d%voldatic &
7383 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7384 v7d%voldatic &
7385 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7386
7387
7388 ! attributi
7389 if (associated (v7d%dativarattr%i)) then
7390 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
7391 if (inddativarattr > 0 ) then
7392 v7d%voldatiattri &
7393 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7394 v7d%voldatiattri &
7395 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7396 end if
7397 end if
7398
7399 if (associated (v7d%dativarattr%r)) then
7400 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
7401 if (inddativarattr > 0 ) then
7402 v7d%voldatiattrr &
7403 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7404 v7d%voldatiattrr &
7405 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7406 end if
7407 end if
7408
7409 if (associated (v7d%dativarattr%d)) then
7410 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
7411 if (inddativarattr > 0 ) then
7412 v7d%voldatiattrd &
7413 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7414 v7d%voldatiattrd &
7415 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7416 end if
7417 end if
7418
7419 if (associated (v7d%dativarattr%b)) then
7420 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
7421 if (inddativarattr > 0 ) then
7422 v7d%voldatiattrb &
7423 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7424 v7d%voldatiattrb &
7425 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7426 end if
7427 end if
7428
7429 if (associated (v7d%dativarattr%c)) then
7430 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
7431 if (inddativarattr > 0 ) then
7432 v7d%voldatiattrc &
7433 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7434 v7d%voldatiattrc &
7435 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7436 end if
7437 end if
7438
7439 end if
7440
7441end do
7442
7443end subroutine move_datac
7444
7450subroutine move_datar (v7d,&
7451 indana,indtime,indlevel,indtimerange,indnetwork,&
7452 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7453
7454TYPE(vol7d),intent(inout) :: v7d
7455
7456integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
7457integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
7458integer :: inddativar,inddativarattr
7459
7460
7461do inddativar=1,size(v7d%dativar%r)
7462
7464 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7465 ) then
7466
7467 ! dati
7468 v7d%voldatir &
7469 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7470 v7d%voldatir &
7471 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7472
7473
7474 ! attributi
7475 if (associated (v7d%dativarattr%i)) then
7476 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
7477 if (inddativarattr > 0 ) then
7478 v7d%voldatiattri &
7479 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7480 v7d%voldatiattri &
7481 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7482 end if
7483 end if
7484
7485 if (associated (v7d%dativarattr%r)) then
7486 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
7487 if (inddativarattr > 0 ) then
7488 v7d%voldatiattrr &
7489 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7490 v7d%voldatiattrr &
7491 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7492 end if
7493 end if
7494
7495 if (associated (v7d%dativarattr%d)) then
7496 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
7497 if (inddativarattr > 0 ) then
7498 v7d%voldatiattrd &
7499 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7500 v7d%voldatiattrd &
7501 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7502 end if
7503 end if
7504
7505 if (associated (v7d%dativarattr%b)) then
7506 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
7507 if (inddativarattr > 0 ) then
7508 v7d%voldatiattrb &
7509 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7510 v7d%voldatiattrb &
7511 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7512 end if
7513 end if
7514
7515 if (associated (v7d%dativarattr%c)) then
7516 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
7517 if (inddativarattr > 0 ) then
7518 v7d%voldatiattrc &
7519 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7520 v7d%voldatiattrc &
7521 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7522 end if
7523 end if
7524
7525 end if
7526
7527end do
7528
7529end subroutine move_datar
7530
7531
7545subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
7546type(vol7d),intent(inout) :: v7din
7547type(vol7d),intent(out) :: v7dout
7548type(vol7d_level),intent(in),optional :: level(:)
7549type(vol7d_timerange),intent(in),optional :: timerange(:)
7550!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
7551!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
7552logical,intent(in),optional :: nostatproc
7553
7554integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
7555integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
7556type(vol7d_level) :: roundlevel(size(v7din%level))
7557type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
7558type(vol7d) :: v7d_tmp
7559
7560
7561nbin=0
7562
7563if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
7564if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
7565if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
7566if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
7567
7569
7570roundlevel=v7din%level
7571
7572if (present(level))then
7573 do ilevel = 1, size(v7din%level)
7574 if ((any(v7din%level(ilevel) .almosteq. level))) then
7575 roundlevel(ilevel)=level(1)
7576 end if
7577 end do
7578end if
7579
7580roundtimerange=v7din%timerange
7581
7582if (present(timerange))then
7583 do itimerange = 1, size(v7din%timerange)
7584 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
7585 roundtimerange(itimerange)=timerange(1)
7586 end if
7587 end do
7588end if
7589
7590!set istantaneous values everywere
7591!preserve p1 for forecast time
7592if (optio_log(nostatproc)) then
7593 roundtimerange(:)%timerange=254
7594 roundtimerange(:)%p2=0
7595end if
7596
7597
7598nana=size(v7din%ana)
7599nlevel=count_distinct(roundlevel,back=.true.)
7600ntime=size(v7din%time)
7601ntimerange=count_distinct(roundtimerange,back=.true.)
7602nnetwork=size(v7din%network)
7603
7605
7606if (nbin == 0) then
7608else
7609 call vol7d_convr(v7din,v7d_tmp)
7610end if
7611
7612v7d_tmp%level=roundlevel
7613v7d_tmp%timerange=roundtimerange
7614
7615do ilevel=1, size(v7d_tmp%level)
7616 indl=index(v7d_tmp%level,roundlevel(ilevel))
7617 do itimerange=1,size(v7d_tmp%timerange)
7618 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
7619
7620 if (indl /= ilevel .or. indt /= itimerange) then
7621
7622 do iana=1, nana
7623 do itime=1,ntime
7624 do inetwork=1,nnetwork
7625
7626 if (nbin > 0) then
7627 call move_datar (v7d_tmp,&
7628 iana,itime,ilevel,itimerange,inetwork,&
7629 iana,itime,indl,indt,inetwork)
7630 else
7631 call move_datac (v7d_tmp,&
7632 iana,itime,ilevel,itimerange,inetwork,&
7633 iana,itime,indl,indt,inetwork)
7634 end if
7635
7636 end do
7637 end do
7638 end do
7639
7640 end if
7641
7642 end do
7643end do
7644
7645! set to missing level and time > nlevel
7646do ilevel=nlevel+1,size(v7d_tmp%level)
7648end do
7649
7650do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7652end do
7653
7654!copy with remove
7657
7658!call display(v7dout)
7659
7660end subroutine v7d_rounding
7661
7662
7664
7670
7671
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 |