libsim Versione 7.2.6

◆ vol7d_get_voldatid()

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

Crea una vista a dimensione ridotta di un volume di dati di tipo DOUBLE PRECISION.

È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio:

DOUBLE PRECISION, POINTER :: vol2d(:,:)
...
CALL vol7d_get_voldatid(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
ENDIF
return
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_d ... vol7d_attr_d, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d
vol5dparray che in uscita conterrà la vista 5d
vol6dparray che in uscita conterrà la vista 6d

Definizione alla linea 4321 del file vol7d_class.F90.

4323! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
4324! authors:
4325! Davide Cesari <dcesari@arpa.emr.it>
4326! Paolo Patruno <ppatruno@arpa.emr.it>
4327
4328! This program is free software; you can redistribute it and/or
4329! modify it under the terms of the GNU General Public License as
4330! published by the Free Software Foundation; either version 2 of
4331! the License, or (at your option) any later version.
4332
4333! This program is distributed in the hope that it will be useful,
4334! but WITHOUT ANY WARRANTY; without even the implied warranty of
4335! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4336! GNU General Public License for more details.
4337
4338! You should have received a copy of the GNU General Public License
4339! along with this program. If not, see <http://www.gnu.org/licenses/>.
4340#include "config.h"
4341
4342!> \defgroup vol7d Libsim package, vol7d library.
4343!! The libsim vol7d library contains classes for managing pointwise
4344!! data, tipically weather observations, and for their import from a
4345!! Db-All.e database or from a WMO BUFR file. In order to compile and
4346!! link programs using this library, you have to insert the required
4347!! \c USE statements in the program units involved, specify the
4348!! location of module files when compiling (tipically \c
4349!! -I/usr/lib/gfortran/modules or \c -I/usr/lib64/gfortran/modules or
4350!! \c -I/usr/include) and indicate the library name \c -lsim_vol7d
4351!! when linking, assuming that the library has been installed in a
4352!! default location.
4353
4354!> Classe per la gestione di un volume completo di dati osservati.
4355!! Questo modulo definisce gli oggetti e i metodi per gestire
4356!! volumi di dati meteorologici sparsi.
4357!! I volumi definiti sono principalmente di 4 categorie:
4358!! - volumi di anagrafica (vol7d::volanar & c.), hanno 3 dimensioni:
4359!! - anagrafica
4360!! - variabile di anagrafica
4361!! - rete
4362!! - volumi di attributi di anagrafica (vol7d::volanaattrr & c.), hanno 4 dimensioni:
4363!! - anagrafica
4364!! - variabile di anagrafica
4365!! - rete
4366!! - variabile di attributi delle variabili di anagrafica
4367!! - volumi di dati (vol7d::voldatir & c.), hanno 6 dimensioni:
4368!! - anagrafica
4369!! - tempo
4370!! - livello verticale
4371!! - intervallo temporale (timerange)
4372!! - variabile di dati
4373!! - rete
4374!! - volumi di attributi di dati (vol7d::voldatiattrr & c.), hanno 7 dimensioni:
4375!! - anagrafica
4376!! - tempo
4377!! - livello verticale
4378!! - intervallo temporale (timerange)
4379!! - variabile di dati
4380!! - rete
4381!! - variabile di attributi delle variabili di dati
4382!!
4383!! Tutte le variabili sono inoltre disponibil1 in 5 tipi diversi:
4384!! - reale (abbreviato r)
4385!! - doppia precisione (abbreviato d)
4386!! - intero (abbreviato i)
4387!! - byte (abbreviato b)
4388!! - carattere (abbreviato c)
4389!!
4390!! Per ognuna delle dimensioni possibili, incluse le variabili e gli
4391!! attributi con i loro diversi tipi,
4392!! è definito un cosiddetto "vettore di descrittori", con un
4393!! numero di elementi pari all'estensione della dimensione stessa,
4394!! che contiene le informazioni necessarie a descrivere
4395!! gli elementi di quella dimensione.
4396!! In realtà l'utente non dovrà generalmente occuparsi di costruire
4397!! un oggetto vol7d con le proprie mani ma utilizzerà nella maggior parte
4398!! dei casi i metodi di importazione preconfezionati che importano dati da
4399!! DB-All.e (vol7d_dballe_class) o dal DB Oracle del SIM (vol7d_oraclesim_class).
4400!!
4401!!
4402!! Il programma esempio_v7d.f90 contiene un esempio elementare di uso
4403!! della classe vol7d:
4404!! \include esempio_v7d.f90
4405!!
4406!! \ingroup vol7d
4407MODULE vol7d_class
4408USE kinds
4412USE log4fortran
4413USE err_handling
4414USE io_units
4421IMPLICIT NONE
4422
4423
4424INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
4425 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
4426
4427INTEGER, PARAMETER :: vol7d_ana_a=1 !< indice della dimensione "anagrafica" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
4428INTEGER, PARAMETER :: vol7d_var_a=2 !< indice della dimensione "variabile" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
4429INTEGER, PARAMETER :: vol7d_network_a=3 !< indice della dimensione "rete" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
4430INTEGER, PARAMETER :: vol7d_attr_a=4 !< indice della dimensione "attributo" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
4431INTEGER, PARAMETER :: vol7d_ana_d=1 !< indice della dimensione "anagrafica" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4432INTEGER, PARAMETER :: vol7d_time_d=2 !< indice della dimensione "tempo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4433INTEGER, PARAMETER :: vol7d_level_d=3 !< indice della dimensione "livello verticale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4434INTEGER, PARAMETER :: vol7d_timerange_d=4 !< indice della dimensione "intervallo temporale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4435INTEGER, PARAMETER :: vol7d_var_d=5 !< indice della dimensione "variabile" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4436INTEGER, PARAMETER :: vol7d_network_d=6 !< indice della dimensione "rete" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4437INTEGER, PARAMETER :: vol7d_attr_d=7 !< indice della dimensione "attributo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
4438INTEGER, PARAMETER :: vol7d_cdatalen=32
4439
4440TYPE vol7d_varmap
4441 INTEGER :: r, d, i, b, c
4442END TYPE vol7d_varmap
4443
4444!> Definisce un oggetto contenente i volumi anagrafica e dati e tutti
4445!! i descrittori delle loro dimensioni.
4446TYPE vol7d
4447!> vettore descrittore della dimensione anagrafica
4448 TYPE(vol7d_ana),POINTER :: ana(:)
4449!> vettore descrittore della dimensione tempo
4450 TYPE(datetime),POINTER :: time(:)
4451!> vettore descrittore della dimensione livello verticale
4452 TYPE(vol7d_level),POINTER :: level(:)
4453!> vettore descrittore della dimensione intervallo temporale (timerange)
4454 TYPE(vol7d_timerange),POINTER :: timerange(:)
4455!> vettore descrittore della dimensione rete
4456 TYPE(vol7d_network),POINTER :: network(:)
4457!> vettore descrittore della dimensione variabile di anagrafica
4458 TYPE(vol7d_varvect) :: anavar
4459!> vettore descrittore della dimensione attributo delle variabili di anagrafica
4460 TYPE(vol7d_varvect) :: anaattr
4461!> vettore descrittore della dimensione variabile di anagrafica che ha tali attributi
4462 TYPE(vol7d_varvect) :: anavarattr
4463!> vettore descrittore della dimensione variabile di dati
4464 TYPE(vol7d_varvect) :: dativar
4465!> vettore descrittore della dimensione attributo delle variabili di dati
4466 TYPE(vol7d_varvect) :: datiattr
4467!> vettore descrittore della dimensione variabile di dati che ha tali attributi
4468 TYPE(vol7d_varvect) :: dativarattr
4469
4470!> volume di anagrafica a valori reali
4471 REAL,POINTER :: volanar(:,:,:)
4472!> volume di anagrafica a valori a doppia precisione
4473 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
4474!> volume di anagrafica a valori interi
4475 INTEGER,POINTER :: volanai(:,:,:)
4476!> volume di anagrafica a valori byte
4477 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
4478!> volume di anagrafica a valori carattere
4479 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
4480
4481!> volume di attributi di anagrafica a valori reali
4482 REAL,POINTER :: volanaattrr(:,:,:,:)
4483!> volume di attributi di anagrafica a valori a doppia precisione
4484 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
4485!> volume di attributi di anagrafica a valori interi
4486 INTEGER,POINTER :: volanaattri(:,:,:,:)
4487!> volume di attributi di anagrafica a valori byte
4488 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
4489!> volume di attributi di anagrafica a valori carattere
4490 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
4491
4492!> volume di dati a valori reali
4493 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
4494!> volume di dati a valori a doppia precisione
4495 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
4496!> volume di dati a valori interi
4497 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
4498!> volume di dati a valori byte
4499 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
4500!> volume di dati a valori carattere
4501 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
4502
4503!> volume di attributi di dati a valori reali
4504 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
4505!> volume di attributi di dati a valori a doppia precisione
4506 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
4507!> volume di attributi di dati a valori interi
4508 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
4509!> volume di attributi di dati a valori byte
4510 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
4511!> volume di attributi di dati a valori carattere
4512 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
4513
4514!> time definition; 0=time is reference time, 1=time is validity time
4515 integer :: time_definition
4516
4517END TYPE vol7d
4518
4519!> Costruttore per la classe vol7d.
4520!! Deve essere richiamato
4521!! per tutti gli oggetti di questo tipo definiti in un programma.
4522INTERFACE init
4523 MODULE PROCEDURE vol7d_init
4524END INTERFACE
4525
4526!> Distruttore per la classe vol7d.
4527INTERFACE delete
4528 MODULE PROCEDURE vol7d_delete
4529END INTERFACE
4530
4531!> Scrittura su file.
4532INTERFACE export
4533 MODULE PROCEDURE vol7d_write_on_file
4534END INTERFACE
4535
4536!> Lettura da file.
4537INTERFACE import
4538 MODULE PROCEDURE vol7d_read_from_file
4539END INTERFACE
4540
4541!>Print object
4542INTERFACE display
4543 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
4544END INTERFACE
4545
4546!>Represent data in a pretty string
4547INTERFACE to_char
4548 MODULE PROCEDURE to_char_dat
4549END INTERFACE
4550
4551!>doubleprecision data conversion
4552INTERFACE doubledat
4553 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4554END INTERFACE
4555
4556!>real data conversion
4557INTERFACE realdat
4558 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
4559END INTERFACE
4560
4561!>integer data conversion
4562INTERFACE integerdat
4563 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
4564END INTERFACE
4565
4566!>copy object
4567INTERFACE copy
4568 MODULE PROCEDURE vol7d_copy
4569END INTERFACE
4570
4571!> Test for a missing volume
4572INTERFACE c_e
4573 MODULE PROCEDURE vol7d_c_e
4574END INTERFACE
4575
4576!> Check for problems
4577!! return 0 if all check passed
4578!! print diagnostics with log4f
4579INTERFACE check
4580 MODULE PROCEDURE vol7d_check
4581END INTERFACE
4582
4583!> Reduce some dimensions (level and timerage) for semplification (rounding).
4584!! You can use this for simplify and use variables in computation like alchimia
4585!! where fields have to be on the same coordinate
4586!! It return real or character data only: if input is charcter data only it return character otherwise il return
4587!! all the data converted to real.
4588!! examples:
4589!! means in time for short periods and istantaneous values
4590!! 2 meter and surface levels
4591!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
4592!! will be taken (order is by icreasing var index).
4593!! You can use predefined values for classic semplification
4594!! almost_equal_levels and almost_equal_timeranges
4595!! The level or timerange in output will be defined by the first element of level and timerange list
4596INTERFACE rounding
4597 MODULE PROCEDURE v7d_rounding
4598END INTERFACE
4599
4600!!$INTERFACE get_volana
4601!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
4602!!$ vol7d_get_volanab, vol7d_get_volanac
4603!!$END INTERFACE
4604!!$
4605!!$INTERFACE get_voldati
4606!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
4607!!$ vol7d_get_voldatib, vol7d_get_voldatic
4608!!$END INTERFACE
4609!!$
4610!!$INTERFACE get_volanaattr
4611!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
4612!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
4613!!$END INTERFACE
4614!!$
4615!!$INTERFACE get_voldatiattr
4616!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
4617!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
4618!!$END INTERFACE
4619
4620PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
4621 vol7d_get_volc, &
4622 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
4623 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
4624 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
4625 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
4626 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
4627 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
4628 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
4629 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
4630 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
4631 vol7d_display, dat_display, dat_vect_display, &
4632 to_char_dat, vol7d_check
4633
4634PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
4635
4636PRIVATE vol7d_c_e
4637
4638CONTAINS
4639
4640
4641!> Inizializza un oggetto di tipo vol7d.
4642!! Non riceve alcun parametro tranne l'oggetto stesso. Attenzione, è necessario
4643!! comunque chiamare sempre il costruttore per evitare di avere dei puntatori in
4644!! uno stato indefinito.
4645SUBROUTINE vol7d_init(this,time_definition)
4646TYPE(vol7d),intent(out) :: this !< oggetto da inizializzare
4647integer,INTENT(IN),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1)
4648
4649CALL init(this%anavar)
4650CALL init(this%anaattr)
4651CALL init(this%anavarattr)
4652CALL init(this%dativar)
4653CALL init(this%datiattr)
4654CALL init(this%dativarattr)
4655CALL vol7d_var_features_init() ! initialise var features table once
4656
4657NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
4658
4659NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
4660NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
4661NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
4662NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
4663NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
4664
4665if(present(time_definition)) then
4666 this%time_definition=time_definition
4667else
4668 this%time_definition=1 !default to validity time
4669end if
4670
4671END SUBROUTINE vol7d_init
4672
4673
4674!> Distrugge l'oggetto in maniera pulita, liberando l'eventuale memoria
4675!! dinamicamente allocata. Permette di distruggere la sola parte di dati
4676!! mantenendo l'anagrafica.
4677ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
4678TYPE(vol7d),intent(inout) :: this !< oggetto da distruggere
4679LOGICAL, INTENT(in), OPTIONAL :: dataonly !< dealloca solo i dati, tenendo l'anagrafica, (default \c .FALSE.)
4680
4681
4682IF (.NOT. optio_log(dataonly)) THEN
4683 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
4684 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
4685 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
4686 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
4687 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
4688 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
4689 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
4690 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
4691 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
4692 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
4693ENDIF
4694IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
4695IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
4696IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
4697IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
4698IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
4699IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
4700IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
4701IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
4702IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
4703IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
4704
4705IF (.NOT. optio_log(dataonly)) THEN
4706 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
4707 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
4708ENDIF
4709IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
4710IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
4711IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
4712
4713IF (.NOT. optio_log(dataonly)) THEN
4714 CALL delete(this%anavar)
4715 CALL delete(this%anaattr)
4716 CALL delete(this%anavarattr)
4717ENDIF
4718CALL delete(this%dativar)
4719CALL delete(this%datiattr)
4720CALL delete(this%dativarattr)
4721
4722END SUBROUTINE vol7d_delete
4723
4724
4725
4726integer function vol7d_check(this)
4727TYPE(vol7d),intent(in) :: this !< object to check
4728integer :: i,j,k,l,m,n
4729
4730vol7d_check=0
4731
4732if (associated(this%voldatii)) then
4733do i = 1,size(this%voldatii,1)
4734 do j = 1,size(this%voldatii,2)
4735 do k = 1,size(this%voldatii,3)
4736 do l = 1,size(this%voldatii,4)
4737 do m = 1,size(this%voldatii,5)
4738 do n = 1,size(this%voldatii,6)
4739 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
4740 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
4741 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4742 vol7d_check=1
4743 end if
4744 end do
4745 end do
4746 end do
4747 end do
4748 end do
4749end do
4750end if
4751
4752
4753if (associated(this%voldatir)) then
4754do i = 1,size(this%voldatir,1)
4755 do j = 1,size(this%voldatir,2)
4756 do k = 1,size(this%voldatir,3)
4757 do l = 1,size(this%voldatir,4)
4758 do m = 1,size(this%voldatir,5)
4759 do n = 1,size(this%voldatir,6)
4760 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
4761 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
4762 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4763 vol7d_check=2
4764 end if
4765 end do
4766 end do
4767 end do
4768 end do
4769 end do
4770end do
4771end if
4772
4773if (associated(this%voldatid)) then
4774do i = 1,size(this%voldatid,1)
4775 do j = 1,size(this%voldatid,2)
4776 do k = 1,size(this%voldatid,3)
4777 do l = 1,size(this%voldatid,4)
4778 do m = 1,size(this%voldatid,5)
4779 do n = 1,size(this%voldatid,6)
4780 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
4781 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
4782 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4783 vol7d_check=3
4784 end if
4785 end do
4786 end do
4787 end do
4788 end do
4789 end do
4790end do
4791end if
4792
4793if (associated(this%voldatib)) then
4794do i = 1,size(this%voldatib,1)
4795 do j = 1,size(this%voldatib,2)
4796 do k = 1,size(this%voldatib,3)
4797 do l = 1,size(this%voldatib,4)
4798 do m = 1,size(this%voldatib,5)
4799 do n = 1,size(this%voldatib,6)
4800 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
4801 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
4802 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
4803 vol7d_check=4
4804 end if
4805 end do
4806 end do
4807 end do
4808 end do
4809 end do
4810end do
4811end if
4812
4813end function vol7d_check
4814
4815
4816
4817!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
4818!> stampa a video una sintesi del contenuto
4819SUBROUTINE vol7d_display(this)
4820TYPE(vol7d),intent(in) :: this !< oggetto da visualizzare
4821integer :: i
4822
4823REAL :: rdat
4824DOUBLE PRECISION :: ddat
4825INTEGER :: idat
4826INTEGER(kind=int_b) :: bdat
4827CHARACTER(len=vol7d_cdatalen) :: cdat
4828
4829
4830print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
4831if (this%time_definition == 0) then
4832 print*,"TIME DEFINITION: time is reference time"
4833else if (this%time_definition == 1) then
4834 print*,"TIME DEFINITION: time is validity time"
4835else
4836 print*,"Time definition have a wrong walue:", this%time_definition
4837end if
4838
4839IF (ASSOCIATED(this%network))then
4840 print*,"---- network vector ----"
4841 print*,"elements=",size(this%network)
4842 do i=1, size(this%network)
4843 call display(this%network(i))
4844 end do
4845end IF
4846
4847IF (ASSOCIATED(this%ana))then
4848 print*,"---- ana vector ----"
4849 print*,"elements=",size(this%ana)
4850 do i=1, size(this%ana)
4851 call display(this%ana(i))
4852 end do
4853end IF
4854
4855IF (ASSOCIATED(this%time))then
4856 print*,"---- time vector ----"
4857 print*,"elements=",size(this%time)
4858 do i=1, size(this%time)
4859 call display(this%time(i))
4860 end do
4861end if
4862
4863IF (ASSOCIATED(this%level)) then
4864 print*,"---- level vector ----"
4865 print*,"elements=",size(this%level)
4866 do i =1,size(this%level)
4867 call display(this%level(i))
4868 end do
4869end if
4870
4871IF (ASSOCIATED(this%timerange))then
4872 print*,"---- timerange vector ----"
4873 print*,"elements=",size(this%timerange)
4874 do i =1,size(this%timerange)
4875 call display(this%timerange(i))
4876 end do
4877end if
4878
4879
4880print*,"---- ana vector ----"
4881print*,""
4882print*,"->>>>>>>>> anavar -"
4883call display(this%anavar)
4884print*,""
4885print*,"->>>>>>>>> anaattr -"
4886call display(this%anaattr)
4887print*,""
4888print*,"->>>>>>>>> anavarattr -"
4889call display(this%anavarattr)
4890
4891print*,"-- ana data section (first point) --"
4892
4893idat=imiss
4894rdat=rmiss
4895ddat=dmiss
4896bdat=ibmiss
4897cdat=cmiss
4898
4899!ntime = MIN(SIZE(this%time),nprint)
4900!ntimerange = MIN(SIZE(this%timerange),nprint)
4901!nlevel = MIN(SIZE(this%level),nprint)
4902!nnetwork = MIN(SIZE(this%network),nprint)
4903!nana = MIN(SIZE(this%ana),nprint)
4904
4905IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
4906if (associated(this%volanai)) then
4907 do i=1,size(this%anavar%i)
4908 idat=this%volanai(1,i,1)
4909 if (associated(this%anavar%i)) call display(this%anavar%i(i),idat,rdat,ddat,bdat,cdat)
4910 end do
4911end if
4912idat=imiss
4913
4914if (associated(this%volanar)) then
4915 do i=1,size(this%anavar%r)
4916 rdat=this%volanar(1,i,1)
4917 if (associated(this%anavar%r)) call display(this%anavar%r(i),idat,rdat,ddat,bdat,cdat)
4918 end do
4919end if
4920rdat=rmiss
4921
4922if (associated(this%volanad)) then
4923 do i=1,size(this%anavar%d)
4924 ddat=this%volanad(1,i,1)
4925 if (associated(this%anavar%d)) call display(this%anavar%d(i),idat,rdat,ddat,bdat,cdat)
4926 end do
4927end if
4928ddat=dmiss
4929
4930if (associated(this%volanab)) then
4931 do i=1,size(this%anavar%b)
4932 bdat=this%volanab(1,i,1)
4933 if (associated(this%anavar%b)) call display(this%anavar%b(i),idat,rdat,ddat,bdat,cdat)
4934 end do
4935end if
4936bdat=ibmiss
4937
4938if (associated(this%volanac)) then
4939 do i=1,size(this%anavar%c)
4940 cdat=this%volanac(1,i,1)
4941 if (associated(this%anavar%c)) call display(this%anavar%c(i),idat,rdat,ddat,bdat,cdat)
4942 end do
4943end if
4944cdat=cmiss
4945ENDIF
4946
4947print*,"---- data vector ----"
4948print*,""
4949print*,"->>>>>>>>> dativar -"
4950call display(this%dativar)
4951print*,""
4952print*,"->>>>>>>>> datiattr -"
4953call display(this%datiattr)
4954print*,""
4955print*,"->>>>>>>>> dativarattr -"
4956call display(this%dativarattr)
4957
4958print*,"-- data data section (first point) --"
4959
4960idat=imiss
4961rdat=rmiss
4962ddat=dmiss
4963bdat=ibmiss
4964cdat=cmiss
4965
4966IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
4967 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
4968if (associated(this%voldatii)) then
4969 do i=1,size(this%dativar%i)
4970 idat=this%voldatii(1,1,1,1,i,1)
4971 if (associated(this%dativar%i)) call display(this%dativar%i(i),idat,rdat,ddat,bdat,cdat)
4972 end do
4973end if
4974idat=imiss
4975
4976if (associated(this%voldatir)) then
4977 do i=1,size(this%dativar%r)
4978 rdat=this%voldatir(1,1,1,1,i,1)
4979 if (associated(this%dativar%r)) call display(this%dativar%r(i),idat,rdat,ddat,bdat,cdat)
4980 end do
4981end if
4982rdat=rmiss
4983
4984if (associated(this%voldatid)) then
4985 do i=1,size(this%dativar%d)
4986 ddat=this%voldatid(1,1,1,1,i,1)
4987 if (associated(this%dativar%d)) call display(this%dativar%d(i),idat,rdat,ddat,bdat,cdat)
4988 end do
4989end if
4990ddat=dmiss
4991
4992if (associated(this%voldatib)) then
4993 do i=1,size(this%dativar%b)
4994 bdat=this%voldatib(1,1,1,1,i,1)
4995 if (associated(this%dativar%b)) call display(this%dativar%b(i),idat,rdat,ddat,bdat,cdat)
4996 end do
4997end if
4998bdat=ibmiss
4999
5000if (associated(this%voldatic)) then
5001 do i=1,size(this%dativar%c)
5002 cdat=this%voldatic(1,1,1,1,i,1)
5003 if (associated(this%dativar%c)) call display(this%dativar%c(i),idat,rdat,ddat,bdat,cdat)
5004 end do
5005end if
5006cdat=cmiss
5007ENDIF
5008
5009print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
5010
5011END SUBROUTINE vol7d_display
5012
5013
5014!> stampa a video una sintesi del contenuto
5015SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
5016TYPE(vol7d_var),intent(in) :: this !< oggetto da visualizzare
5017!> real
5018REAL :: rdat
5019!> double precision
5020DOUBLE PRECISION :: ddat
5021!> integer
5022INTEGER :: idat
5023!> byte
5024INTEGER(kind=int_b) :: bdat
5025!> character
5026CHARACTER(len=*) :: cdat
5027
5028print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5029
5030end SUBROUTINE dat_display
5031
5032!> stampa a video una sintesi del contenuto
5033SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
5034
5035TYPE(vol7d_var),intent(in) :: this(:) !< oggetto da visualizzare
5036!> real
5037REAL :: rdat(:)
5038!> double precision
5039DOUBLE PRECISION :: ddat(:)
5040!> integer
5041INTEGER :: idat(:)
5042!> byte
5043INTEGER(kind=int_b) :: bdat(:)
5044!> character
5045CHARACTER(len=*):: cdat(:)
5046
5047integer :: i
5048
5049do i =1,size(this)
5050 call display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
5051end do
5052
5053end SUBROUTINE dat_vect_display
5054
5055
5056FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5057#ifdef HAVE_DBALLE
5058USE dballef
5059#endif
5060TYPE(vol7d_var),INTENT(in) :: this
5061!> real
5062REAL :: rdat
5063!> double precision
5064DOUBLE PRECISION :: ddat
5065!> integer
5066INTEGER :: idat
5067!> byte
5068INTEGER(kind=int_b) :: bdat
5069!> character
5070CHARACTER(len=*) :: cdat
5071CHARACTER(len=80) :: to_char_dat
5072
5073CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
5074
5075
5076#ifdef HAVE_DBALLE
5077INTEGER :: handle, ier
5078
5079handle = 0
5080to_char_dat="VALUE: "
5081
5082if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5083if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5084if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5085if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5086
5087if ( c_e(cdat))then
5088 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
5089 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
5090 ier = idba_fatto(handle)
5091 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
5092endif
5093
5094#else
5095
5096to_char_dat="VALUE: "
5097if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5098if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5099if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5100if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5101if (c_e(cdat)) to_char_dat=trim(to_char_dat)//" ;char> "//trim(cdat)
5102
5103#endif
5104
5105END FUNCTION to_char_dat
5106
5107
5108!> Tests whether anything has ever been assigned to a vol7d object
5109!! (.TRUE.) or it is as clean as after an init (.FALSE.).
5110FUNCTION vol7d_c_e(this) RESULT(c_e)
5111TYPE(vol7d), INTENT(in) :: this
5112
5113LOGICAL :: c_e
5114
5115c_e = ASSOCIATED(this%ana) .OR. ASSOCIATED(this%time) .OR. &
5116 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5117 ASSOCIATED(this%network) .OR. &
5118 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5119 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5120 ASSOCIATED(this%anavar%c) .OR. &
5121 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5122 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5123 ASSOCIATED(this%anaattr%c) .OR. &
5124 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5125 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5126 ASSOCIATED(this%dativar%c) .OR. &
5127 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5128 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5129 ASSOCIATED(this%datiattr%c)
5130
5131END FUNCTION vol7d_c_e
5132
5133
5134!> Metodo per allocare i descrittori delle 7 dimensioni.
5135!! Riceve un grande numero di parametri opzionali che
5136!! indicano quali descrittori allocare e con quale estensione;
5137!! i descrittori non specificati non vengono toccati.
5138!! Può essere quindi chiamato più volte allocando via via
5139!! descrittori relativi a dimensioni diverse.
5140!! Se un descrittore richiesto è già allocato, viene deallocato
5141!! (perdendone l'eventuale contenuto) e riallocato con l'estensione
5142!! richiesta.
5143!! Per i descrittori relativi a dimensioni che non siano variabili o attributi,
5144!! è possibile specificare l'estensione di una dimensione a 0,
5145!! in tal caso il descrittore viene comunque allocato con lunghezza nulla,
5146!! che è diverso da non allocarlo. Per i descrittori di variabili e attributi
5147!! passare un'estensione 0 equivale a non fornire il parametro.
5148!! Avere uno o più descrittori dimensionati con estensione nulla fa sì
5149!! che anche il volume dati successivamente allocato abbia estensione nulla;
5150!! sebbene ciò appaia inutile, un volume del genere può in realtà servire,
5151!! in associazione ai metodi ::vol7d_merge o ::vol7d_append per estendere
5152!! un volume esistente aggiungendo elementi in alcune dimensioni (quelle
5153!! a estensione non nulla, ovviamente) e mantenendo invariato tutto il resto.
5154!! Per quanto riguarda i descrittori delle dimensioni relative alle
5155!! variabili, la relativa estensione è specificata con la nomenclatura
5156!! \a n&lt;x&gt;&lt;y&gt;&lt;z&gt; dove &lt;x&gt; può valere:
5157!! - \a ana per variabili relative a voumi di anagrafica
5158!! - \a dati per variabili relative a voumi di dati
5159!!
5160!! &lt;y&gt; può valere:
5161!! - \a var per variabili
5162!! - \a attr per attributi
5163!! - \a varattr variabili aventi attributi nei volumi di attributi
5164!!
5165!! &lt;z&gt; può valere:
5166!! - \a r per variabili o attributi a valori reali
5167!! - \a d per variabili o attributi a valori a doppia precisione
5168!! - \a i per variabili o attributi a valori interi
5169!! - \a b per variabili o attributi a valori byte
5170!! - \a c per variabili o attributi a valori carattere
5171!!
5172SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5173 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5174 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5175 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5176 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5177 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5178 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5179 ini)
5180TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i descrittori
5181INTEGER,INTENT(in),OPTIONAL :: nana !< estensione della dimensione anagrafica
5182INTEGER,INTENT(in),OPTIONAL :: ntime !< estensione della dimensione tempo
5183INTEGER,INTENT(in),OPTIONAL :: nlevel !< estensione della dimensione livello varticale
5184INTEGER,INTENT(in),OPTIONAL :: ntimerange !< estensione della dimensione intervallo temporale (timerange)
5185INTEGER,INTENT(in),OPTIONAL :: nnetwork !< estensione della dimensione rete
5186!> estensione delle possibili dimensioni variabile
5187INTEGER,INTENT(in),OPTIONAL :: &
5188 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5189 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5190 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5191 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5192 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5193 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5194LOGICAL,INTENT(in),OPTIONAL :: ini !< se fornito e vale \c .TRUE., viene chiamato il costruttore, senza parametri opzionali, per ogni elemento di tutti i descrittori allocati, inizializzandolo quindi a valore mancante
5195
5196INTEGER :: i
5197LOGICAL :: linit
5198
5199IF (PRESENT(ini)) THEN
5200 linit = ini
5201ELSE
5202 linit = .false.
5203ENDIF
5204
5205! Dimensioni principali
5206IF (PRESENT(nana)) THEN
5207 IF (nana >= 0) THEN
5208 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5209 ALLOCATE(this%ana(nana))
5210 IF (linit) THEN
5211 DO i = 1, nana
5212 CALL init(this%ana(i))
5213 ENDDO
5214 ENDIF
5215 ENDIF
5216ENDIF
5217IF (PRESENT(ntime)) THEN
5218 IF (ntime >= 0) THEN
5219 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5220 ALLOCATE(this%time(ntime))
5221 IF (linit) THEN
5222 DO i = 1, ntime
5223 CALL init(this%time(i))
5224 ENDDO
5225 ENDIF
5226 ENDIF
5227ENDIF
5228IF (PRESENT(nlevel)) THEN
5229 IF (nlevel >= 0) THEN
5230 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5231 ALLOCATE(this%level(nlevel))
5232 IF (linit) THEN
5233 DO i = 1, nlevel
5234 CALL init(this%level(i))
5235 ENDDO
5236 ENDIF
5237 ENDIF
5238ENDIF
5239IF (PRESENT(ntimerange)) THEN
5240 IF (ntimerange >= 0) THEN
5241 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5242 ALLOCATE(this%timerange(ntimerange))
5243 IF (linit) THEN
5244 DO i = 1, ntimerange
5245 CALL init(this%timerange(i))
5246 ENDDO
5247 ENDIF
5248 ENDIF
5249ENDIF
5250IF (PRESENT(nnetwork)) THEN
5251 IF (nnetwork >= 0) THEN
5252 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5253 ALLOCATE(this%network(nnetwork))
5254 IF (linit) THEN
5255 DO i = 1, nnetwork
5256 CALL init(this%network(i))
5257 ENDDO
5258 ENDIF
5259 ENDIF
5260ENDIF
5261! Dimensioni dei tipi delle variabili
5262CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5263 nanavari, nanavarb, nanavarc, ini)
5264CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5265 nanaattri, nanaattrb, nanaattrc, ini)
5266CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5267 nanavarattri, nanavarattrb, nanavarattrc, ini)
5268CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5269 ndativari, ndativarb, ndativarc, ini)
5270CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5271 ndatiattri, ndatiattrb, ndatiattrc, ini)
5272CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5273 ndativarattri, ndativarattrb, ndativarattrc, ini)
5274
5275END SUBROUTINE vol7d_alloc
5276
5277
5278FUNCTION vol7d_check_alloc_ana(this)
5279TYPE(vol7d),INTENT(in) :: this
5280LOGICAL :: vol7d_check_alloc_ana
5281
5282vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5283
5284END FUNCTION vol7d_check_alloc_ana
5285
5286SUBROUTINE vol7d_force_alloc_ana(this, ini)
5287TYPE(vol7d),INTENT(inout) :: this
5288LOGICAL,INTENT(in),OPTIONAL :: ini
5289
5290! Alloco i descrittori minimi per avere un volume di anagrafica
5291IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5292IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5293
5294END SUBROUTINE vol7d_force_alloc_ana
5295
5296
5297FUNCTION vol7d_check_alloc_dati(this)
5298TYPE(vol7d),INTENT(in) :: this
5299LOGICAL :: vol7d_check_alloc_dati
5300
5301vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5302 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5303 ASSOCIATED(this%timerange)
5304
5305END FUNCTION vol7d_check_alloc_dati
5306
5307SUBROUTINE vol7d_force_alloc_dati(this, ini)
5308TYPE(vol7d),INTENT(inout) :: this
5309LOGICAL,INTENT(in),OPTIONAL :: ini
5310
5311! Alloco i descrittori minimi per avere un volume di dati
5312CALL vol7d_force_alloc_ana(this, ini)
5313IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5314IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5315IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5316
5317END SUBROUTINE vol7d_force_alloc_dati
5318
5319
5320SUBROUTINE vol7d_force_alloc(this)
5321TYPE(vol7d),INTENT(inout) :: this
5322
5323! If anything really not allocated yet, allocate with size 0
5324IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
5325IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
5326IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
5327IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
5328IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
5329
5330END SUBROUTINE vol7d_force_alloc
5331
5332
5333FUNCTION vol7d_check_vol(this)
5334TYPE(vol7d),INTENT(in) :: this !< oggetto da controllare
5335LOGICAL :: vol7d_check_vol
5336
5337vol7d_check_vol = c_e(this)
5338
5339! Anagrafica
5340IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5341 vol7d_check_vol = .false.
5342ENDIF
5343
5344IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5345 vol7d_check_vol = .false.
5346ENDIF
5347
5348IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5349 vol7d_check_vol = .false.
5350ENDIF
5351
5352IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5353 vol7d_check_vol = .false.
5354ENDIF
5355
5356IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5357 vol7d_check_vol = .false.
5358ENDIF
5359IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5360 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5361 ASSOCIATED(this%anavar%c)) THEN
5362 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
5363ENDIF
5364
5365! Attributi dell'anagrafica
5366IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5367 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5368 vol7d_check_vol = .false.
5369ENDIF
5370
5371IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5372 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5373 vol7d_check_vol = .false.
5374ENDIF
5375
5376IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5377 .NOT.ASSOCIATED(this%volanaattri)) THEN
5378 vol7d_check_vol = .false.
5379ENDIF
5380
5381IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5382 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5383 vol7d_check_vol = .false.
5384ENDIF
5385
5386IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5387 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5388 vol7d_check_vol = .false.
5389ENDIF
5390
5391! Dati
5392IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5393 vol7d_check_vol = .false.
5394ENDIF
5395
5396IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5397 vol7d_check_vol = .false.
5398ENDIF
5399
5400IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5401 vol7d_check_vol = .false.
5402ENDIF
5403
5404IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5405 vol7d_check_vol = .false.
5406ENDIF
5407
5408IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5409 vol7d_check_vol = .false.
5410ENDIF
5411
5412! Attributi dei dati
5413IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5414 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5415 vol7d_check_vol = .false.
5416ENDIF
5417
5418IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5419 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5420 vol7d_check_vol = .false.
5421ENDIF
5422
5423IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5424 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5425 vol7d_check_vol = .false.
5426ENDIF
5427
5428IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5429 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5430 vol7d_check_vol = .false.
5431ENDIF
5432
5433IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5434 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5435 vol7d_check_vol = .false.
5436ENDIF
5437IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5438 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5439 ASSOCIATED(this%dativar%c)) THEN
5440 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
5441ENDIF
5442
5443END FUNCTION vol7d_check_vol
5444
5445
5446!> Metodo per allocare i volumi richiesti di variabili e attributi per
5447!! anagrafica e dati.
5448!! Se alcuni dei descrittori relativi alle dimensioni anagrafica,
5449!! livello verticale, tempo, intervallo temporale (timerange), rete non sono
5450!! stati richiesti preventivamente con la ::vol7d_alloc, essi vengono allocati
5451!! automaticamente da questo metodo
5452!! con estensione di default pari a 1 (non 0!), questo significa, ad esempio,
5453!! che se prevedo di avere soli dati superficiali, cioè ad un solo livello
5454!! verticale, o una sola rete di stazioni, non devo preoccuparmi di
5455!! specificare questa informazione.
5456!! Tra i 20 possibili volumi allocabili
5457!! ((variabili,attributi)*(anagrafica,dati)*(r,d,i,b,c)=20)
5458!! saranno allocati solo quelli per cui è stato precedentemente richiesto il
5459!! corrispondente descrittore variabili/attributi con la ::vol7d_alloc.
5460SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
5461TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i volumi
5462LOGICAL,INTENT(in),OPTIONAL :: ini !< se fornito e vale \c .TRUE., viene chiamato il costruttore, senza parametri opzionali, per ogni elemento di tutti i descrittori allocati
5463LOGICAL,INTENT(in),OPTIONAL :: inivol !< se fornito e vale \c .TRUE., i volumi allocati saranno inizializzati a valore mancante
5464
5465LOGICAL :: linivol
5466
5467IF (PRESENT(inivol)) THEN
5468 linivol = inivol
5469ELSE
5470 linivol = .true.
5471ENDIF
5472
5473! Anagrafica
5474IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5475 CALL vol7d_force_alloc_ana(this, ini)
5476 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
5477 IF (linivol) this%volanar(:,:,:) = rmiss
5478ENDIF
5479
5480IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5481 CALL vol7d_force_alloc_ana(this, ini)
5482 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
5483 IF (linivol) this%volanad(:,:,:) = rdmiss
5484ENDIF
5485
5486IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5487 CALL vol7d_force_alloc_ana(this, ini)
5488 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
5489 IF (linivol) this%volanai(:,:,:) = imiss
5490ENDIF
5491
5492IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5493 CALL vol7d_force_alloc_ana(this, ini)
5494 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
5495 IF (linivol) this%volanab(:,:,:) = ibmiss
5496ENDIF
5497
5498IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5499 CALL vol7d_force_alloc_ana(this, ini)
5500 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
5501 IF (linivol) this%volanac(:,:,:) = cmiss
5502ENDIF
5503
5504! Attributi dell'anagrafica
5505IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5506 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5507 CALL vol7d_force_alloc_ana(this, ini)
5508 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
5509 SIZE(this%network), SIZE(this%anaattr%r)))
5510 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
5511ENDIF
5512
5513IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5514 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5515 CALL vol7d_force_alloc_ana(this, ini)
5516 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
5517 SIZE(this%network), SIZE(this%anaattr%d)))
5518 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
5519ENDIF
5520
5521IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5522 .NOT.ASSOCIATED(this%volanaattri)) THEN
5523 CALL vol7d_force_alloc_ana(this, ini)
5524 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
5525 SIZE(this%network), SIZE(this%anaattr%i)))
5526 IF (linivol) this%volanaattri(:,:,:,:) = imiss
5527ENDIF
5528
5529IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5530 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5531 CALL vol7d_force_alloc_ana(this, ini)
5532 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
5533 SIZE(this%network), SIZE(this%anaattr%b)))
5534 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
5535ENDIF
5536
5537IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5538 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5539 CALL vol7d_force_alloc_ana(this, ini)
5540 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
5541 SIZE(this%network), SIZE(this%anaattr%c)))
5542 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
5543ENDIF
5544
5545! Dati
5546IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5547 CALL vol7d_force_alloc_dati(this, ini)
5548 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5549 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
5550 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
5551ENDIF
5552
5553IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5554 CALL vol7d_force_alloc_dati(this, ini)
5555 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5556 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
5557 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
5558ENDIF
5559
5560IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5561 CALL vol7d_force_alloc_dati(this, ini)
5562 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5563 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
5564 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
5565ENDIF
5566
5567IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5568 CALL vol7d_force_alloc_dati(this, ini)
5569 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5570 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
5571 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
5572ENDIF
5573
5574IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5575 CALL vol7d_force_alloc_dati(this, ini)
5576 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5577 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
5578 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
5579ENDIF
5580
5581! Attributi dei dati
5582IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5583 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5584 CALL vol7d_force_alloc_dati(this, ini)
5585 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5586 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
5587 SIZE(this%datiattr%r)))
5588 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
5589ENDIF
5590
5591IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5592 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5593 CALL vol7d_force_alloc_dati(this, ini)
5594 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5595 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
5596 SIZE(this%datiattr%d)))
5597 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
5598ENDIF
5599
5600IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5601 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5602 CALL vol7d_force_alloc_dati(this, ini)
5603 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5604 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
5605 SIZE(this%datiattr%i)))
5606 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
5607ENDIF
5608
5609IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
5610 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
5611 CALL vol7d_force_alloc_dati(this, ini)
5612 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5613 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
5614 SIZE(this%datiattr%b)))
5615 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
5616ENDIF
5617
5618IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
5619 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
5620 CALL vol7d_force_alloc_dati(this, ini)
5621 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
5622 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
5623 SIZE(this%datiattr%c)))
5624 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
5625ENDIF
5626
5627! Catch-all method
5628CALL vol7d_force_alloc(this)
5629
5630! Creo gli indici var-attr
5631
5632#ifdef DEBUG
5633CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
5634#endif
5635
5636CALL vol7d_set_attr_ind(this)
5637
5638
5639
5640END SUBROUTINE vol7d_alloc_vol
5641
5642
5643!> Metodo per creare gli indici che associano le variabili aventi attributo
5644!! alle variabili nei relativi descrittori.
5645!! Ha senso chiamare questo metodo solo dopo che i descrittori delle variabili
5646!! e degli attributi desiderati sono stati allocati ed è stato assegnato un
5647!! valore ai relativi membri btable (vedi vol7d_var_class::vol7d_var), se
5648!! i descrittori non sono stati allocati o assegnati, il metodo non fa niente.
5649SUBROUTINE vol7d_set_attr_ind(this)
5650TYPE(vol7d),INTENT(inout) :: this !< oggetto in cui creare gli indici
5651
5652INTEGER :: i
5653
5654! real
5655IF (ASSOCIATED(this%dativar%r)) THEN
5656 IF (ASSOCIATED(this%dativarattr%r)) THEN
5657 DO i = 1, SIZE(this%dativar%r)
5658 this%dativar%r(i)%r = &
5659 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
5660 ENDDO
5661 ENDIF
5662
5663 IF (ASSOCIATED(this%dativarattr%d)) THEN
5664 DO i = 1, SIZE(this%dativar%r)
5665 this%dativar%r(i)%d = &
5666 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
5667 ENDDO
5668 ENDIF
5669
5670 IF (ASSOCIATED(this%dativarattr%i)) THEN
5671 DO i = 1, SIZE(this%dativar%r)
5672 this%dativar%r(i)%i = &
5673 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
5674 ENDDO
5675 ENDIF
5676
5677 IF (ASSOCIATED(this%dativarattr%b)) THEN
5678 DO i = 1, SIZE(this%dativar%r)
5679 this%dativar%r(i)%b = &
5680 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
5681 ENDDO
5682 ENDIF
5683
5684 IF (ASSOCIATED(this%dativarattr%c)) THEN
5685 DO i = 1, SIZE(this%dativar%r)
5686 this%dativar%r(i)%c = &
5687 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
5688 ENDDO
5689 ENDIF
5690ENDIF
5691! double
5692IF (ASSOCIATED(this%dativar%d)) THEN
5693 IF (ASSOCIATED(this%dativarattr%r)) THEN
5694 DO i = 1, SIZE(this%dativar%d)
5695 this%dativar%d(i)%r = &
5696 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
5697 ENDDO
5698 ENDIF
5699
5700 IF (ASSOCIATED(this%dativarattr%d)) THEN
5701 DO i = 1, SIZE(this%dativar%d)
5702 this%dativar%d(i)%d = &
5703 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
5704 ENDDO
5705 ENDIF
5706
5707 IF (ASSOCIATED(this%dativarattr%i)) THEN
5708 DO i = 1, SIZE(this%dativar%d)
5709 this%dativar%d(i)%i = &
5710 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
5711 ENDDO
5712 ENDIF
5713
5714 IF (ASSOCIATED(this%dativarattr%b)) THEN
5715 DO i = 1, SIZE(this%dativar%d)
5716 this%dativar%d(i)%b = &
5717 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
5718 ENDDO
5719 ENDIF
5720
5721 IF (ASSOCIATED(this%dativarattr%c)) THEN
5722 DO i = 1, SIZE(this%dativar%d)
5723 this%dativar%d(i)%c = &
5724 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
5725 ENDDO
5726 ENDIF
5727ENDIF
5728! integer
5729IF (ASSOCIATED(this%dativar%i)) THEN
5730 IF (ASSOCIATED(this%dativarattr%r)) THEN
5731 DO i = 1, SIZE(this%dativar%i)
5732 this%dativar%i(i)%r = &
5733 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
5734 ENDDO
5735 ENDIF
5736
5737 IF (ASSOCIATED(this%dativarattr%d)) THEN
5738 DO i = 1, SIZE(this%dativar%i)
5739 this%dativar%i(i)%d = &
5740 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
5741 ENDDO
5742 ENDIF
5743
5744 IF (ASSOCIATED(this%dativarattr%i)) THEN
5745 DO i = 1, SIZE(this%dativar%i)
5746 this%dativar%i(i)%i = &
5747 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
5748 ENDDO
5749 ENDIF
5750
5751 IF (ASSOCIATED(this%dativarattr%b)) THEN
5752 DO i = 1, SIZE(this%dativar%i)
5753 this%dativar%i(i)%b = &
5754 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
5755 ENDDO
5756 ENDIF
5757
5758 IF (ASSOCIATED(this%dativarattr%c)) THEN
5759 DO i = 1, SIZE(this%dativar%i)
5760 this%dativar%i(i)%c = &
5761 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
5762 ENDDO
5763 ENDIF
5764ENDIF
5765! byte
5766IF (ASSOCIATED(this%dativar%b)) THEN
5767 IF (ASSOCIATED(this%dativarattr%r)) THEN
5768 DO i = 1, SIZE(this%dativar%b)
5769 this%dativar%b(i)%r = &
5770 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
5771 ENDDO
5772 ENDIF
5773
5774 IF (ASSOCIATED(this%dativarattr%d)) THEN
5775 DO i = 1, SIZE(this%dativar%b)
5776 this%dativar%b(i)%d = &
5777 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
5778 ENDDO
5779 ENDIF
5780
5781 IF (ASSOCIATED(this%dativarattr%i)) THEN
5782 DO i = 1, SIZE(this%dativar%b)
5783 this%dativar%b(i)%i = &
5784 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
5785 ENDDO
5786 ENDIF
5787
5788 IF (ASSOCIATED(this%dativarattr%b)) THEN
5789 DO i = 1, SIZE(this%dativar%b)
5790 this%dativar%b(i)%b = &
5791 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
5792 ENDDO
5793 ENDIF
5794
5795 IF (ASSOCIATED(this%dativarattr%c)) THEN
5796 DO i = 1, SIZE(this%dativar%b)
5797 this%dativar%b(i)%c = &
5798 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
5799 ENDDO
5800 ENDIF
5801ENDIF
5802! character
5803IF (ASSOCIATED(this%dativar%c)) THEN
5804 IF (ASSOCIATED(this%dativarattr%r)) THEN
5805 DO i = 1, SIZE(this%dativar%c)
5806 this%dativar%c(i)%r = &
5807 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
5808 ENDDO
5809 ENDIF
5810
5811 IF (ASSOCIATED(this%dativarattr%d)) THEN
5812 DO i = 1, SIZE(this%dativar%c)
5813 this%dativar%c(i)%d = &
5814 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
5815 ENDDO
5816 ENDIF
5817
5818 IF (ASSOCIATED(this%dativarattr%i)) THEN
5819 DO i = 1, SIZE(this%dativar%c)
5820 this%dativar%c(i)%i = &
5821 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
5822 ENDDO
5823 ENDIF
5824
5825 IF (ASSOCIATED(this%dativarattr%b)) THEN
5826 DO i = 1, SIZE(this%dativar%c)
5827 this%dativar%c(i)%b = &
5828 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
5829 ENDDO
5830 ENDIF
5831
5832 IF (ASSOCIATED(this%dativarattr%c)) THEN
5833 DO i = 1, SIZE(this%dativar%c)
5834 this%dativar%c(i)%c = &
5835 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
5836 ENDDO
5837 ENDIF
5838ENDIF
5839
5840END SUBROUTINE vol7d_set_attr_ind
5841
5842
5843!> Metodo per fondere 2 oggetti vol7d.
5844!! Il secondo volume viene accodato al primo e poi distrutto, si veda
5845!! quindi la descrizione di ::vol7d_append. Se uno degli oggetti \a
5846!! this o \a that sono vuoti non perde tempo inutile,
5847SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
5848 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5849TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, alla fine conterrà il risultato della fusione
5850TYPE(vol7d),INTENT(INOUT) :: that !< secondo oggetto in ingresso, alla fine sarà distrutto
5851LOGICAL,INTENT(IN),OPTIONAL :: sort !< se fornito e uguale a \c .TRUE., i descrittori che supportano un ordinamento (operatori > e/o <) risulteranno ordinati in ordine crescente nell'oggetto finale
5852LOGICAL,INTENT(in),OPTIONAL :: bestdata !< if provided and \a .TRUE. in case of overlapping volumes keep valid data where available, or data from the second volume if both valid
5853LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
5854
5855TYPE(vol7d) :: v7d_clean
5856
5857
5858IF (.NOT.c_e(this)) THEN ! speedup
5859 this = that
5860 CALL init(v7d_clean)
5861 that = v7d_clean ! destroy that without deallocating
5862ELSE ! Append that to this and destroy that
5863 CALL vol7d_append(this, that, sort, bestdata, &
5864 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
5865 CALL delete(that)
5866ENDIF
5867
5868END SUBROUTINE vol7d_merge
5869
5870
5871!> Metodo per accodare un oggetto vol7d ad un altro.
5872!! Si tratta di un metodo molto potente e versatile;
5873!! i descrittori delle dimensioni del volume finale conterranno i valori
5874!! dei corrispondenti descrittori del primo e del secondo volume
5875!! e i volumi di anagrafica e dati conterranno i valori dei due volumi
5876!! ai posti giusti, e valori mancanti per le nuove combinazioni che
5877!! eventualmente si verranno a creare.
5878!! Se i volumi multidimensionali di anagrafica e/o dati dei 2 oggetti
5879!! hanno un'intersezione non nulla, negli elementi comuni il volume finale
5880!! conterrà il corrispondente elemento del \b secondo volume.
5881!! Attenzione che, durante l'esecuzione del metodo, la memoria richiesta è
5882!! pari alla memoria complessiva occupata dai 2 volumi iniziali più
5883!! la memoria complessiva del volume finale, per cui, nel caso di volumi grandi,
5884!! ci potrebbero essere problemi di esaurimento della memoria centrale.
5885!! Se l'oggetto \a that è vuoto non perde tempo inutile,
5886!!
5887!! \todo nel caso di elementi comuni inserire la possibiità (opzionale per
5888!! non penalizzare le prestazioni quando ciò non serve) di effettuare una scelta
5889!! più ragionata dell'elemento da tenere, almeno controllando i dati mancanti
5890!! se non le flag di qualità
5891!!
5892!! \todo "rateizzare" l'allocazione dei volumi per ridurre l'occupazione di
5893!! memoria nel caso siano allocati contemporaneamente volumi di variabili e
5894!! di attributi o più volumi di tipi diversi
5895!!
5896!! \todo il parametro \a that è dichiarato \a INOUT perché la vol7d_alloc_vol
5897!! può modificarlo, bisognerebbe implementare una vol7d_check_vol che restituisca
5898!! errore anziché usare la vol7d_alloc_vol.
5899SUBROUTINE vol7d_append(this, that, sort, bestdata, &
5900 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
5901TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, a cui sarà accodato il secondo
5902TYPE(vol7d),INTENT(IN) :: that !< secondo oggetto in ingresso, non viene modificato dal metodo
5903LOGICAL,INTENT(IN),OPTIONAL :: sort !< se fornito e uguale a \c .TRUE., i descrittori che supportano un ordinamento (operatori > e/o <) risulteranno ordinati in ordine crescente nell'oggetto finale
5904! experimental, please do not use outside the library now, they force the use
5905! of a simplified mapping algorithm which is valid only whene the dimension
5906! content is the same in both volumes , or when one of them is empty
5907LOGICAL,INTENT(in),OPTIONAL :: bestdata !< if provided and \a .TRUE. in case of overlapping volumes keep valid data where available, or data from the second volume if both valid
5908LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
5909
5910
5911TYPE(vol7d) :: v7dtmp
5912LOGICAL :: lsort, lbestdata
5913INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
5914 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
5915
5916IF (.NOT.c_e(that)) RETURN ! speedup, nothing to do
5917IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
5918IF (.NOT.c_e(this)) THEN ! this case is like a vol7d_copy, more efficient to copy?
5919 CALL vol7d_copy(that, this, sort=sort)
5920 RETURN
5921ENDIF
5922
5923IF (this%time_definition /= that%time_definition) THEN
5924 CALL l4f_log(l4f_fatal, &
5925 'in vol7d_append, cannot append volumes with different &
5926 &time definition')
5927 CALL raise_fatal_error()
5928ENDIF
5929
5930! Completo l'allocazione per avere volumi a norma
5931CALL vol7d_alloc_vol(this)
5932
5933CALL init(v7dtmp, time_definition=this%time_definition)
5934CALL optio(sort, lsort)
5935CALL optio(bestdata, lbestdata)
5936
5937! Calcolo le mappature tra volumi vecchi e volume nuovo
5938! I puntatori remap* vengono tutti o allocati o nullificati
5939IF (optio_log(ltimesimple)) THEN
5940 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
5941 lsort, remapt1, remapt2)
5942ELSE
5943 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
5944 lsort, remapt1, remapt2)
5945ENDIF
5946IF (optio_log(ltimerangesimple)) THEN
5947 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
5948 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5949ELSE
5950 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
5951 v7dtmp%timerange, lsort, remaptr1, remaptr2)
5952ENDIF
5953IF (optio_log(llevelsimple)) THEN
5954 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
5955 lsort, remapl1, remapl2)
5956ELSE
5957 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
5958 lsort, remapl1, remapl2)
5959ENDIF
5960IF (optio_log(lanasimple)) THEN
5961 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5962 .false., remapa1, remapa2)
5963ELSE
5964 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
5965 .false., remapa1, remapa2)
5966ENDIF
5967IF (optio_log(lnetworksimple)) THEN
5968 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
5969 .false., remapn1, remapn2)
5970ELSE
5971 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
5972 .false., remapn1, remapn2)
5973ENDIF
5974
5975! Faccio la fusione fisica dei volumi
5976CALL vol7d_merge_finalr(this, that, v7dtmp, &
5977 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5978 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5979CALL vol7d_merge_finald(this, that, v7dtmp, &
5980 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5981 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5982CALL vol7d_merge_finali(this, that, v7dtmp, &
5983 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5984 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5985CALL vol7d_merge_finalb(this, that, v7dtmp, &
5986 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5987 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5988CALL vol7d_merge_finalc(this, that, v7dtmp, &
5989 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
5990 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
5991
5992! Dealloco i vettori di rimappatura
5993IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
5994IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
5995IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
5996IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
5997IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
5998IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
5999IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
6000IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
6001IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
6002IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
6003
6004! Distruggo il vecchio volume e assegno il nuovo a this
6005CALL delete(this)
6006this = v7dtmp
6007! Ricreo gli indici var-attr
6008CALL vol7d_set_attr_ind(this)
6009
6010END SUBROUTINE vol7d_append
6011
6012
6013!> Metodo per creare una copia completa e indipendente di un oggetto vol7d.
6014!! Questo metodo crea un duplicato di tutti i membri di un oggetto vol7d,
6015!! con la possibilità di rielaborarlo durante la copia. Se l'oggetto da copiare
6016!! è vuoto non perde tempo inutile.
6017!! Attenzione, il codice:
6018!! \code
6019!! USE vol7d_class
6020!! TYPE(vol7d) :: vol1, vol2
6021!! CALL init(vol1)
6022!! CALL init(vol2)
6023!! ... ! riempio vol1
6024!! vol2 = vol1
6025!! \endcode
6026!! fa una cosa diversa rispetto a:
6027!! \code
6028!! USE vol7d_class
6029!! TYPE(vol7d) :: vol1, vol2
6030!! CALL init(vol1)
6031!! CALL init(vol2)
6032!! ... ! riempio vol1
6033!! CALL vol7d_copy(vol1, vol2)
6034!! \endcode
6035!! nel primo caso, infatti, l'operatore di assegnazione copia solo i componenti
6036!! statici di \a vol1 nei corrispondenti elementi di \a vol2, mentre i componenti che
6037!! sono allocati dinamicamente (cioè quelli che in ::vol7d hanno l'attributo
6038!! \c POINTER, in pratica quasi tutti) non vengono duplicati, ma per essi vol2
6039!! conterrà un puntatore al corrispondente elemento a cui già punta vol1, e quindi
6040!! eventuali cambiamenti al contenuto di uno dei due oggetti influenzerà il
6041!! contenuto dell'altro; nel secondo caso, invece, vol1 e vol2 sono, dopo la
6042!! vol7d_copy, 2 istanze
6043!! completamente indipendenti, ma uguali tra loro per contenuto, della classe
6044!! vol7d, e quindi hanno vita indipendente.
6045SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
6046 lsort_time, lsort_timerange, lsort_level, &
6047 ltime, ltimerange, llevel, lana, lnetwork, &
6048 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6049 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6050 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6051 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6052 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6053 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6054TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
6055TYPE(vol7d),INTENT(INOUT) :: that !< oggetto destinazione
6056LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
6057LOGICAL,INTENT(IN),OPTIONAL :: unique !< se fornito e uguale a \c .TRUE., gli eventuali elementi duplicati nei descrittori dell'oggetto iniziale verranno collassati in un unico elemento (con eventuale perdita dei dati relativi agli elementi duplicati)
6058LOGICAL,INTENT(IN),OPTIONAL :: miss !< se fornito e uguale a \c .TRUE., gli eventuali elementi dei descrittori uguali al corrispondente valore mancante verranno eliminati dall'oggetto riformato
6059LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
6060LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
6061LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
6062!> se fornito, deve essere un vettore logico della stessa lunghezza di
6063!! this%time indicante quali elementi della dimensione \a time
6064!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
6065!! nel volume copiato; in alternativa può essere un vettore di
6066!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
6067!! gli elementi (utile principalmente per le variabili); è compatibile
6068!! col parametro \a miss
6069LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6070!> come il precedente per la dimensione \a timerange
6071LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6072!> come il precedente per la dimensione \a level
6073LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6074!> come il precedente per la dimensione \a ana
6075LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6076!> come il precedente per la dimensione \a network
6077LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6078!> come il precedente per tutte le possibili dimensioni variabile
6079LOGICAL,INTENT(in),OPTIONAL :: &
6080 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6081 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6082 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6083 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6084 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6085 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6086
6087LOGICAL :: lsort, lunique, lmiss
6088INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
6089
6090CALL init(that)
6091IF (.NOT.c_e(this)) RETURN ! speedup, nothing to do
6092IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
6093
6094CALL optio(sort, lsort)
6095CALL optio(unique, lunique)
6096CALL optio(miss, lmiss)
6097
6098! Calcolo le mappature tra volume vecchio e volume nuovo
6099! I puntatori remap* vengono tutti o allocati o nullificati
6100CALL vol7d_remap1_datetime(this%time, that%time, &
6101 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6102CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6103 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6104CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6105 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6106CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6107 lsort, lunique, lmiss, remapa, lana)
6108CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6109 lsort, lunique, lmiss, remapn, lnetwork)
6110
6111! lanavari, lanavarb, lanavarc, &
6112! lanaattri, lanaattrb, lanaattrc, &
6113! lanavarattri, lanavarattrb, lanavarattrc, &
6114! ldativari, ldativarb, ldativarc, &
6115! ldatiattri, ldatiattrb, ldatiattrc, &
6116! ldativarattri, ldativarattrb, ldativarattrc
6117! Faccio la riforma fisica dei volumi
6118CALL vol7d_reform_finalr(this, that, &
6119 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6120 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6121CALL vol7d_reform_finald(this, that, &
6122 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6123 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6124CALL vol7d_reform_finali(this, that, &
6125 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6126 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6127CALL vol7d_reform_finalb(this, that, &
6128 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6129 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6130CALL vol7d_reform_finalc(this, that, &
6131 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6132 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6133
6134! Dealloco i vettori di rimappatura
6135IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6136IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6137IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6138IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6139IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6140
6141! Ricreo gli indici var-attr
6142CALL vol7d_set_attr_ind(that)
6143that%time_definition = this%time_definition
6144
6145END SUBROUTINE vol7d_copy
6146
6147
6148!> Metodo per riformare in varie maniere un oggetto vol7d.
6149!! Equivale ad una copia (vedi ::vol7d_copy)
6150!! seguita dalla distruzione del volume iniziale e alla
6151!! sua riassegnazione al volume copiato. Ha senso se almeno uno dei parametri
6152!! \a sort, \a uniq o \a miss è fornito uguale a \c .TRUE., altrimenti
6153!! è solo una perdita di tempo.
6154!! Può essere utile, ad esempio, per eliminare stazioni
6155!! o istanti temporali indesiderati, basta assegnare il loro corrispondente
6156!! elemento del descrittore a valore mancante e chiamare vol7d_reform
6157!! con miss=.TRUE. .
6158SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6159 lsort_time, lsort_timerange, lsort_level, &
6160 ltime, ltimerange, llevel, lana, lnetwork, &
6161 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6162 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6163 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6164 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6165 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6166 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6167 ,purgeana)
6168TYPE(vol7d),INTENT(INOUT) :: this !< oggetto da riformare
6169LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
6170LOGICAL,INTENT(IN),OPTIONAL :: unique !< se fornito e uguale a \c .TRUE., gli eventuali elementi duplicati nei descrittori dell'oggetto iniziale verranno collassati in un unico elemento (con eventuale perdita dei dati relativi agli elementi duplicati)
6171LOGICAL,INTENT(IN),OPTIONAL :: miss !< se fornito e uguale a \c .TRUE., gli eventuali elementi dei descrittori uguali al corrispondente valore mancante verranno eliminati dall'oggetto riformato
6172LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
6173LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
6174LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
6175!> se fornito, deve essere un vettore logico della stessa lunghezza di
6176!! this%time indicante quali elementi della dimensione \a time
6177!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
6178!! nel volume copiato; in alternativa può essere un vettore di
6179!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
6180!! gli elementi (utile principalmente per le variabili); è compatibile
6181!! col parametro \a miss
6182LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6183LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:) !< come il precedente per la dimensione \a timerange
6184LOGICAL,INTENT(IN),OPTIONAL :: llevel(:) !< come il precedente per la dimensione \a level
6185LOGICAL,INTENT(IN),OPTIONAL :: lana(:) !< come il precedente per la dimensione \a ana
6186LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:) !< come il precedente per la dimensione \a network
6187!> come il precedente per tutte le possibili dimensioni variabile
6188LOGICAL,INTENT(in),OPTIONAL :: &
6189 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6190 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6191 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6192 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6193 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6194 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6195LOGICAL,INTENT(IN),OPTIONAL :: purgeana !< if true remove ana with all data missing
6196
6197TYPE(vol7d) :: v7dtmp
6198logical,allocatable :: llana(:)
6199integer :: i
6200
6201CALL vol7d_copy(this, v7dtmp, sort, unique, miss, &
6202 lsort_time, lsort_timerange, lsort_level, &
6203 ltime, ltimerange, llevel, lana, lnetwork, &
6204 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6205 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6206 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6207 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6208 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6209 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6210
6211! destroy old volume
6212CALL delete(this)
6213
6214if (optio_log(purgeana)) then
6215 allocate(llana(size(v7dtmp%ana)))
6216 llana =.false.
6217 do i =1,size(v7dtmp%ana)
6218 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6219 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6220 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6221 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6222 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6223 end do
6224 CALL vol7d_copy(v7dtmp, this,lana=llana)
6225 CALL delete(v7dtmp)
6226 deallocate(llana)
6227else
6228 this=v7dtmp
6229end if
6230
6231END SUBROUTINE vol7d_reform
6232
6233
6234!> Sorts the sortable dimensions in the volume \a this only when necessary.
6235!! Most of the times, the time, timerange and level dimensions in a
6236!! vol7d object are correctly sorted; on the other side many methods
6237!! strictly rely on this fact in order to work correctly. This method
6238!! performs a quick check and sorts the required dimensions only if
6239!! they are not sorted in ascending order yet, improving safety
6240!! without impairing much performance.
6241SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6242TYPE(vol7d),INTENT(INOUT) :: this !< object to be sorted
6243LOGICAL,OPTIONAL,INTENT(in) :: lsort_time !< if present and \a .TRUE., sort time dimension if it is not sorted in ascending order
6244LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange !< if present and \a .TRUE., sort timerange dimension if it is not sorted in ascending order
6245LOGICAL,OPTIONAL,INTENT(in) :: lsort_level !< if present and \a .TRUE., sort vertical level dimension if it is not sorted in ascending order
6246
6247INTEGER :: i
6248LOGICAL :: to_be_sorted
6249
6250to_be_sorted = .false.
6251CALL vol7d_alloc_vol(this) ! usual safety check
6252
6253IF (optio_log(lsort_time)) THEN
6254 DO i = 2, SIZE(this%time)
6255 IF (this%time(i) < this%time(i-1)) THEN
6256 to_be_sorted = .true.
6257 EXIT
6258 ENDIF
6259 ENDDO
6260ENDIF
6261IF (optio_log(lsort_timerange)) THEN
6262 DO i = 2, SIZE(this%timerange)
6263 IF (this%timerange(i) < this%timerange(i-1)) THEN
6264 to_be_sorted = .true.
6265 EXIT
6266 ENDIF
6267 ENDDO
6268ENDIF
6269IF (optio_log(lsort_level)) THEN
6270 DO i = 2, SIZE(this%level)
6271 IF (this%level(i) < this%level(i-1)) THEN
6272 to_be_sorted = .true.
6273 EXIT
6274 ENDIF
6275 ENDDO
6276ENDIF
6277
6278IF (to_be_sorted) CALL vol7d_reform(this, &
6279 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6280
6281END SUBROUTINE vol7d_smart_sort
6282
6283!> Filter the contents of a volume keeping only desired data.
6284!! This subroutine filters a vol7d object by keeping only a subset of
6285!! the data contained. It can keep only times within a specified
6286!! interval, only station networks contained in a list and only
6287!! specified station or data variables. If a filter parameter is not
6288!! provided, no filtering will take place according to that criterion.
6289!! The volume is reallocated keeping only the desired data.
6290SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6291TYPE(vol7d),INTENT(inout) :: this !< volume to be filtered
6292CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:) !< list of station variables to be kept, if not provided or of zero length, all variables are kept
6293CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:) !< list of data variables to be kept, if not provided or of zero length, all variables are kept
6294TYPE(vol7d_network),OPTIONAL :: nl(:) !< list of station networks to be kept, if not provided or of zero length, all networks are kept
6295TYPE(datetime),INTENT(in),OPTIONAL :: s_d !< initial time interval for time filtering, if not provided or equal to missing data no lower limit is imposed
6296TYPE(datetime),INTENT(in),OPTIONAL :: e_d !< final time interval for time filtering, if not provided or equal to missing data no upper limit is imposed
6297
6298INTEGER :: i
6299
6300IF (PRESENT(avl)) THEN
6301 IF (SIZE(avl) > 0) THEN
6302
6303 IF (ASSOCIATED(this%anavar%r)) THEN
6304 DO i = 1, SIZE(this%anavar%r)
6305 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6306 ENDDO
6307 ENDIF
6308
6309 IF (ASSOCIATED(this%anavar%i)) THEN
6310 DO i = 1, SIZE(this%anavar%i)
6311 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6312 ENDDO
6313 ENDIF
6314
6315 IF (ASSOCIATED(this%anavar%b)) THEN
6316 DO i = 1, SIZE(this%anavar%b)
6317 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6318 ENDDO
6319 ENDIF
6320
6321 IF (ASSOCIATED(this%anavar%d)) THEN
6322 DO i = 1, SIZE(this%anavar%d)
6323 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
6324 ENDDO
6325 ENDIF
6326
6327 IF (ASSOCIATED(this%anavar%c)) THEN
6328 DO i = 1, SIZE(this%anavar%c)
6329 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
6330 ENDDO
6331 ENDIF
6332
6333 ENDIF
6334ENDIF
6335
6336
6337IF (PRESENT(vl)) THEN
6338 IF (size(vl) > 0) THEN
6339 IF (ASSOCIATED(this%dativar%r)) THEN
6340 DO i = 1, SIZE(this%dativar%r)
6341 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
6342 ENDDO
6343 ENDIF
6344
6345 IF (ASSOCIATED(this%dativar%i)) THEN
6346 DO i = 1, SIZE(this%dativar%i)
6347 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
6348 ENDDO
6349 ENDIF
6350
6351 IF (ASSOCIATED(this%dativar%b)) THEN
6352 DO i = 1, SIZE(this%dativar%b)
6353 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
6354 ENDDO
6355 ENDIF
6356
6357 IF (ASSOCIATED(this%dativar%d)) THEN
6358 DO i = 1, SIZE(this%dativar%d)
6359 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
6360 ENDDO
6361 ENDIF
6362
6363 IF (ASSOCIATED(this%dativar%c)) THEN
6364 DO i = 1, SIZE(this%dativar%c)
6365 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6366 ENDDO
6367 ENDIF
6368
6369 IF (ASSOCIATED(this%dativar%c)) THEN
6370 DO i = 1, SIZE(this%dativar%c)
6371 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6372 ENDDO
6373 ENDIF
6374
6375 ENDIF
6376ENDIF
6377
6378IF (PRESENT(nl)) THEN
6379 IF (SIZE(nl) > 0) THEN
6380 DO i = 1, SIZE(this%network)
6381 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
6382 ENDDO
6383 ENDIF
6384ENDIF
6385
6386IF (PRESENT(s_d)) THEN
6387 IF (c_e(s_d)) THEN
6388 WHERE (this%time < s_d)
6389 this%time = datetime_miss
6390 END WHERE
6391 ENDIF
6392ENDIF
6393
6394IF (PRESENT(e_d)) THEN
6395 IF (c_e(e_d)) THEN
6396 WHERE (this%time > e_d)
6397 this%time = datetime_miss
6398 END WHERE
6399 ENDIF
6400ENDIF
6401
6402CALL vol7d_reform(this, miss=.true.)
6403
6404END SUBROUTINE vol7d_filter
6405
6406
6407!> Metodo per convertire i volumi di dati di un oggetto vol7d in dati
6408!! reali dove possibile. L'oggetto convertito è una copia completa
6409!! dell'originale che può essere quindi distrutto dopo la chiamata.
6410!! Per i dati di anagrafica, al momento sono convertiti solo
6411!! i dati CHARACTER se è passato \a anaconv=.TRUE.
6412!! Gli attributi non sono toccati.
6413SUBROUTINE vol7d_convr(this, that, anaconv)
6414TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
6415TYPE(vol7d),INTENT(INOUT) :: that !< oggetto convertito
6416LOGICAL,OPTIONAL,INTENT(in) :: anaconv !< converti anche anagrafica
6417INTEGER :: i
6418LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
6419TYPE(vol7d) :: v7d_tmp
6420
6421IF (optio_log(anaconv)) THEN
6422 acp=fv
6423 acn=tv
6424ELSE
6425 acp=tv
6426 acn=fv
6427ENDIF
6428
6429! Volume con solo i dati reali e tutti gli attributi
6430! l'anagrafica e` copiata interamente se necessario
6431CALL vol7d_copy(this, that, &
6432 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
6433 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
6434
6435! Volume solo di dati double
6436CALL vol7d_copy(this, v7d_tmp, &
6437 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
6438 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6439 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6440 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
6441 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6442 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6443
6444! converto a dati reali
6445IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
6446
6447 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
6448! alloco i dati reali e vi trasferisco i double
6449 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
6450 SIZE(v7d_tmp%volanad, 3)))
6451 DO i = 1, SIZE(v7d_tmp%anavar%d)
6452 v7d_tmp%volanar(:,i,:) = &
6453 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
6454 ENDDO
6455 DEALLOCATE(v7d_tmp%volanad)
6456! trasferisco le variabili
6457 v7d_tmp%anavar%r => v7d_tmp%anavar%d
6458 NULLIFY(v7d_tmp%anavar%d)
6459 ENDIF
6460
6461 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
6462! alloco i dati reali e vi trasferisco i double
6463 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
6464 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
6465 SIZE(v7d_tmp%voldatid, 6)))
6466 DO i = 1, SIZE(v7d_tmp%dativar%d)
6467 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6468 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
6469 ENDDO
6470 DEALLOCATE(v7d_tmp%voldatid)
6471! trasferisco le variabili
6472 v7d_tmp%dativar%r => v7d_tmp%dativar%d
6473 NULLIFY(v7d_tmp%dativar%d)
6474 ENDIF
6475
6476! fondo con il volume definitivo
6477 CALL vol7d_merge(that, v7d_tmp)
6478ELSE
6479 CALL delete(v7d_tmp)
6480ENDIF
6481
6482
6483! Volume solo di dati interi
6484CALL vol7d_copy(this, v7d_tmp, &
6485 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
6486 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6487 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6488 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
6489 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6490 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6491
6492! converto a dati reali
6493IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
6494
6495 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
6496! alloco i dati reali e vi trasferisco gli interi
6497 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
6498 SIZE(v7d_tmp%volanai, 3)))
6499 DO i = 1, SIZE(v7d_tmp%anavar%i)
6500 v7d_tmp%volanar(:,i,:) = &
6501 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
6502 ENDDO
6503 DEALLOCATE(v7d_tmp%volanai)
6504! trasferisco le variabili
6505 v7d_tmp%anavar%r => v7d_tmp%anavar%i
6506 NULLIFY(v7d_tmp%anavar%i)
6507 ENDIF
6508
6509 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
6510! alloco i dati reali e vi trasferisco gli interi
6511 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
6512 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
6513 SIZE(v7d_tmp%voldatii, 6)))
6514 DO i = 1, SIZE(v7d_tmp%dativar%i)
6515 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6516 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
6517 ENDDO
6518 DEALLOCATE(v7d_tmp%voldatii)
6519! trasferisco le variabili
6520 v7d_tmp%dativar%r => v7d_tmp%dativar%i
6521 NULLIFY(v7d_tmp%dativar%i)
6522 ENDIF
6523
6524! fondo con il volume definitivo
6525 CALL vol7d_merge(that, v7d_tmp)
6526ELSE
6527 CALL delete(v7d_tmp)
6528ENDIF
6529
6530
6531! Volume solo di dati byte
6532CALL vol7d_copy(this, v7d_tmp, &
6533 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
6534 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6535 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6536 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
6537 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6538 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6539
6540! converto a dati reali
6541IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
6542
6543 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
6544! alloco i dati reali e vi trasferisco i byte
6545 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
6546 SIZE(v7d_tmp%volanab, 3)))
6547 DO i = 1, SIZE(v7d_tmp%anavar%b)
6548 v7d_tmp%volanar(:,i,:) = &
6549 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
6550 ENDDO
6551 DEALLOCATE(v7d_tmp%volanab)
6552! trasferisco le variabili
6553 v7d_tmp%anavar%r => v7d_tmp%anavar%b
6554 NULLIFY(v7d_tmp%anavar%b)
6555 ENDIF
6556
6557 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
6558! alloco i dati reali e vi trasferisco i byte
6559 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
6560 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
6561 SIZE(v7d_tmp%voldatib, 6)))
6562 DO i = 1, SIZE(v7d_tmp%dativar%b)
6563 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6564 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
6565 ENDDO
6566 DEALLOCATE(v7d_tmp%voldatib)
6567! trasferisco le variabili
6568 v7d_tmp%dativar%r => v7d_tmp%dativar%b
6569 NULLIFY(v7d_tmp%dativar%b)
6570 ENDIF
6571
6572! fondo con il volume definitivo
6573 CALL vol7d_merge(that, v7d_tmp)
6574ELSE
6575 CALL delete(v7d_tmp)
6576ENDIF
6577
6578
6579! Volume solo di dati character
6580CALL vol7d_copy(this, v7d_tmp, &
6581 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
6582 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
6583 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
6584 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
6585 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
6586 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
6587
6588! converto a dati reali
6589IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
6590
6591 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
6592! alloco i dati reali e vi trasferisco i character
6593 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
6594 SIZE(v7d_tmp%volanac, 3)))
6595 DO i = 1, SIZE(v7d_tmp%anavar%c)
6596 v7d_tmp%volanar(:,i,:) = &
6597 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
6598 ENDDO
6599 DEALLOCATE(v7d_tmp%volanac)
6600! trasferisco le variabili
6601 v7d_tmp%anavar%r => v7d_tmp%anavar%c
6602 NULLIFY(v7d_tmp%anavar%c)
6603 ENDIF
6604
6605 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
6606! alloco i dati reali e vi trasferisco i character
6607 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
6608 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
6609 SIZE(v7d_tmp%voldatic, 6)))
6610 DO i = 1, SIZE(v7d_tmp%dativar%c)
6611 v7d_tmp%voldatir(:,:,:,:,i,:) = &
6612 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
6613 ENDDO
6614 DEALLOCATE(v7d_tmp%voldatic)
6615! trasferisco le variabili
6616 v7d_tmp%dativar%r => v7d_tmp%dativar%c
6617 NULLIFY(v7d_tmp%dativar%c)
6618 ENDIF
6619
6620! fondo con il volume definitivo
6621 CALL vol7d_merge(that, v7d_tmp)
6622ELSE
6623 CALL delete(v7d_tmp)
6624ENDIF
6625
6626END SUBROUTINE vol7d_convr
6627
6628
6629!> Metodo per ottenere solo le differenze tra due oggetti vol7d.
6630!! Il primo volume viene confrontato col secondo; nel secondo volume ovunque
6631!! i dati confrontati siano coincidenti viene impostato valore mancante.
6632SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
6633TYPE(vol7d),INTENT(IN) :: this !< primo volume da confrontare
6634TYPE(vol7d),INTENT(OUT) :: that !< secondo volume da confrontare in cui eliminare i dati coincidenti
6635logical , optional, intent(in) :: data_only !< attiva l'elaborazione dei soli dati e non dell'anagrafica (default: .false.)
6636logical , optional, intent(in) :: ana !< attiva l'elaborazione dell'anagrafica (coordinate e ident) (default: .false.)
6637logical :: ldata_only,lana
6638
6639IF (PRESENT(data_only)) THEN
6640 ldata_only = data_only
6641ELSE
6642 ldata_only = .false.
6643ENDIF
6644
6645IF (PRESENT(ana)) THEN
6646 lana = ana
6647ELSE
6648 lana = .false.
6649ENDIF
6650
6651
6652#undef VOL7D_POLY_ARRAY
6653#define VOL7D_POLY_ARRAY voldati
6654#include "vol7d_class_diff.F90"
6655#undef VOL7D_POLY_ARRAY
6656#define VOL7D_POLY_ARRAY voldatiattr
6657#include "vol7d_class_diff.F90"
6658#undef VOL7D_POLY_ARRAY
6659
6660if ( .not. ldata_only) then
6661
6662#define VOL7D_POLY_ARRAY volana
6663#include "vol7d_class_diff.F90"
6664#undef VOL7D_POLY_ARRAY
6665#define VOL7D_POLY_ARRAY volanaattr
6666#include "vol7d_class_diff.F90"
6667#undef VOL7D_POLY_ARRAY
6668
6669 if(lana)then
6670 where ( this%ana == that%ana )
6671 that%ana = vol7d_ana_miss
6672 end where
6673 end if
6674
6675end if
6676
6677
6678
6679END SUBROUTINE vol7d_diff_only
6680
6681
6682
6683! Creo le routine da ripetere per i vari tipi di dati di v7d
6684! tramite un template e il preprocessore
6685#undef VOL7D_POLY_TYPE
6686#undef VOL7D_POLY_TYPES
6687#define VOL7D_POLY_TYPE REAL
6688#define VOL7D_POLY_TYPES r
6689#include "vol7d_class_type_templ.F90"
6690#undef VOL7D_POLY_TYPE
6691#undef VOL7D_POLY_TYPES
6692#define VOL7D_POLY_TYPE DOUBLE PRECISION
6693#define VOL7D_POLY_TYPES d
6694#include "vol7d_class_type_templ.F90"
6695#undef VOL7D_POLY_TYPE
6696#undef VOL7D_POLY_TYPES
6697#define VOL7D_POLY_TYPE INTEGER
6698#define VOL7D_POLY_TYPES i
6699#include "vol7d_class_type_templ.F90"
6700#undef VOL7D_POLY_TYPE
6701#undef VOL7D_POLY_TYPES
6702#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
6703#define VOL7D_POLY_TYPES b
6704#include "vol7d_class_type_templ.F90"
6705#undef VOL7D_POLY_TYPE
6706#undef VOL7D_POLY_TYPES
6707#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
6708#define VOL7D_POLY_TYPES c
6709#include "vol7d_class_type_templ.F90"
6710
6711! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
6712! tramite un template e il preprocessore
6713#define VOL7D_SORT
6714#undef VOL7D_NO_ZERO_ALLOC
6715#undef VOL7D_POLY_TYPE
6716#define VOL7D_POLY_TYPE datetime
6717#include "vol7d_class_desc_templ.F90"
6718#undef VOL7D_POLY_TYPE
6719#define VOL7D_POLY_TYPE vol7d_timerange
6720#include "vol7d_class_desc_templ.F90"
6721#undef VOL7D_POLY_TYPE
6722#define VOL7D_POLY_TYPE vol7d_level
6723#include "vol7d_class_desc_templ.F90"
6724#undef VOL7D_SORT
6725#undef VOL7D_POLY_TYPE
6726#define VOL7D_POLY_TYPE vol7d_network
6727#include "vol7d_class_desc_templ.F90"
6728#undef VOL7D_POLY_TYPE
6729#define VOL7D_POLY_TYPE vol7d_ana
6730#include "vol7d_class_desc_templ.F90"
6731#define VOL7D_NO_ZERO_ALLOC
6732#undef VOL7D_POLY_TYPE
6733#define VOL7D_POLY_TYPE vol7d_var
6734#include "vol7d_class_desc_templ.F90"
6735
6736!>\brief Scrittura su file di un volume Vol7d.
6737!! Scrittura su file unformatted di un intero volume Vol7d.
6738!! Il volume viene serializzato e scritto su file.
6739!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
6740!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
6741!! tali parametri saranno in output.
6742!! Se non viene fornito il nome file viene utilizzato un file di default con nome pari al nome del programma in
6743!! esecuzione con postfisso ".v7d".
6744!! Come parametro opzionale c'è la description che insieme alla data corrente viene inserita nell'header del file.
6745subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
6746
6747TYPE(vol7d),INTENT(IN) :: this !< volume vol7d da scrivere
6748integer,optional,intent(inout) :: unit !< unità su cui scrivere; se passata =0 ritorna il valore rielaborato (default =rielaborato internamente con getlun )
6749character(len=*),intent(in),optional :: filename !< nome del file su cui scrivere
6750character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
6751character(len=*),INTENT(IN),optional :: description !< descrizione del volume
6752
6753integer :: lunit
6754character(len=254) :: ldescription,arg,lfilename
6755integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
6756 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6757 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6758 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6759 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6760 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6761 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
6762!integer :: im,id,iy
6763integer :: tarray(8)
6764logical :: opened,exist
6765
6766 nana=0
6767 ntime=0
6768 ntimerange=0
6769 nlevel=0
6770 nnetwork=0
6771 ndativarr=0
6772 ndativari=0
6773 ndativarb=0
6774 ndativard=0
6775 ndativarc=0
6776 ndatiattrr=0
6777 ndatiattri=0
6778 ndatiattrb=0
6779 ndatiattrd=0
6780 ndatiattrc=0
6781 ndativarattrr=0
6782 ndativarattri=0
6783 ndativarattrb=0
6784 ndativarattrd=0
6785 ndativarattrc=0
6786 nanavarr=0
6787 nanavari=0
6788 nanavarb=0
6789 nanavard=0
6790 nanavarc=0
6791 nanaattrr=0
6792 nanaattri=0
6793 nanaattrb=0
6794 nanaattrd=0
6795 nanaattrc=0
6796 nanavarattrr=0
6797 nanavarattri=0
6798 nanavarattrb=0
6799 nanavarattrd=0
6800 nanavarattrc=0
6801
6802
6803!call idate(im,id,iy)
6804call date_and_time(values=tarray)
6805call getarg(0,arg)
6806
6807if (present(description))then
6808 ldescription=description
6809else
6810 ldescription="Vol7d generated by: "//trim(arg)
6811end if
6812
6813if (.not. present(unit))then
6814 lunit=getunit()
6815else
6816 if (unit==0)then
6817 lunit=getunit()
6818 unit=lunit
6819 else
6820 lunit=unit
6821 end if
6822end if
6823
6824lfilename=trim(arg)//".v7d"
6825if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
6826
6827if (present(filename))then
6828 if (filename /= "")then
6829 lfilename=filename
6830 end if
6831end if
6832
6833if (present(filename_auto))filename_auto=lfilename
6834
6835
6836inquire(unit=lunit,opened=opened)
6837if (.not. opened) then
6838! inquire(file=lfilename, EXIST=exist)
6839! IF (exist) THEN
6840! CALL l4f_log(L4F_FATAL, &
6841! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
6842! CALL raise_fatal_error()
6843! ENDIF
6844 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
6845 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
6846end if
6847
6848if (associated(this%ana)) nana=size(this%ana)
6849if (associated(this%time)) ntime=size(this%time)
6850if (associated(this%timerange)) ntimerange=size(this%timerange)
6851if (associated(this%level)) nlevel=size(this%level)
6852if (associated(this%network)) nnetwork=size(this%network)
6853
6854if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
6855if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
6856if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
6857if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
6858if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
6859
6860if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
6861if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
6862if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
6863if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
6864if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
6865
6866if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
6867if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
6868if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
6869if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
6870if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
6871
6872if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
6873if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
6874if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
6875if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
6876if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
6877
6878if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
6879if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
6880if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
6881if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
6882if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
6883
6884if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
6885if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
6886if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
6887if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
6888if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
6889
6890write(unit=lunit)ldescription
6891write(unit=lunit)tarray
6892
6893write(unit=lunit)&
6894 nana, ntime, ntimerange, nlevel, nnetwork, &
6895 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
6896 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
6897 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
6898 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
6899 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
6900 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
6901 this%time_definition
6902
6903
6904!write(unit=lunit)this
6905
6906
6907!! prime 5 dimensioni
6908if (associated(this%ana)) call write_unit(this%ana, lunit)
6909if (associated(this%time)) call write_unit(this%time, lunit)
6910if (associated(this%level)) write(unit=lunit)this%level
6911if (associated(this%timerange)) write(unit=lunit)this%timerange
6912if (associated(this%network)) write(unit=lunit)this%network
6913
6914 !! 6a dimensione: variabile dell'anagrafica e dei dati
6915 !! con relativi attributi e in 5 tipi diversi
6916
6917if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
6918if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
6919if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
6920if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
6921if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
6922
6923if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
6924if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
6925if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
6926if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
6927if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
6928
6929if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
6930if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
6931if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
6932if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
6933if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
6934
6935if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
6936if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
6937if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
6938if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
6939if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
6940
6941if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
6942if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
6943if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
6944if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
6945if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
6946
6947if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
6948if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
6949if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
6950if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
6951if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
6952
6953!! Volumi di valori e attributi per anagrafica e dati
6954
6955if (associated(this%volanar)) write(unit=lunit)this%volanar
6956if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
6957if (associated(this%voldatir)) write(unit=lunit)this%voldatir
6958if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
6959
6960if (associated(this%volanai)) write(unit=lunit)this%volanai
6961if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
6962if (associated(this%voldatii)) write(unit=lunit)this%voldatii
6963if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
6964
6965if (associated(this%volanab)) write(unit=lunit)this%volanab
6966if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
6967if (associated(this%voldatib)) write(unit=lunit)this%voldatib
6968if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
6969
6970if (associated(this%volanad)) write(unit=lunit)this%volanad
6971if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
6972if (associated(this%voldatid)) write(unit=lunit)this%voldatid
6973if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
6974
6975if (associated(this%volanac)) write(unit=lunit)this%volanac
6976if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
6977if (associated(this%voldatic)) write(unit=lunit)this%voldatic
6978if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
6979
6980if (.not. present(unit)) close(unit=lunit)
6981
6982end subroutine vol7d_write_on_file
6983
6984
6985!>\brief Lettura da file di un volume Vol7d.
6986!! Lettura da file unformatted di un intero volume Vol7d.
6987!! Questa subroutine comprende vol7d_alloc e vol7d_alloc_vol.
6988!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
6989!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
6990!! tali parametri saranno in output.
6991
6992
6993subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
6994
6995TYPE(vol7d),INTENT(OUT) :: this !< Volume vol7d da leggere
6996integer,intent(inout),optional :: unit !< unità su cui è stato aperto un file; se =0 rielaborato internamente (default = elaborato internamente con getunit)
6997character(len=*),INTENT(in),optional :: filename !< nome del file eventualmente da aprire (default = (nome dell'eseguibile)//.v7d )
6998character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
6999character(len=*),INTENT(out),optional :: description !< descrizione del volume letto
7000integer,intent(out),optional :: tarray(8) !< vettore come definito da "date_and_time" della data di scrittura del volume
7001
7002
7003integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7004 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7005 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7006 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7007 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7008 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7009 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7010
7011character(len=254) :: ldescription,lfilename,arg
7012integer :: ltarray(8),lunit,ios
7013logical :: opened,exist
7014
7015
7016call getarg(0,arg)
7017
7018if (.not. present(unit))then
7019 lunit=getunit()
7020else
7021 if (unit==0)then
7022 lunit=getunit()
7023 unit=lunit
7024 else
7025 lunit=unit
7026 end if
7027end if
7028
7029lfilename=trim(arg)//".v7d"
7030if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
7031
7032if (present(filename))then
7033 if (filename /= "")then
7034 lfilename=filename
7035 end if
7036end if
7037
7038if (present(filename_auto))filename_auto=lfilename
7039
7040
7041inquire(unit=lunit,opened=opened)
7042IF (.NOT. opened) THEN
7043 inquire(file=lfilename,exist=exist)
7044 IF (.NOT.exist) THEN
7045 CALL l4f_log(l4f_fatal, &
7046 'in vol7d_read_from_file, file does not exists, cannot open')
7047 CALL raise_fatal_error()
7048 ENDIF
7049 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
7050 status='OLD', action='READ')
7051 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7052end if
7053
7054
7055call init(this)
7056read(unit=lunit,iostat=ios)ldescription
7057
7058if (ios < 0) then ! A negative value indicates that the End of File or End of Record
7059 call vol7d_alloc (this)
7060 call vol7d_alloc_vol (this)
7061 if (present(description))description=ldescription
7062 if (present(tarray))tarray=ltarray
7063 if (.not. present(unit)) close(unit=lunit)
7064end if
7065
7066read(unit=lunit)ltarray
7067
7068CALL l4f_log(l4f_info, 'Reading vol7d from file')
7069CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
7070CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
7071 trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
7072
7073if (present(description))description=ldescription
7074if (present(tarray))tarray=ltarray
7075
7076read(unit=lunit)&
7077 nana, ntime, ntimerange, nlevel, nnetwork, &
7078 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7079 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7080 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7081 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7082 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7083 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7084 this%time_definition
7085
7086call vol7d_alloc (this, &
7087 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
7088 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
7089 ndativard=ndativard, ndativarc=ndativarc,&
7090 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
7091 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
7092 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
7093 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
7094 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
7095 nanavard=nanavard, nanavarc=nanavarc,&
7096 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
7097 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
7098 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7099 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7100
7101
7102if (associated(this%ana)) call read_unit(this%ana, lunit)
7103if (associated(this%time)) call read_unit(this%time, lunit)
7104if (associated(this%level)) read(unit=lunit)this%level
7105if (associated(this%timerange)) read(unit=lunit)this%timerange
7106if (associated(this%network)) read(unit=lunit)this%network
7107
7108if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7109if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7110if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7111if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7112if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7113
7114if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7115if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7116if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7117if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7118if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7119
7120if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7121if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7122if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7123if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7124if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7125
7126if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7127if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7128if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7129if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7130if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7131
7132if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7133if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7134if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7135if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7136if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7137
7138if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7139if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7140if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7141if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7142if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7143
7144call vol7d_alloc_vol (this)
7145
7146!! Volumi di valori e attributi per anagrafica e dati
7147
7148if (associated(this%volanar)) read(unit=lunit)this%volanar
7149if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7150if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7151if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7152
7153if (associated(this%volanai)) read(unit=lunit)this%volanai
7154if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7155if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7156if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7157
7158if (associated(this%volanab)) read(unit=lunit)this%volanab
7159if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7160if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7161if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7162
7163if (associated(this%volanad)) read(unit=lunit)this%volanad
7164if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7165if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7166if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7167
7168if (associated(this%volanac)) read(unit=lunit)this%volanac
7169if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7170if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7171if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7172
7173if (.not. present(unit)) close(unit=lunit)
7174
7175end subroutine vol7d_read_from_file
7176
7177
7178! to double precision
7179elemental doubleprecision function doubledatd(voldat,var)
7180doubleprecision,intent(in) :: voldat
7181type(vol7d_var),intent(in) :: var
7182
7183doubledatd=voldat
7184
7185end function doubledatd
7186
7187
7188elemental doubleprecision function doubledatr(voldat,var)
7189real,intent(in) :: voldat
7190type(vol7d_var),intent(in) :: var
7191
7192if (c_e(voldat))then
7193 doubledatr=dble(voldat)
7194else
7195 doubledatr=dmiss
7196end if
7197
7198end function doubledatr
7199
7200
7201elemental doubleprecision function doubledati(voldat,var)
7202integer,intent(in) :: voldat
7203type(vol7d_var),intent(in) :: var
7204
7205if (c_e(voldat)) then
7206 if (c_e(var%scalefactor))then
7207 doubledati=dble(voldat)/10.d0**var%scalefactor
7208 else
7209 doubledati=dble(voldat)
7210 endif
7211else
7212 doubledati=dmiss
7213end if
7214
7215end function doubledati
7216
7217
7218elemental doubleprecision function doubledatb(voldat,var)
7219integer(kind=int_b),intent(in) :: voldat
7220type(vol7d_var),intent(in) :: var
7221
7222if (c_e(voldat)) then
7223 if (c_e(var%scalefactor))then
7224 doubledatb=dble(voldat)/10.d0**var%scalefactor
7225 else
7226 doubledatb=dble(voldat)
7227 endif
7228else
7229 doubledatb=dmiss
7230end if
7231
7232end function doubledatb
7233
7234
7235elemental doubleprecision function doubledatc(voldat,var)
7236CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7237type(vol7d_var),intent(in) :: var
7238
7239doubledatc = c2d(voldat)
7240if (c_e(doubledatc) .and. c_e(var%scalefactor))then
7241 doubledatc=doubledatc/10.d0**var%scalefactor
7242end if
7243
7244end function doubledatc
7245
7246
7247! to integer
7248elemental integer function integerdatd(voldat,var)
7249doubleprecision,intent(in) :: voldat
7250type(vol7d_var),intent(in) :: var
7251
7252if (c_e(voldat))then
7253 if (c_e(var%scalefactor)) then
7254 integerdatd=nint(voldat*10d0**var%scalefactor)
7255 else
7256 integerdatd=nint(voldat)
7257 endif
7258else
7259 integerdatd=imiss
7260end if
7261
7262end function integerdatd
7263
7264
7265elemental integer function integerdatr(voldat,var)
7266real,intent(in) :: voldat
7267type(vol7d_var),intent(in) :: var
7268
7269if (c_e(voldat))then
7270 if (c_e(var%scalefactor)) then
7271 integerdatr=nint(voldat*10d0**var%scalefactor)
7272 else
7273 integerdatr=nint(voldat)
7274 endif
7275else
7276 integerdatr=imiss
7277end if
7278
7279end function integerdatr
7280
7281
7282elemental integer function integerdati(voldat,var)
7283integer,intent(in) :: voldat
7284type(vol7d_var),intent(in) :: var
7285
7286integerdati=voldat
7287
7288end function integerdati
7289
7290
7291elemental integer function integerdatb(voldat,var)
7292integer(kind=int_b),intent(in) :: voldat
7293type(vol7d_var),intent(in) :: var
7294
7295if (c_e(voldat))then
7296 integerdatb=voldat
7297else
7298 integerdatb=imiss
7299end if
7300
7301end function integerdatb
7302
7303
7304elemental integer function integerdatc(voldat,var)
7305CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7306type(vol7d_var),intent(in) :: var
7307
7308integerdatc=c2i(voldat)
7309
7310end function integerdatc
7311
7312
7313! to real
7314elemental real function realdatd(voldat,var)
7315doubleprecision,intent(in) :: voldat
7316type(vol7d_var),intent(in) :: var
7317
7318if (c_e(voldat))then
7319 realdatd=real(voldat)
7320else
7321 realdatd=rmiss
7322end if
7323
7324end function realdatd
7325
7326
7327elemental real function realdatr(voldat,var)
7328real,intent(in) :: voldat
7329type(vol7d_var),intent(in) :: var
7330
7331realdatr=voldat
7332
7333end function realdatr
7334
7335
7336elemental real function realdati(voldat,var)
7337integer,intent(in) :: voldat
7338type(vol7d_var),intent(in) :: var
7339
7340if (c_e(voldat)) then
7341 if (c_e(var%scalefactor))then
7342 realdati=float(voldat)/10.**var%scalefactor
7343 else
7344 realdati=float(voldat)
7345 endif
7346else
7347 realdati=rmiss
7348end if
7349
7350end function realdati
7351
7352
7353elemental real function realdatb(voldat,var)
7354integer(kind=int_b),intent(in) :: voldat
7355type(vol7d_var),intent(in) :: var
7356
7357if (c_e(voldat)) then
7358 if (c_e(var%scalefactor))then
7359 realdatb=float(voldat)/10**var%scalefactor
7360 else
7361 realdatb=float(voldat)
7362 endif
7363else
7364 realdatb=rmiss
7365end if
7366
7367end function realdatb
7368
7369
7370elemental real function realdatc(voldat,var)
7371CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7372type(vol7d_var),intent(in) :: var
7373
7374realdatc=c2r(voldat)
7375if (c_e(realdatc) .and. c_e(var%scalefactor))then
7376 realdatc=realdatc/10.**var%scalefactor
7377end if
7378
7379end function realdatc
7380
7381
7382!> Return an ana volume of a requested variable as real data.
7383!! It returns a 2-d array of the proper shape (ana x network) for the
7384!! ana variable requested, converted to real type. If the conversion
7385!! fails or if the variable is not contained in the ana volume,
7386!! missing data are returned.
7387FUNCTION realanavol(this, var) RESULT(vol)
7388TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
7389TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
7390REAL :: vol(SIZE(this%ana),size(this%network))
7391
7392CHARACTER(len=1) :: dtype
7393INTEGER :: indvar
7394
7395dtype = cmiss
7396indvar = index(this%anavar, var, type=dtype)
7397
7398IF (indvar > 0) THEN
7399 SELECT CASE (dtype)
7400 CASE("d")
7401 vol = realdat(this%volanad(:,indvar,:), var)
7402 CASE("r")
7403 vol = this%volanar(:,indvar,:)
7404 CASE("i")
7405 vol = realdat(this%volanai(:,indvar,:), var)
7406 CASE("b")
7407 vol = realdat(this%volanab(:,indvar,:), var)
7408 CASE("c")
7409 vol = realdat(this%volanac(:,indvar,:), var)
7410 CASE default
7411 vol = rmiss
7412 END SELECT
7413ELSE
7414 vol = rmiss
7415ENDIF
7416
7417END FUNCTION realanavol
7418
7419
7420!> Return an ana volume of a requested variable as integer data.
7421!! It returns a 2-d array of the proper shape (ana x network) for the
7422!! ana variable requested, converted to integer type. If the conversion
7423!! fails or if the variable is not contained in the ana volume,
7424!! missing data are returned.
7425FUNCTION integeranavol(this, var) RESULT(vol)
7426TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
7427TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
7428INTEGER :: vol(SIZE(this%ana),size(this%network))
7429
7430CHARACTER(len=1) :: dtype
7431INTEGER :: indvar
7432
7433dtype = cmiss
7434indvar = index(this%anavar, var, type=dtype)
7435
7436IF (indvar > 0) THEN
7437 SELECT CASE (dtype)
7438 CASE("d")
7439 vol = integerdat(this%volanad(:,indvar,:), var)
7440 CASE("r")
7441 vol = integerdat(this%volanar(:,indvar,:), var)
7442 CASE("i")
7443 vol = this%volanai(:,indvar,:)
7444 CASE("b")
7445 vol = integerdat(this%volanab(:,indvar,:), var)
7446 CASE("c")
7447 vol = integerdat(this%volanac(:,indvar,:), var)
7448 CASE default
7449 vol = imiss
7450 END SELECT
7451ELSE
7452 vol = imiss
7453ENDIF
7454
7455END FUNCTION integeranavol
7456
7457
7458!> Move data for all variables from one coordinate in the character volume to other.
7459!! Only not missing data will be copyed and all attributes will be moved together.
7460!! Usefull to colapse data spread in more indices (level or time or ....).
7461!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
7462!! to obtain a new vol7d with less data shape.
7463subroutine move_datac (v7d,&
7464 indana,indtime,indlevel,indtimerange,indnetwork,&
7465 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7466
7467TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
7468
7469integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
7470integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
7471integer :: inddativar,inddativarattr
7472
7473
7474do inddativar=1,size(v7d%dativar%c)
7475
7476 if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
7477 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7478 ) then
7479
7480 ! dati
7481 v7d%voldatic &
7482 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7483 v7d%voldatic &
7484 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7485
7486
7487 ! attributi
7488 if (associated (v7d%dativarattr%i)) then
7489 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
7490 if (inddativarattr > 0 ) then
7491 v7d%voldatiattri &
7492 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7493 v7d%voldatiattri &
7494 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7495 end if
7496 end if
7497
7498 if (associated (v7d%dativarattr%r)) then
7499 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
7500 if (inddativarattr > 0 ) then
7501 v7d%voldatiattrr &
7502 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7503 v7d%voldatiattrr &
7504 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7505 end if
7506 end if
7507
7508 if (associated (v7d%dativarattr%d)) then
7509 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
7510 if (inddativarattr > 0 ) then
7511 v7d%voldatiattrd &
7512 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7513 v7d%voldatiattrd &
7514 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7515 end if
7516 end if
7517
7518 if (associated (v7d%dativarattr%b)) then
7519 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
7520 if (inddativarattr > 0 ) then
7521 v7d%voldatiattrb &
7522 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7523 v7d%voldatiattrb &
7524 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7525 end if
7526 end if
7527
7528 if (associated (v7d%dativarattr%c)) then
7529 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
7530 if (inddativarattr > 0 ) then
7531 v7d%voldatiattrc &
7532 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7533 v7d%voldatiattrc &
7534 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7535 end if
7536 end if
7537
7538 end if
7539
7540end do
7541
7542end subroutine move_datac
7543
7544!> Move data for all variables from one coordinate in the real volume to other.
7545!! Only not missing data will be copyed and all attributes will be moved together.
7546!! Usefull to colapse data spread in more indices (level or time or ....).
7547!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
7548!! to obtain a new vol7d with less data shape.
7549subroutine move_datar (v7d,&
7550 indana,indtime,indlevel,indtimerange,indnetwork,&
7551 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
7552
7553TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
7554
7555integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
7556integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
7557integer :: inddativar,inddativarattr
7558
7559
7560do inddativar=1,size(v7d%dativar%r)
7561
7562 if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
7563 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
7564 ) then
7565
7566 ! dati
7567 v7d%voldatir &
7568 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
7569 v7d%voldatir &
7570 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
7571
7572
7573 ! attributi
7574 if (associated (v7d%dativarattr%i)) then
7575 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
7576 if (inddativarattr > 0 ) then
7577 v7d%voldatiattri &
7578 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7579 v7d%voldatiattri &
7580 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7581 end if
7582 end if
7583
7584 if (associated (v7d%dativarattr%r)) then
7585 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
7586 if (inddativarattr > 0 ) then
7587 v7d%voldatiattrr &
7588 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7589 v7d%voldatiattrr &
7590 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7591 end if
7592 end if
7593
7594 if (associated (v7d%dativarattr%d)) then
7595 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
7596 if (inddativarattr > 0 ) then
7597 v7d%voldatiattrd &
7598 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7599 v7d%voldatiattrd &
7600 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7601 end if
7602 end if
7603
7604 if (associated (v7d%dativarattr%b)) then
7605 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
7606 if (inddativarattr > 0 ) then
7607 v7d%voldatiattrb &
7608 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7609 v7d%voldatiattrb &
7610 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7611 end if
7612 end if
7613
7614 if (associated (v7d%dativarattr%c)) then
7615 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
7616 if (inddativarattr > 0 ) then
7617 v7d%voldatiattrc &
7618 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
7619 v7d%voldatiattrc &
7620 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
7621 end if
7622 end if
7623
7624 end if
7625
7626end do
7627
7628end subroutine move_datar
7629
7630
7631!> Reduce some dimensions (level and timerage) for semplification (rounding).
7632!! You can use this for simplify and use variables in computation like alchimia
7633!! where fields have to be on the same coordinate
7634!! It return real or character data only: if input is charcter data only it return character otherwise il return
7635!! all the data converted to real.
7636!! examples:
7637!! means in time for short periods and istantaneous values
7638!! 2 meter and surface levels
7639!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
7640!! will be taken (order is by icreasing var index).
7641!! You can use predefined values for classic semplification
7642!! almost_equal_levels and almost_equal_timeranges
7643!! The level or timerange in output will be defined by the first element of level and timerange list
7644subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
7645type(vol7d),intent(inout) :: v7din !< input volume
7646type(vol7d),intent(out) :: v7dout !> output volume
7647type(vol7d_level),intent(in),optional :: level(:) !< almost equal level list
7648type(vol7d_timerange),intent(in),optional :: timerange(:) !< almost equal timerange list
7649!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
7650!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
7651logical,intent(in),optional :: nostatproc !< do not take in account statistical processing code in timerange and P2
7652
7653integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
7654integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
7655type(vol7d_level) :: roundlevel(size(v7din%level))
7656type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
7657type(vol7d) :: v7d_tmp
7658
7659
7660nbin=0
7661
7662if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
7663if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
7664if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
7665if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
7666
7667call init(v7d_tmp)
7668
7669roundlevel=v7din%level
7670
7671if (present(level))then
7672 do ilevel = 1, size(v7din%level)
7673 if ((any(v7din%level(ilevel) .almosteq. level))) then
7674 roundlevel(ilevel)=level(1)
7675 end if
7676 end do
7677end if
7678
7679roundtimerange=v7din%timerange
7680
7681if (present(timerange))then
7682 do itimerange = 1, size(v7din%timerange)
7683 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
7684 roundtimerange(itimerange)=timerange(1)
7685 end if
7686 end do
7687end if
7688
7689!set istantaneous values everywere
7690!preserve p1 for forecast time
7691if (optio_log(nostatproc)) then
7692 roundtimerange(:)%timerange=254
7693 roundtimerange(:)%p2=0
7694end if
7695
7696
7697nana=size(v7din%ana)
7698nlevel=count_distinct(roundlevel,back=.true.)
7699ntime=size(v7din%time)
7700ntimerange=count_distinct(roundtimerange,back=.true.)
7701nnetwork=size(v7din%network)
7702
7703call init(v7d_tmp)
7704
7705if (nbin == 0) then
7706 call copy(v7din,v7d_tmp)
7707else
7708 call vol7d_convr(v7din,v7d_tmp)
7709end if
7710
7711v7d_tmp%level=roundlevel
7712v7d_tmp%timerange=roundtimerange
7713
7714do ilevel=1, size(v7d_tmp%level)
7715 indl=index(v7d_tmp%level,roundlevel(ilevel))
7716 do itimerange=1,size(v7d_tmp%timerange)
7717 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
7718
7719 if (indl /= ilevel .or. indt /= itimerange) then
7720
7721 do iana=1, nana
7722 do itime=1,ntime
7723 do inetwork=1,nnetwork
7724
7725 if (nbin > 0) then
7726 call move_datar (v7d_tmp,&
7727 iana,itime,ilevel,itimerange,inetwork,&
7728 iana,itime,indl,indt,inetwork)
7729 else
7730 call move_datac (v7d_tmp,&
7731 iana,itime,ilevel,itimerange,inetwork,&
7732 iana,itime,indl,indt,inetwork)
7733 end if
7734
7735 end do
7736 end do
7737 end do
7738
7739 end if
7740
7741 end do
7742end do
7743
7744! set to missing level and time > nlevel
7745do ilevel=nlevel+1,size(v7d_tmp%level)
7746 call init (v7d_tmp%level(ilevel))
7747end do
7748
7749do itimerange=ntimerange+1,size(v7d_tmp%timerange)
7750 call init (v7d_tmp%timerange(itimerange))
7751end do
7752
7753!copy with remove
7754CALL copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
7755CALL delete(v7d_tmp)
7756
7757!call display(v7dout)
7758
7759end subroutine v7d_rounding
7760
7761
7762END MODULE vol7d_class
7763
7764!>\example esempio_qc_convert.f90
7765!!\brief Programma esempio semplice per la scrittura su file di un volume vol7d
7766!!
7767!!Programma che scrive su file un volume vol7d letto da una serie di file ASCII.
7768!!Questo programma scrive i dati del clima che poi verranno letti da modqccli
7769
7770
7771!>\example esempio_v7ddballe_move_and_collapse.f90
7772!!\brief ! Example program to reduce to one the dimensions of levels and time without loss of data
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 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.