libsim Versione 7.2.4

◆ vol7d_get_volanad()

subroutine vol7d_get_volanad ( type(vol7d), intent(in) this,
integer, dimension(:), intent(in) dimlist,
double precision, dimension(:), optional, pointer vol1dp,
double precision, dimension(:,:), optional, pointer vol2dp,
double precision, dimension(:,:,:), optional, pointer vol3dp )

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
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d

Definizione alla linea 4216 del file vol7d_class.F90.

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

Generated with Doxygen.