libsim Versione 7.2.6

◆ vol7d_get_volanaattrd()

subroutine vol7d_get_volanaattrd ( 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 )

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

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

DOUBLE PRECISION, POINTER :: vol1d(:)
...
CALL vol7d_get_volanaattrd(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d

Definizione alla linea 4268 del file vol7d_class.F90.

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