libsim Versione 7.2.6

◆ vol7d_get_voldatii()

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

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

È 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:

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

Definizione alla linea 4997 del file vol7d_class.F90.

4999! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
5000! authors:
5001! Davide Cesari <dcesari@arpa.emr.it>
5002! Paolo Patruno <ppatruno@arpa.emr.it>
5003
5004! This program is free software; you can redistribute it and/or
5005! modify it under the terms of the GNU General Public License as
5006! published by the Free Software Foundation; either version 2 of
5007! the License, or (at your option) any later version.
5008
5009! This program is distributed in the hope that it will be useful,
5010! but WITHOUT ANY WARRANTY; without even the implied warranty of
5011! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5012! GNU General Public License for more details.
5013
5014! You should have received a copy of the GNU General Public License
5015! along with this program. If not, see <http://www.gnu.org/licenses/>.
5016#include "config.h"
5017
5018!> \defgroup vol7d Libsim package, vol7d library.
5019!! The libsim vol7d library contains classes for managing pointwise
5020!! data, tipically weather observations, and for their import from a
5021!! Db-All.e database or from a WMO BUFR file. In order to compile and
5022!! link programs using this library, you have to insert the required
5023!! \c USE statements in the program units involved, specify the
5024!! location of module files when compiling (tipically \c
5025!! -I/usr/lib/gfortran/modules or \c -I/usr/lib64/gfortran/modules or
5026!! \c -I/usr/include) and indicate the library name \c -lsim_vol7d
5027!! when linking, assuming that the library has been installed in a
5028!! default location.
5029
5030!> Classe per la gestione di un volume completo di dati osservati.
5031!! Questo modulo definisce gli oggetti e i metodi per gestire
5032!! volumi di dati meteorologici sparsi.
5033!! I volumi definiti sono principalmente di 4 categorie:
5034!! - volumi di anagrafica (vol7d::volanar & c.), hanno 3 dimensioni:
5035!! - anagrafica
5036!! - variabile di anagrafica
5037!! - rete
5038!! - volumi di attributi di anagrafica (vol7d::volanaattrr & c.), hanno 4 dimensioni:
5039!! - anagrafica
5040!! - variabile di anagrafica
5041!! - rete
5042!! - variabile di attributi delle variabili di anagrafica
5043!! - volumi di dati (vol7d::voldatir & c.), hanno 6 dimensioni:
5044!! - anagrafica
5045!! - tempo
5046!! - livello verticale
5047!! - intervallo temporale (timerange)
5048!! - variabile di dati
5049!! - rete
5050!! - volumi di attributi di dati (vol7d::voldatiattrr & c.), hanno 7 dimensioni:
5051!! - anagrafica
5052!! - tempo
5053!! - livello verticale
5054!! - intervallo temporale (timerange)
5055!! - variabile di dati
5056!! - rete
5057!! - variabile di attributi delle variabili di dati
5058!!
5059!! Tutte le variabili sono inoltre disponibil1 in 5 tipi diversi:
5060!! - reale (abbreviato r)
5061!! - doppia precisione (abbreviato d)
5062!! - intero (abbreviato i)
5063!! - byte (abbreviato b)
5064!! - carattere (abbreviato c)
5065!!
5066!! Per ognuna delle dimensioni possibili, incluse le variabili e gli
5067!! attributi con i loro diversi tipi,
5068!! è definito un cosiddetto "vettore di descrittori", con un
5069!! numero di elementi pari all'estensione della dimensione stessa,
5070!! che contiene le informazioni necessarie a descrivere
5071!! gli elementi di quella dimensione.
5072!! In realtà l'utente non dovrà generalmente occuparsi di costruire
5073!! un oggetto vol7d con le proprie mani ma utilizzerà nella maggior parte
5074!! dei casi i metodi di importazione preconfezionati che importano dati da
5075!! DB-All.e (vol7d_dballe_class) o dal DB Oracle del SIM (vol7d_oraclesim_class).
5076!!
5077!!
5078!! Il programma esempio_v7d.f90 contiene un esempio elementare di uso
5079!! della classe vol7d:
5080!! \include esempio_v7d.f90
5081!!
5082!! \ingroup vol7d
5083MODULE vol7d_class
5084USE kinds
5088USE log4fortran
5089USE err_handling
5090USE io_units
5097IMPLICIT NONE
5098
5099
5100INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
5101 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
5102
5103INTEGER, PARAMETER :: vol7d_ana_a=1 !< indice della dimensione "anagrafica" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5104INTEGER, PARAMETER :: vol7d_var_a=2 !< indice della dimensione "variabile" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5105INTEGER, PARAMETER :: vol7d_network_a=3 !< indice della dimensione "rete" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5106INTEGER, PARAMETER :: vol7d_attr_a=4 !< indice della dimensione "attributo" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5107INTEGER, PARAMETER :: vol7d_ana_d=1 !< indice della dimensione "anagrafica" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5108INTEGER, PARAMETER :: vol7d_time_d=2 !< indice della dimensione "tempo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5109INTEGER, PARAMETER :: vol7d_level_d=3 !< indice della dimensione "livello verticale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5110INTEGER, PARAMETER :: vol7d_timerange_d=4 !< indice della dimensione "intervallo temporale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5111INTEGER, PARAMETER :: vol7d_var_d=5 !< indice della dimensione "variabile" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5112INTEGER, PARAMETER :: vol7d_network_d=6 !< indice della dimensione "rete" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5113INTEGER, PARAMETER :: vol7d_attr_d=7 !< indice della dimensione "attributo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5114INTEGER, PARAMETER :: vol7d_cdatalen=32
5115
5116TYPE vol7d_varmap
5117 INTEGER :: r, d, i, b, c
5118END TYPE vol7d_varmap
5119
5120!> Definisce un oggetto contenente i volumi anagrafica e dati e tutti
5121!! i descrittori delle loro dimensioni.
5122TYPE vol7d
5123!> vettore descrittore della dimensione anagrafica
5124 TYPE(vol7d_ana),POINTER :: ana(:)
5125!> vettore descrittore della dimensione tempo
5126 TYPE(datetime),POINTER :: time(:)
5127!> vettore descrittore della dimensione livello verticale
5128 TYPE(vol7d_level),POINTER :: level(:)
5129!> vettore descrittore della dimensione intervallo temporale (timerange)
5130 TYPE(vol7d_timerange),POINTER :: timerange(:)
5131!> vettore descrittore della dimensione rete
5132 TYPE(vol7d_network),POINTER :: network(:)
5133!> vettore descrittore della dimensione variabile di anagrafica
5134 TYPE(vol7d_varvect) :: anavar
5135!> vettore descrittore della dimensione attributo delle variabili di anagrafica
5136 TYPE(vol7d_varvect) :: anaattr
5137!> vettore descrittore della dimensione variabile di anagrafica che ha tali attributi
5138 TYPE(vol7d_varvect) :: anavarattr
5139!> vettore descrittore della dimensione variabile di dati
5140 TYPE(vol7d_varvect) :: dativar
5141!> vettore descrittore della dimensione attributo delle variabili di dati
5142 TYPE(vol7d_varvect) :: datiattr
5143!> vettore descrittore della dimensione variabile di dati che ha tali attributi
5144 TYPE(vol7d_varvect) :: dativarattr
5145
5146!> volume di anagrafica a valori reali
5147 REAL,POINTER :: volanar(:,:,:)
5148!> volume di anagrafica a valori a doppia precisione
5149 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5150!> volume di anagrafica a valori interi
5151 INTEGER,POINTER :: volanai(:,:,:)
5152!> volume di anagrafica a valori byte
5153 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5154!> volume di anagrafica a valori carattere
5155 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5156
5157!> volume di attributi di anagrafica a valori reali
5158 REAL,POINTER :: volanaattrr(:,:,:,:)
5159!> volume di attributi di anagrafica a valori a doppia precisione
5160 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5161!> volume di attributi di anagrafica a valori interi
5162 INTEGER,POINTER :: volanaattri(:,:,:,:)
5163!> volume di attributi di anagrafica a valori byte
5164 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5165!> volume di attributi di anagrafica a valori carattere
5166 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5167
5168!> volume di dati a valori reali
5169 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5170!> volume di dati a valori a doppia precisione
5171 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5172!> volume di dati a valori interi
5173 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5174!> volume di dati a valori byte
5175 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5176!> volume di dati a valori carattere
5177 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5178
5179!> volume di attributi di dati a valori reali
5180 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5181!> volume di attributi di dati a valori a doppia precisione
5182 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5183!> volume di attributi di dati a valori interi
5184 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5185!> volume di attributi di dati a valori byte
5186 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5187!> volume di attributi di dati a valori carattere
5188 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5189
5190!> time definition; 0=time is reference time, 1=time is validity time
5191 integer :: time_definition
5192
5193END TYPE vol7d
5194
5195!> Costruttore per la classe vol7d.
5196!! Deve essere richiamato
5197!! per tutti gli oggetti di questo tipo definiti in un programma.
5198INTERFACE init
5199 MODULE PROCEDURE vol7d_init
5200END INTERFACE
5201
5202!> Distruttore per la classe vol7d.
5203INTERFACE delete
5204 MODULE PROCEDURE vol7d_delete
5205END INTERFACE
5206
5207!> Scrittura su file.
5208INTERFACE export
5209 MODULE PROCEDURE vol7d_write_on_file
5210END INTERFACE
5211
5212!> Lettura da file.
5213INTERFACE import
5214 MODULE PROCEDURE vol7d_read_from_file
5215END INTERFACE
5216
5217!>Print object
5218INTERFACE display
5219 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5220END INTERFACE
5221
5222!>Represent data in a pretty string
5223INTERFACE to_char
5224 MODULE PROCEDURE to_char_dat
5225END INTERFACE
5226
5227!>doubleprecision data conversion
5228INTERFACE doubledat
5229 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5230END INTERFACE
5231
5232!>real data conversion
5233INTERFACE realdat
5234 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5235END INTERFACE
5236
5237!>integer data conversion
5238INTERFACE integerdat
5239 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5240END INTERFACE
5241
5242!>copy object
5243INTERFACE copy
5244 MODULE PROCEDURE vol7d_copy
5245END INTERFACE
5246
5247!> Test for a missing volume
5248INTERFACE c_e
5249 MODULE PROCEDURE vol7d_c_e
5250END INTERFACE
5251
5252!> Check for problems
5253!! return 0 if all check passed
5254!! print diagnostics with log4f
5255INTERFACE check
5256 MODULE PROCEDURE vol7d_check
5257END INTERFACE
5258
5259!> Reduce some dimensions (level and timerage) for semplification (rounding).
5260!! You can use this for simplify and use variables in computation like alchimia
5261!! where fields have to be on the same coordinate
5262!! It return real or character data only: if input is charcter data only it return character otherwise il return
5263!! all the data converted to real.
5264!! examples:
5265!! means in time for short periods and istantaneous values
5266!! 2 meter and surface levels
5267!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
5268!! will be taken (order is by icreasing var index).
5269!! You can use predefined values for classic semplification
5270!! almost_equal_levels and almost_equal_timeranges
5271!! The level or timerange in output will be defined by the first element of level and timerange list
5272INTERFACE rounding
5273 MODULE PROCEDURE v7d_rounding
5274END INTERFACE
5275
5276!!$INTERFACE get_volana
5277!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
5278!!$ vol7d_get_volanab, vol7d_get_volanac
5279!!$END INTERFACE
5280!!$
5281!!$INTERFACE get_voldati
5282!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
5283!!$ vol7d_get_voldatib, vol7d_get_voldatic
5284!!$END INTERFACE
5285!!$
5286!!$INTERFACE get_volanaattr
5287!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
5288!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
5289!!$END INTERFACE
5290!!$
5291!!$INTERFACE get_voldatiattr
5292!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
5293!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
5294!!$END INTERFACE
5295
5296PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
5297 vol7d_get_volc, &
5298 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
5299 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
5300 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
5301 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
5302 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
5303 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
5304 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
5305 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
5306 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
5307 vol7d_display, dat_display, dat_vect_display, &
5308 to_char_dat, vol7d_check
5309
5310PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5311
5312PRIVATE vol7d_c_e
5313
5314CONTAINS
5315
5316
5317!> Inizializza un oggetto di tipo vol7d.
5318!! Non riceve alcun parametro tranne l'oggetto stesso. Attenzione, è necessario
5319!! comunque chiamare sempre il costruttore per evitare di avere dei puntatori in
5320!! uno stato indefinito.
5321SUBROUTINE vol7d_init(this,time_definition)
5322TYPE(vol7d),intent(out) :: this !< oggetto da inizializzare
5323integer,INTENT(IN),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1)
5324
5325CALL init(this%anavar)
5326CALL init(this%anaattr)
5327CALL init(this%anavarattr)
5328CALL init(this%dativar)
5329CALL init(this%datiattr)
5330CALL init(this%dativarattr)
5331CALL vol7d_var_features_init() ! initialise var features table once
5332
5333NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
5334
5335NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
5336NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
5337NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
5338NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
5339NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
5340
5341if(present(time_definition)) then
5342 this%time_definition=time_definition
5343else
5344 this%time_definition=1 !default to validity time
5345end if
5346
5347END SUBROUTINE vol7d_init
5348
5349
5350!> Distrugge l'oggetto in maniera pulita, liberando l'eventuale memoria
5351!! dinamicamente allocata. Permette di distruggere la sola parte di dati
5352!! mantenendo l'anagrafica.
5353ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
5354TYPE(vol7d),intent(inout) :: this !< oggetto da distruggere
5355LOGICAL, INTENT(in), OPTIONAL :: dataonly !< dealloca solo i dati, tenendo l'anagrafica, (default \c .FALSE.)
5356
5357
5358IF (.NOT. optio_log(dataonly)) THEN
5359 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
5360 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
5361 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
5362 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
5363 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
5364 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
5365 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
5366 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
5367 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
5368 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
5369ENDIF
5370IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
5371IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
5372IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
5373IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
5374IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
5375IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
5376IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
5377IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
5378IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
5379IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
5380
5381IF (.NOT. optio_log(dataonly)) THEN
5382 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5383 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5384ENDIF
5385IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5386IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5387IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5388
5389IF (.NOT. optio_log(dataonly)) THEN
5390 CALL delete(this%anavar)
5391 CALL delete(this%anaattr)
5392 CALL delete(this%anavarattr)
5393ENDIF
5394CALL delete(this%dativar)
5395CALL delete(this%datiattr)
5396CALL delete(this%dativarattr)
5397
5398END SUBROUTINE vol7d_delete
5399
5400
5401
5402integer function vol7d_check(this)
5403TYPE(vol7d),intent(in) :: this !< object to check
5404integer :: i,j,k,l,m,n
5405
5406vol7d_check=0
5407
5408if (associated(this%voldatii)) then
5409do i = 1,size(this%voldatii,1)
5410 do j = 1,size(this%voldatii,2)
5411 do k = 1,size(this%voldatii,3)
5412 do l = 1,size(this%voldatii,4)
5413 do m = 1,size(this%voldatii,5)
5414 do n = 1,size(this%voldatii,6)
5415 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
5416 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
5417 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
5418 vol7d_check=1
5419 end if
5420 end do
5421 end do
5422 end do
5423 end do
5424 end do
5425end do
5426end if
5427
5428
5429if (associated(this%voldatir)) then
5430do i = 1,size(this%voldatir,1)
5431 do j = 1,size(this%voldatir,2)
5432 do k = 1,size(this%voldatir,3)
5433 do l = 1,size(this%voldatir,4)
5434 do m = 1,size(this%voldatir,5)
5435 do n = 1,size(this%voldatir,6)
5436 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
5437 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
5438 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
5439 vol7d_check=2
5440 end if
5441 end do
5442 end do
5443 end do
5444 end do
5445 end do
5446end do
5447end if
5448
5449if (associated(this%voldatid)) then
5450do i = 1,size(this%voldatid,1)
5451 do j = 1,size(this%voldatid,2)
5452 do k = 1,size(this%voldatid,3)
5453 do l = 1,size(this%voldatid,4)
5454 do m = 1,size(this%voldatid,5)
5455 do n = 1,size(this%voldatid,6)
5456 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
5457 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
5458 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
5459 vol7d_check=3
5460 end if
5461 end do
5462 end do
5463 end do
5464 end do
5465 end do
5466end do
5467end if
5468
5469if (associated(this%voldatib)) then
5470do i = 1,size(this%voldatib,1)
5471 do j = 1,size(this%voldatib,2)
5472 do k = 1,size(this%voldatib,3)
5473 do l = 1,size(this%voldatib,4)
5474 do m = 1,size(this%voldatib,5)
5475 do n = 1,size(this%voldatib,6)
5476 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
5477 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
5478 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
5479 vol7d_check=4
5480 end if
5481 end do
5482 end do
5483 end do
5484 end do
5485 end do
5486end do
5487end if
5488
5489end function vol7d_check
5490
5491
5492
5493!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
5494!> stampa a video una sintesi del contenuto
5495SUBROUTINE vol7d_display(this)
5496TYPE(vol7d),intent(in) :: this !< oggetto da visualizzare
5497integer :: i
5498
5499REAL :: rdat
5500DOUBLE PRECISION :: ddat
5501INTEGER :: idat
5502INTEGER(kind=int_b) :: bdat
5503CHARACTER(len=vol7d_cdatalen) :: cdat
5504
5505
5506print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
5507if (this%time_definition == 0) then
5508 print*,"TIME DEFINITION: time is reference time"
5509else if (this%time_definition == 1) then
5510 print*,"TIME DEFINITION: time is validity time"
5511else
5512 print*,"Time definition have a wrong walue:", this%time_definition
5513end if
5514
5515IF (ASSOCIATED(this%network))then
5516 print*,"---- network vector ----"
5517 print*,"elements=",size(this%network)
5518 do i=1, size(this%network)
5519 call display(this%network(i))
5520 end do
5521end IF
5522
5523IF (ASSOCIATED(this%ana))then
5524 print*,"---- ana vector ----"
5525 print*,"elements=",size(this%ana)
5526 do i=1, size(this%ana)
5527 call display(this%ana(i))
5528 end do
5529end IF
5530
5531IF (ASSOCIATED(this%time))then
5532 print*,"---- time vector ----"
5533 print*,"elements=",size(this%time)
5534 do i=1, size(this%time)
5535 call display(this%time(i))
5536 end do
5537end if
5538
5539IF (ASSOCIATED(this%level)) then
5540 print*,"---- level vector ----"
5541 print*,"elements=",size(this%level)
5542 do i =1,size(this%level)
5543 call display(this%level(i))
5544 end do
5545end if
5546
5547IF (ASSOCIATED(this%timerange))then
5548 print*,"---- timerange vector ----"
5549 print*,"elements=",size(this%timerange)
5550 do i =1,size(this%timerange)
5551 call display(this%timerange(i))
5552 end do
5553end if
5554
5555
5556print*,"---- ana vector ----"
5557print*,""
5558print*,"->>>>>>>>> anavar -"
5559call display(this%anavar)
5560print*,""
5561print*,"->>>>>>>>> anaattr -"
5562call display(this%anaattr)
5563print*,""
5564print*,"->>>>>>>>> anavarattr -"
5565call display(this%anavarattr)
5566
5567print*,"-- ana data section (first point) --"
5568
5569idat=imiss
5570rdat=rmiss
5571ddat=dmiss
5572bdat=ibmiss
5573cdat=cmiss
5574
5575!ntime = MIN(SIZE(this%time),nprint)
5576!ntimerange = MIN(SIZE(this%timerange),nprint)
5577!nlevel = MIN(SIZE(this%level),nprint)
5578!nnetwork = MIN(SIZE(this%network),nprint)
5579!nana = MIN(SIZE(this%ana),nprint)
5580
5581IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
5582if (associated(this%volanai)) then
5583 do i=1,size(this%anavar%i)
5584 idat=this%volanai(1,i,1)
5585 if (associated(this%anavar%i)) call display(this%anavar%i(i),idat,rdat,ddat,bdat,cdat)
5586 end do
5587end if
5588idat=imiss
5589
5590if (associated(this%volanar)) then
5591 do i=1,size(this%anavar%r)
5592 rdat=this%volanar(1,i,1)
5593 if (associated(this%anavar%r)) call display(this%anavar%r(i),idat,rdat,ddat,bdat,cdat)
5594 end do
5595end if
5596rdat=rmiss
5597
5598if (associated(this%volanad)) then
5599 do i=1,size(this%anavar%d)
5600 ddat=this%volanad(1,i,1)
5601 if (associated(this%anavar%d)) call display(this%anavar%d(i),idat,rdat,ddat,bdat,cdat)
5602 end do
5603end if
5604ddat=dmiss
5605
5606if (associated(this%volanab)) then
5607 do i=1,size(this%anavar%b)
5608 bdat=this%volanab(1,i,1)
5609 if (associated(this%anavar%b)) call display(this%anavar%b(i),idat,rdat,ddat,bdat,cdat)
5610 end do
5611end if
5612bdat=ibmiss
5613
5614if (associated(this%volanac)) then
5615 do i=1,size(this%anavar%c)
5616 cdat=this%volanac(1,i,1)
5617 if (associated(this%anavar%c)) call display(this%anavar%c(i),idat,rdat,ddat,bdat,cdat)
5618 end do
5619end if
5620cdat=cmiss
5621ENDIF
5622
5623print*,"---- data vector ----"
5624print*,""
5625print*,"->>>>>>>>> dativar -"
5626call display(this%dativar)
5627print*,""
5628print*,"->>>>>>>>> datiattr -"
5629call display(this%datiattr)
5630print*,""
5631print*,"->>>>>>>>> dativarattr -"
5632call display(this%dativarattr)
5633
5634print*,"-- data data section (first point) --"
5635
5636idat=imiss
5637rdat=rmiss
5638ddat=dmiss
5639bdat=ibmiss
5640cdat=cmiss
5641
5642IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
5643 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
5644if (associated(this%voldatii)) then
5645 do i=1,size(this%dativar%i)
5646 idat=this%voldatii(1,1,1,1,i,1)
5647 if (associated(this%dativar%i)) call display(this%dativar%i(i),idat,rdat,ddat,bdat,cdat)
5648 end do
5649end if
5650idat=imiss
5651
5652if (associated(this%voldatir)) then
5653 do i=1,size(this%dativar%r)
5654 rdat=this%voldatir(1,1,1,1,i,1)
5655 if (associated(this%dativar%r)) call display(this%dativar%r(i),idat,rdat,ddat,bdat,cdat)
5656 end do
5657end if
5658rdat=rmiss
5659
5660if (associated(this%voldatid)) then
5661 do i=1,size(this%dativar%d)
5662 ddat=this%voldatid(1,1,1,1,i,1)
5663 if (associated(this%dativar%d)) call display(this%dativar%d(i),idat,rdat,ddat,bdat,cdat)
5664 end do
5665end if
5666ddat=dmiss
5667
5668if (associated(this%voldatib)) then
5669 do i=1,size(this%dativar%b)
5670 bdat=this%voldatib(1,1,1,1,i,1)
5671 if (associated(this%dativar%b)) call display(this%dativar%b(i),idat,rdat,ddat,bdat,cdat)
5672 end do
5673end if
5674bdat=ibmiss
5675
5676if (associated(this%voldatic)) then
5677 do i=1,size(this%dativar%c)
5678 cdat=this%voldatic(1,1,1,1,i,1)
5679 if (associated(this%dativar%c)) call display(this%dativar%c(i),idat,rdat,ddat,bdat,cdat)
5680 end do
5681end if
5682cdat=cmiss
5683ENDIF
5684
5685print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
5686
5687END SUBROUTINE vol7d_display
5688
5689
5690!> stampa a video una sintesi del contenuto
5691SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
5692TYPE(vol7d_var),intent(in) :: this !< oggetto da visualizzare
5693!> real
5694REAL :: rdat
5695!> double precision
5696DOUBLE PRECISION :: ddat
5697!> integer
5698INTEGER :: idat
5699!> byte
5700INTEGER(kind=int_b) :: bdat
5701!> character
5702CHARACTER(len=*) :: cdat
5703
5704print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5705
5706end SUBROUTINE dat_display
5707
5708!> stampa a video una sintesi del contenuto
5709SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
5710
5711TYPE(vol7d_var),intent(in) :: this(:) !< oggetto da visualizzare
5712!> real
5713REAL :: rdat(:)
5714!> double precision
5715DOUBLE PRECISION :: ddat(:)
5716!> integer
5717INTEGER :: idat(:)
5718!> byte
5719INTEGER(kind=int_b) :: bdat(:)
5720!> character
5721CHARACTER(len=*):: cdat(:)
5722
5723integer :: i
5724
5725do i =1,size(this)
5726 call display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
5727end do
5728
5729end SUBROUTINE dat_vect_display
5730
5731
5732FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5733#ifdef HAVE_DBALLE
5734USE dballef
5735#endif
5736TYPE(vol7d_var),INTENT(in) :: this
5737!> real
5738REAL :: rdat
5739!> double precision
5740DOUBLE PRECISION :: ddat
5741!> integer
5742INTEGER :: idat
5743!> byte
5744INTEGER(kind=int_b) :: bdat
5745!> character
5746CHARACTER(len=*) :: cdat
5747CHARACTER(len=80) :: to_char_dat
5748
5749CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
5750
5751
5752#ifdef HAVE_DBALLE
5753INTEGER :: handle, ier
5754
5755handle = 0
5756to_char_dat="VALUE: "
5757
5758if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5759if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5760if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5761if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5762
5763if ( c_e(cdat))then
5764 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
5765 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
5766 ier = idba_fatto(handle)
5767 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
5768endif
5769
5770#else
5771
5772to_char_dat="VALUE: "
5773if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
5774if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
5775if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
5776if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
5777if (c_e(cdat)) to_char_dat=trim(to_char_dat)//" ;char> "//trim(cdat)
5778
5779#endif
5780
5781END FUNCTION to_char_dat
5782
5783
5784!> Tests whether anything has ever been assigned to a vol7d object
5785!! (.TRUE.) or it is as clean as after an init (.FALSE.).
5786FUNCTION vol7d_c_e(this) RESULT(c_e)
5787TYPE(vol7d), INTENT(in) :: this
5788
5789LOGICAL :: c_e
5790
5791c_e = ASSOCIATED(this%ana) .OR. ASSOCIATED(this%time) .OR. &
5792 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5793 ASSOCIATED(this%network) .OR. &
5794 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5795 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5796 ASSOCIATED(this%anavar%c) .OR. &
5797 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5798 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5799 ASSOCIATED(this%anaattr%c) .OR. &
5800 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5801 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5802 ASSOCIATED(this%dativar%c) .OR. &
5803 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5804 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5805 ASSOCIATED(this%datiattr%c)
5806
5807END FUNCTION vol7d_c_e
5808
5809
5810!> Metodo per allocare i descrittori delle 7 dimensioni.
5811!! Riceve un grande numero di parametri opzionali che
5812!! indicano quali descrittori allocare e con quale estensione;
5813!! i descrittori non specificati non vengono toccati.
5814!! Può essere quindi chiamato più volte allocando via via
5815!! descrittori relativi a dimensioni diverse.
5816!! Se un descrittore richiesto è già allocato, viene deallocato
5817!! (perdendone l'eventuale contenuto) e riallocato con l'estensione
5818!! richiesta.
5819!! Per i descrittori relativi a dimensioni che non siano variabili o attributi,
5820!! è possibile specificare l'estensione di una dimensione a 0,
5821!! in tal caso il descrittore viene comunque allocato con lunghezza nulla,
5822!! che è diverso da non allocarlo. Per i descrittori di variabili e attributi
5823!! passare un'estensione 0 equivale a non fornire il parametro.
5824!! Avere uno o più descrittori dimensionati con estensione nulla fa sì
5825!! che anche il volume dati successivamente allocato abbia estensione nulla;
5826!! sebbene ciò appaia inutile, un volume del genere può in realtà servire,
5827!! in associazione ai metodi ::vol7d_merge o ::vol7d_append per estendere
5828!! un volume esistente aggiungendo elementi in alcune dimensioni (quelle
5829!! a estensione non nulla, ovviamente) e mantenendo invariato tutto il resto.
5830!! Per quanto riguarda i descrittori delle dimensioni relative alle
5831!! variabili, la relativa estensione è specificata con la nomenclatura
5832!! \a n&lt;x&gt;&lt;y&gt;&lt;z&gt; dove &lt;x&gt; può valere:
5833!! - \a ana per variabili relative a voumi di anagrafica
5834!! - \a dati per variabili relative a voumi di dati
5835!!
5836!! &lt;y&gt; può valere:
5837!! - \a var per variabili
5838!! - \a attr per attributi
5839!! - \a varattr variabili aventi attributi nei volumi di attributi
5840!!
5841!! &lt;z&gt; può valere:
5842!! - \a r per variabili o attributi a valori reali
5843!! - \a d per variabili o attributi a valori a doppia precisione
5844!! - \a i per variabili o attributi a valori interi
5845!! - \a b per variabili o attributi a valori byte
5846!! - \a c per variabili o attributi a valori carattere
5847!!
5848SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5849 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5850 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5851 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5852 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5853 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5854 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5855 ini)
5856TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i descrittori
5857INTEGER,INTENT(in),OPTIONAL :: nana !< estensione della dimensione anagrafica
5858INTEGER,INTENT(in),OPTIONAL :: ntime !< estensione della dimensione tempo
5859INTEGER,INTENT(in),OPTIONAL :: nlevel !< estensione della dimensione livello varticale
5860INTEGER,INTENT(in),OPTIONAL :: ntimerange !< estensione della dimensione intervallo temporale (timerange)
5861INTEGER,INTENT(in),OPTIONAL :: nnetwork !< estensione della dimensione rete
5862!> estensione delle possibili dimensioni variabile
5863INTEGER,INTENT(in),OPTIONAL :: &
5864 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5865 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5866 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5867 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5868 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5869 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5870LOGICAL,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
5871
5872INTEGER :: i
5873LOGICAL :: linit
5874
5875IF (PRESENT(ini)) THEN
5876 linit = ini
5877ELSE
5878 linit = .false.
5879ENDIF
5880
5881! Dimensioni principali
5882IF (PRESENT(nana)) THEN
5883 IF (nana >= 0) THEN
5884 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5885 ALLOCATE(this%ana(nana))
5886 IF (linit) THEN
5887 DO i = 1, nana
5888 CALL init(this%ana(i))
5889 ENDDO
5890 ENDIF
5891 ENDIF
5892ENDIF
5893IF (PRESENT(ntime)) THEN
5894 IF (ntime >= 0) THEN
5895 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5896 ALLOCATE(this%time(ntime))
5897 IF (linit) THEN
5898 DO i = 1, ntime
5899 CALL init(this%time(i))
5900 ENDDO
5901 ENDIF
5902 ENDIF
5903ENDIF
5904IF (PRESENT(nlevel)) THEN
5905 IF (nlevel >= 0) THEN
5906 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5907 ALLOCATE(this%level(nlevel))
5908 IF (linit) THEN
5909 DO i = 1, nlevel
5910 CALL init(this%level(i))
5911 ENDDO
5912 ENDIF
5913 ENDIF
5914ENDIF
5915IF (PRESENT(ntimerange)) THEN
5916 IF (ntimerange >= 0) THEN
5917 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5918 ALLOCATE(this%timerange(ntimerange))
5919 IF (linit) THEN
5920 DO i = 1, ntimerange
5921 CALL init(this%timerange(i))
5922 ENDDO
5923 ENDIF
5924 ENDIF
5925ENDIF
5926IF (PRESENT(nnetwork)) THEN
5927 IF (nnetwork >= 0) THEN
5928 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5929 ALLOCATE(this%network(nnetwork))
5930 IF (linit) THEN
5931 DO i = 1, nnetwork
5932 CALL init(this%network(i))
5933 ENDDO
5934 ENDIF
5935 ENDIF
5936ENDIF
5937! Dimensioni dei tipi delle variabili
5938CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5939 nanavari, nanavarb, nanavarc, ini)
5940CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5941 nanaattri, nanaattrb, nanaattrc, ini)
5942CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5943 nanavarattri, nanavarattrb, nanavarattrc, ini)
5944CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5945 ndativari, ndativarb, ndativarc, ini)
5946CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5947 ndatiattri, ndatiattrb, ndatiattrc, ini)
5948CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5949 ndativarattri, ndativarattrb, ndativarattrc, ini)
5950
5951END SUBROUTINE vol7d_alloc
5952
5953
5954FUNCTION vol7d_check_alloc_ana(this)
5955TYPE(vol7d),INTENT(in) :: this
5956LOGICAL :: vol7d_check_alloc_ana
5957
5958vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5959
5960END FUNCTION vol7d_check_alloc_ana
5961
5962SUBROUTINE vol7d_force_alloc_ana(this, ini)
5963TYPE(vol7d),INTENT(inout) :: this
5964LOGICAL,INTENT(in),OPTIONAL :: ini
5965
5966! Alloco i descrittori minimi per avere un volume di anagrafica
5967IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5968IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5969
5970END SUBROUTINE vol7d_force_alloc_ana
5971
5972
5973FUNCTION vol7d_check_alloc_dati(this)
5974TYPE(vol7d),INTENT(in) :: this
5975LOGICAL :: vol7d_check_alloc_dati
5976
5977vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5978 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5979 ASSOCIATED(this%timerange)
5980
5981END FUNCTION vol7d_check_alloc_dati
5982
5983SUBROUTINE vol7d_force_alloc_dati(this, ini)
5984TYPE(vol7d),INTENT(inout) :: this
5985LOGICAL,INTENT(in),OPTIONAL :: ini
5986
5987! Alloco i descrittori minimi per avere un volume di dati
5988CALL vol7d_force_alloc_ana(this, ini)
5989IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5990IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5991IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5992
5993END SUBROUTINE vol7d_force_alloc_dati
5994
5995
5996SUBROUTINE vol7d_force_alloc(this)
5997TYPE(vol7d),INTENT(inout) :: this
5998
5999! If anything really not allocated yet, allocate with size 0
6000IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
6001IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
6002IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
6003IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
6004IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
6005
6006END SUBROUTINE vol7d_force_alloc
6007
6008
6009FUNCTION vol7d_check_vol(this)
6010TYPE(vol7d),INTENT(in) :: this !< oggetto da controllare
6011LOGICAL :: vol7d_check_vol
6012
6013vol7d_check_vol = c_e(this)
6014
6015! Anagrafica
6016IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6017 vol7d_check_vol = .false.
6018ENDIF
6019
6020IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6021 vol7d_check_vol = .false.
6022ENDIF
6023
6024IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6025 vol7d_check_vol = .false.
6026ENDIF
6027
6028IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6029 vol7d_check_vol = .false.
6030ENDIF
6031
6032IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6033 vol7d_check_vol = .false.
6034ENDIF
6035IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6036 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6037 ASSOCIATED(this%anavar%c)) THEN
6038 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
6039ENDIF
6040
6041! Attributi dell'anagrafica
6042IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6043 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6044 vol7d_check_vol = .false.
6045ENDIF
6046
6047IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6048 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6049 vol7d_check_vol = .false.
6050ENDIF
6051
6052IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6053 .NOT.ASSOCIATED(this%volanaattri)) THEN
6054 vol7d_check_vol = .false.
6055ENDIF
6056
6057IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6058 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6059 vol7d_check_vol = .false.
6060ENDIF
6061
6062IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6063 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6064 vol7d_check_vol = .false.
6065ENDIF
6066
6067! Dati
6068IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6069 vol7d_check_vol = .false.
6070ENDIF
6071
6072IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6073 vol7d_check_vol = .false.
6074ENDIF
6075
6076IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6077 vol7d_check_vol = .false.
6078ENDIF
6079
6080IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6081 vol7d_check_vol = .false.
6082ENDIF
6083
6084IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6085 vol7d_check_vol = .false.
6086ENDIF
6087
6088! Attributi dei dati
6089IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6090 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6091 vol7d_check_vol = .false.
6092ENDIF
6093
6094IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6095 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6096 vol7d_check_vol = .false.
6097ENDIF
6098
6099IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6100 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6101 vol7d_check_vol = .false.
6102ENDIF
6103
6104IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6105 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6106 vol7d_check_vol = .false.
6107ENDIF
6108
6109IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6110 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6111 vol7d_check_vol = .false.
6112ENDIF
6113IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6114 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6115 ASSOCIATED(this%dativar%c)) THEN
6116 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6117ENDIF
6118
6119END FUNCTION vol7d_check_vol
6120
6121
6122!> Metodo per allocare i volumi richiesti di variabili e attributi per
6123!! anagrafica e dati.
6124!! Se alcuni dei descrittori relativi alle dimensioni anagrafica,
6125!! livello verticale, tempo, intervallo temporale (timerange), rete non sono
6126!! stati richiesti preventivamente con la ::vol7d_alloc, essi vengono allocati
6127!! automaticamente da questo metodo
6128!! con estensione di default pari a 1 (non 0!), questo significa, ad esempio,
6129!! che se prevedo di avere soli dati superficiali, cioè ad un solo livello
6130!! verticale, o una sola rete di stazioni, non devo preoccuparmi di
6131!! specificare questa informazione.
6132!! Tra i 20 possibili volumi allocabili
6133!! ((variabili,attributi)*(anagrafica,dati)*(r,d,i,b,c)=20)
6134!! saranno allocati solo quelli per cui è stato precedentemente richiesto il
6135!! corrispondente descrittore variabili/attributi con la ::vol7d_alloc.
6136SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6137TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i volumi
6138LOGICAL,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
6139LOGICAL,INTENT(in),OPTIONAL :: inivol !< se fornito e vale \c .TRUE., i volumi allocati saranno inizializzati a valore mancante
6140
6141LOGICAL :: linivol
6142
6143IF (PRESENT(inivol)) THEN
6144 linivol = inivol
6145ELSE
6146 linivol = .true.
6147ENDIF
6148
6149! Anagrafica
6150IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6151 CALL vol7d_force_alloc_ana(this, ini)
6152 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6153 IF (linivol) this%volanar(:,:,:) = rmiss
6154ENDIF
6155
6156IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6157 CALL vol7d_force_alloc_ana(this, ini)
6158 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6159 IF (linivol) this%volanad(:,:,:) = rdmiss
6160ENDIF
6161
6162IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6163 CALL vol7d_force_alloc_ana(this, ini)
6164 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6165 IF (linivol) this%volanai(:,:,:) = imiss
6166ENDIF
6167
6168IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6169 CALL vol7d_force_alloc_ana(this, ini)
6170 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6171 IF (linivol) this%volanab(:,:,:) = ibmiss
6172ENDIF
6173
6174IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6175 CALL vol7d_force_alloc_ana(this, ini)
6176 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6177 IF (linivol) this%volanac(:,:,:) = cmiss
6178ENDIF
6179
6180! Attributi dell'anagrafica
6181IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6182 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6183 CALL vol7d_force_alloc_ana(this, ini)
6184 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6185 SIZE(this%network), SIZE(this%anaattr%r)))
6186 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6187ENDIF
6188
6189IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6190 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6191 CALL vol7d_force_alloc_ana(this, ini)
6192 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6193 SIZE(this%network), SIZE(this%anaattr%d)))
6194 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6195ENDIF
6196
6197IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6198 .NOT.ASSOCIATED(this%volanaattri)) THEN
6199 CALL vol7d_force_alloc_ana(this, ini)
6200 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6201 SIZE(this%network), SIZE(this%anaattr%i)))
6202 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6203ENDIF
6204
6205IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6206 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6207 CALL vol7d_force_alloc_ana(this, ini)
6208 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6209 SIZE(this%network), SIZE(this%anaattr%b)))
6210 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6211ENDIF
6212
6213IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6214 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6215 CALL vol7d_force_alloc_ana(this, ini)
6216 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6217 SIZE(this%network), SIZE(this%anaattr%c)))
6218 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6219ENDIF
6220
6221! Dati
6222IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6223 CALL vol7d_force_alloc_dati(this, ini)
6224 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6225 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6226 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6227ENDIF
6228
6229IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6230 CALL vol7d_force_alloc_dati(this, ini)
6231 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6232 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6233 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6234ENDIF
6235
6236IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6237 CALL vol7d_force_alloc_dati(this, ini)
6238 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6239 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6240 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6241ENDIF
6242
6243IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6244 CALL vol7d_force_alloc_dati(this, ini)
6245 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6246 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6247 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6248ENDIF
6249
6250IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6251 CALL vol7d_force_alloc_dati(this, ini)
6252 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6253 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6254 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6255ENDIF
6256
6257! Attributi dei dati
6258IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6259 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6260 CALL vol7d_force_alloc_dati(this, ini)
6261 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6262 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
6263 SIZE(this%datiattr%r)))
6264 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
6265ENDIF
6266
6267IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6268 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6269 CALL vol7d_force_alloc_dati(this, ini)
6270 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6271 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
6272 SIZE(this%datiattr%d)))
6273 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
6274ENDIF
6275
6276IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6277 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6278 CALL vol7d_force_alloc_dati(this, ini)
6279 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6280 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
6281 SIZE(this%datiattr%i)))
6282 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
6283ENDIF
6284
6285IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6286 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6287 CALL vol7d_force_alloc_dati(this, ini)
6288 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6289 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
6290 SIZE(this%datiattr%b)))
6291 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
6292ENDIF
6293
6294IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6295 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6296 CALL vol7d_force_alloc_dati(this, ini)
6297 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6298 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
6299 SIZE(this%datiattr%c)))
6300 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
6301ENDIF
6302
6303! Catch-all method
6304CALL vol7d_force_alloc(this)
6305
6306! Creo gli indici var-attr
6307
6308#ifdef DEBUG
6309CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
6310#endif
6311
6312CALL vol7d_set_attr_ind(this)
6313
6314
6315
6316END SUBROUTINE vol7d_alloc_vol
6317
6318
6319!> Metodo per creare gli indici che associano le variabili aventi attributo
6320!! alle variabili nei relativi descrittori.
6321!! Ha senso chiamare questo metodo solo dopo che i descrittori delle variabili
6322!! e degli attributi desiderati sono stati allocati ed è stato assegnato un
6323!! valore ai relativi membri btable (vedi vol7d_var_class::vol7d_var), se
6324!! i descrittori non sono stati allocati o assegnati, il metodo non fa niente.
6325SUBROUTINE vol7d_set_attr_ind(this)
6326TYPE(vol7d),INTENT(inout) :: this !< oggetto in cui creare gli indici
6327
6328INTEGER :: i
6329
6330! real
6331IF (ASSOCIATED(this%dativar%r)) THEN
6332 IF (ASSOCIATED(this%dativarattr%r)) THEN
6333 DO i = 1, SIZE(this%dativar%r)
6334 this%dativar%r(i)%r = &
6335 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
6336 ENDDO
6337 ENDIF
6338
6339 IF (ASSOCIATED(this%dativarattr%d)) THEN
6340 DO i = 1, SIZE(this%dativar%r)
6341 this%dativar%r(i)%d = &
6342 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
6343 ENDDO
6344 ENDIF
6345
6346 IF (ASSOCIATED(this%dativarattr%i)) THEN
6347 DO i = 1, SIZE(this%dativar%r)
6348 this%dativar%r(i)%i = &
6349 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
6350 ENDDO
6351 ENDIF
6352
6353 IF (ASSOCIATED(this%dativarattr%b)) THEN
6354 DO i = 1, SIZE(this%dativar%r)
6355 this%dativar%r(i)%b = &
6356 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
6357 ENDDO
6358 ENDIF
6359
6360 IF (ASSOCIATED(this%dativarattr%c)) THEN
6361 DO i = 1, SIZE(this%dativar%r)
6362 this%dativar%r(i)%c = &
6363 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
6364 ENDDO
6365 ENDIF
6366ENDIF
6367! double
6368IF (ASSOCIATED(this%dativar%d)) THEN
6369 IF (ASSOCIATED(this%dativarattr%r)) THEN
6370 DO i = 1, SIZE(this%dativar%d)
6371 this%dativar%d(i)%r = &
6372 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
6373 ENDDO
6374 ENDIF
6375
6376 IF (ASSOCIATED(this%dativarattr%d)) THEN
6377 DO i = 1, SIZE(this%dativar%d)
6378 this%dativar%d(i)%d = &
6379 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
6380 ENDDO
6381 ENDIF
6382
6383 IF (ASSOCIATED(this%dativarattr%i)) THEN
6384 DO i = 1, SIZE(this%dativar%d)
6385 this%dativar%d(i)%i = &
6386 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
6387 ENDDO
6388 ENDIF
6389
6390 IF (ASSOCIATED(this%dativarattr%b)) THEN
6391 DO i = 1, SIZE(this%dativar%d)
6392 this%dativar%d(i)%b = &
6393 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
6394 ENDDO
6395 ENDIF
6396
6397 IF (ASSOCIATED(this%dativarattr%c)) THEN
6398 DO i = 1, SIZE(this%dativar%d)
6399 this%dativar%d(i)%c = &
6400 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
6401 ENDDO
6402 ENDIF
6403ENDIF
6404! integer
6405IF (ASSOCIATED(this%dativar%i)) THEN
6406 IF (ASSOCIATED(this%dativarattr%r)) THEN
6407 DO i = 1, SIZE(this%dativar%i)
6408 this%dativar%i(i)%r = &
6409 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
6410 ENDDO
6411 ENDIF
6412
6413 IF (ASSOCIATED(this%dativarattr%d)) THEN
6414 DO i = 1, SIZE(this%dativar%i)
6415 this%dativar%i(i)%d = &
6416 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
6417 ENDDO
6418 ENDIF
6419
6420 IF (ASSOCIATED(this%dativarattr%i)) THEN
6421 DO i = 1, SIZE(this%dativar%i)
6422 this%dativar%i(i)%i = &
6423 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
6424 ENDDO
6425 ENDIF
6426
6427 IF (ASSOCIATED(this%dativarattr%b)) THEN
6428 DO i = 1, SIZE(this%dativar%i)
6429 this%dativar%i(i)%b = &
6430 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
6431 ENDDO
6432 ENDIF
6433
6434 IF (ASSOCIATED(this%dativarattr%c)) THEN
6435 DO i = 1, SIZE(this%dativar%i)
6436 this%dativar%i(i)%c = &
6437 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
6438 ENDDO
6439 ENDIF
6440ENDIF
6441! byte
6442IF (ASSOCIATED(this%dativar%b)) THEN
6443 IF (ASSOCIATED(this%dativarattr%r)) THEN
6444 DO i = 1, SIZE(this%dativar%b)
6445 this%dativar%b(i)%r = &
6446 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
6447 ENDDO
6448 ENDIF
6449
6450 IF (ASSOCIATED(this%dativarattr%d)) THEN
6451 DO i = 1, SIZE(this%dativar%b)
6452 this%dativar%b(i)%d = &
6453 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
6454 ENDDO
6455 ENDIF
6456
6457 IF (ASSOCIATED(this%dativarattr%i)) THEN
6458 DO i = 1, SIZE(this%dativar%b)
6459 this%dativar%b(i)%i = &
6460 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
6461 ENDDO
6462 ENDIF
6463
6464 IF (ASSOCIATED(this%dativarattr%b)) THEN
6465 DO i = 1, SIZE(this%dativar%b)
6466 this%dativar%b(i)%b = &
6467 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
6468 ENDDO
6469 ENDIF
6470
6471 IF (ASSOCIATED(this%dativarattr%c)) THEN
6472 DO i = 1, SIZE(this%dativar%b)
6473 this%dativar%b(i)%c = &
6474 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
6475 ENDDO
6476 ENDIF
6477ENDIF
6478! character
6479IF (ASSOCIATED(this%dativar%c)) THEN
6480 IF (ASSOCIATED(this%dativarattr%r)) THEN
6481 DO i = 1, SIZE(this%dativar%c)
6482 this%dativar%c(i)%r = &
6483 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
6484 ENDDO
6485 ENDIF
6486
6487 IF (ASSOCIATED(this%dativarattr%d)) THEN
6488 DO i = 1, SIZE(this%dativar%c)
6489 this%dativar%c(i)%d = &
6490 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
6491 ENDDO
6492 ENDIF
6493
6494 IF (ASSOCIATED(this%dativarattr%i)) THEN
6495 DO i = 1, SIZE(this%dativar%c)
6496 this%dativar%c(i)%i = &
6497 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
6498 ENDDO
6499 ENDIF
6500
6501 IF (ASSOCIATED(this%dativarattr%b)) THEN
6502 DO i = 1, SIZE(this%dativar%c)
6503 this%dativar%c(i)%b = &
6504 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
6505 ENDDO
6506 ENDIF
6507
6508 IF (ASSOCIATED(this%dativarattr%c)) THEN
6509 DO i = 1, SIZE(this%dativar%c)
6510 this%dativar%c(i)%c = &
6511 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
6512 ENDDO
6513 ENDIF
6514ENDIF
6515
6516END SUBROUTINE vol7d_set_attr_ind
6517
6518
6519!> Metodo per fondere 2 oggetti vol7d.
6520!! Il secondo volume viene accodato al primo e poi distrutto, si veda
6521!! quindi la descrizione di ::vol7d_append. Se uno degli oggetti \a
6522!! this o \a that sono vuoti non perde tempo inutile,
6523SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
6524 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6525TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, alla fine conterrà il risultato della fusione
6526TYPE(vol7d),INTENT(INOUT) :: that !< secondo oggetto in ingresso, alla fine sarà distrutto
6527LOGICAL,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
6528LOGICAL,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
6529LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
6530
6531TYPE(vol7d) :: v7d_clean
6532
6533
6534IF (.NOT.c_e(this)) THEN ! speedup
6535 this = that
6536 CALL init(v7d_clean)
6537 that = v7d_clean ! destroy that without deallocating
6538ELSE ! Append that to this and destroy that
6539 CALL vol7d_append(this, that, sort, bestdata, &
6540 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6541 CALL delete(that)
6542ENDIF
6543
6544END SUBROUTINE vol7d_merge
6545
6546
6547!> Metodo per accodare un oggetto vol7d ad un altro.
6548!! Si tratta di un metodo molto potente e versatile;
6549!! i descrittori delle dimensioni del volume finale conterranno i valori
6550!! dei corrispondenti descrittori del primo e del secondo volume
6551!! e i volumi di anagrafica e dati conterranno i valori dei due volumi
6552!! ai posti giusti, e valori mancanti per le nuove combinazioni che
6553!! eventualmente si verranno a creare.
6554!! Se i volumi multidimensionali di anagrafica e/o dati dei 2 oggetti
6555!! hanno un'intersezione non nulla, negli elementi comuni il volume finale
6556!! conterrà il corrispondente elemento del \b secondo volume.
6557!! Attenzione che, durante l'esecuzione del metodo, la memoria richiesta è
6558!! pari alla memoria complessiva occupata dai 2 volumi iniziali più
6559!! la memoria complessiva del volume finale, per cui, nel caso di volumi grandi,
6560!! ci potrebbero essere problemi di esaurimento della memoria centrale.
6561!! Se l'oggetto \a that è vuoto non perde tempo inutile,
6562!!
6563!! \todo nel caso di elementi comuni inserire la possibiità (opzionale per
6564!! non penalizzare le prestazioni quando ciò non serve) di effettuare una scelta
6565!! più ragionata dell'elemento da tenere, almeno controllando i dati mancanti
6566!! se non le flag di qualità
6567!!
6568!! \todo "rateizzare" l'allocazione dei volumi per ridurre l'occupazione di
6569!! memoria nel caso siano allocati contemporaneamente volumi di variabili e
6570!! di attributi o più volumi di tipi diversi
6571!!
6572!! \todo il parametro \a that è dichiarato \a INOUT perché la vol7d_alloc_vol
6573!! può modificarlo, bisognerebbe implementare una vol7d_check_vol che restituisca
6574!! errore anziché usare la vol7d_alloc_vol.
6575SUBROUTINE vol7d_append(this, that, sort, bestdata, &
6576 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
6577TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, a cui sarà accodato il secondo
6578TYPE(vol7d),INTENT(IN) :: that !< secondo oggetto in ingresso, non viene modificato dal metodo
6579LOGICAL,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
6580! experimental, please do not use outside the library now, they force the use
6581! of a simplified mapping algorithm which is valid only whene the dimension
6582! content is the same in both volumes , or when one of them is empty
6583LOGICAL,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
6584LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
6585
6586
6587TYPE(vol7d) :: v7dtmp
6588LOGICAL :: lsort, lbestdata
6589INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
6590 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
6591
6592IF (.NOT.c_e(that)) RETURN ! speedup, nothing to do
6593IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
6594IF (.NOT.c_e(this)) THEN ! this case is like a vol7d_copy, more efficient to copy?
6595 CALL vol7d_copy(that, this, sort=sort)
6596 RETURN
6597ENDIF
6598
6599IF (this%time_definition /= that%time_definition) THEN
6600 CALL l4f_log(l4f_fatal, &
6601 'in vol7d_append, cannot append volumes with different &
6602 &time definition')
6603 CALL raise_fatal_error()
6604ENDIF
6605
6606! Completo l'allocazione per avere volumi a norma
6607CALL vol7d_alloc_vol(this)
6608
6609CALL init(v7dtmp, time_definition=this%time_definition)
6610CALL optio(sort, lsort)
6611CALL optio(bestdata, lbestdata)
6612
6613! Calcolo le mappature tra volumi vecchi e volume nuovo
6614! I puntatori remap* vengono tutti o allocati o nullificati
6615IF (optio_log(ltimesimple)) THEN
6616 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
6617 lsort, remapt1, remapt2)
6618ELSE
6619 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
6620 lsort, remapt1, remapt2)
6621ENDIF
6622IF (optio_log(ltimerangesimple)) THEN
6623 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
6624 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6625ELSE
6626 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
6627 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6628ENDIF
6629IF (optio_log(llevelsimple)) THEN
6630 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
6631 lsort, remapl1, remapl2)
6632ELSE
6633 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
6634 lsort, remapl1, remapl2)
6635ENDIF
6636IF (optio_log(lanasimple)) THEN
6637 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6638 .false., remapa1, remapa2)
6639ELSE
6640 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6641 .false., remapa1, remapa2)
6642ENDIF
6643IF (optio_log(lnetworksimple)) THEN
6644 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
6645 .false., remapn1, remapn2)
6646ELSE
6647 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
6648 .false., remapn1, remapn2)
6649ENDIF
6650
6651! Faccio la fusione fisica dei volumi
6652CALL vol7d_merge_finalr(this, that, v7dtmp, &
6653 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6654 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6655CALL vol7d_merge_finald(this, that, v7dtmp, &
6656 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6657 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6658CALL vol7d_merge_finali(this, that, v7dtmp, &
6659 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6660 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6661CALL vol7d_merge_finalb(this, that, v7dtmp, &
6662 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6663 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6664CALL vol7d_merge_finalc(this, that, v7dtmp, &
6665 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6666 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6667
6668! Dealloco i vettori di rimappatura
6669IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
6670IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
6671IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
6672IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
6673IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
6674IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
6675IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
6676IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
6677IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
6678IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
6679
6680! Distruggo il vecchio volume e assegno il nuovo a this
6681CALL delete(this)
6682this = v7dtmp
6683! Ricreo gli indici var-attr
6684CALL vol7d_set_attr_ind(this)
6685
6686END SUBROUTINE vol7d_append
6687
6688
6689!> Metodo per creare una copia completa e indipendente di un oggetto vol7d.
6690!! Questo metodo crea un duplicato di tutti i membri di un oggetto vol7d,
6691!! con la possibilità di rielaborarlo durante la copia. Se l'oggetto da copiare
6692!! è vuoto non perde tempo inutile.
6693!! Attenzione, il codice:
6694!! \code
6695!! USE vol7d_class
6696!! TYPE(vol7d) :: vol1, vol2
6697!! CALL init(vol1)
6698!! CALL init(vol2)
6699!! ... ! riempio vol1
6700!! vol2 = vol1
6701!! \endcode
6702!! fa una cosa diversa rispetto a:
6703!! \code
6704!! USE vol7d_class
6705!! TYPE(vol7d) :: vol1, vol2
6706!! CALL init(vol1)
6707!! CALL init(vol2)
6708!! ... ! riempio vol1
6709!! CALL vol7d_copy(vol1, vol2)
6710!! \endcode
6711!! nel primo caso, infatti, l'operatore di assegnazione copia solo i componenti
6712!! statici di \a vol1 nei corrispondenti elementi di \a vol2, mentre i componenti che
6713!! sono allocati dinamicamente (cioè quelli che in ::vol7d hanno l'attributo
6714!! \c POINTER, in pratica quasi tutti) non vengono duplicati, ma per essi vol2
6715!! conterrà un puntatore al corrispondente elemento a cui già punta vol1, e quindi
6716!! eventuali cambiamenti al contenuto di uno dei due oggetti influenzerà il
6717!! contenuto dell'altro; nel secondo caso, invece, vol1 e vol2 sono, dopo la
6718!! vol7d_copy, 2 istanze
6719!! completamente indipendenti, ma uguali tra loro per contenuto, della classe
6720!! vol7d, e quindi hanno vita indipendente.
6721SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
6722 lsort_time, lsort_timerange, lsort_level, &
6723 ltime, ltimerange, llevel, lana, lnetwork, &
6724 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6725 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6726 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6727 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6728 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6729 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6730TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
6731TYPE(vol7d),INTENT(INOUT) :: that !< oggetto destinazione
6732LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
6733LOGICAL,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)
6734LOGICAL,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
6735LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
6736LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
6737LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
6738!> se fornito, deve essere un vettore logico della stessa lunghezza di
6739!! this%time indicante quali elementi della dimensione \a time
6740!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
6741!! nel volume copiato; in alternativa può essere un vettore di
6742!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
6743!! gli elementi (utile principalmente per le variabili); è compatibile
6744!! col parametro \a miss
6745LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6746!> come il precedente per la dimensione \a timerange
6747LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6748!> come il precedente per la dimensione \a level
6749LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6750!> come il precedente per la dimensione \a ana
6751LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6752!> come il precedente per la dimensione \a network
6753LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6754!> come il precedente per tutte le possibili dimensioni variabile
6755LOGICAL,INTENT(in),OPTIONAL :: &
6756 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6757 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6758 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6759 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6760 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6761 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6762
6763LOGICAL :: lsort, lunique, lmiss
6764INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
6765
6766CALL init(that)
6767IF (.NOT.c_e(this)) RETURN ! speedup, nothing to do
6768IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
6769
6770CALL optio(sort, lsort)
6771CALL optio(unique, lunique)
6772CALL optio(miss, lmiss)
6773
6774! Calcolo le mappature tra volume vecchio e volume nuovo
6775! I puntatori remap* vengono tutti o allocati o nullificati
6776CALL vol7d_remap1_datetime(this%time, that%time, &
6777 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6778CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6779 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6780CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6781 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6782CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6783 lsort, lunique, lmiss, remapa, lana)
6784CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6785 lsort, lunique, lmiss, remapn, lnetwork)
6786
6787! lanavari, lanavarb, lanavarc, &
6788! lanaattri, lanaattrb, lanaattrc, &
6789! lanavarattri, lanavarattrb, lanavarattrc, &
6790! ldativari, ldativarb, ldativarc, &
6791! ldatiattri, ldatiattrb, ldatiattrc, &
6792! ldativarattri, ldativarattrb, ldativarattrc
6793! Faccio la riforma fisica dei volumi
6794CALL vol7d_reform_finalr(this, that, &
6795 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6796 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6797CALL vol7d_reform_finald(this, that, &
6798 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6799 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6800CALL vol7d_reform_finali(this, that, &
6801 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6802 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6803CALL vol7d_reform_finalb(this, that, &
6804 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6805 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6806CALL vol7d_reform_finalc(this, that, &
6807 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6808 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6809
6810! Dealloco i vettori di rimappatura
6811IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6812IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6813IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6814IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6815IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6816
6817! Ricreo gli indici var-attr
6818CALL vol7d_set_attr_ind(that)
6819that%time_definition = this%time_definition
6820
6821END SUBROUTINE vol7d_copy
6822
6823
6824!> Metodo per riformare in varie maniere un oggetto vol7d.
6825!! Equivale ad una copia (vedi ::vol7d_copy)
6826!! seguita dalla distruzione del volume iniziale e alla
6827!! sua riassegnazione al volume copiato. Ha senso se almeno uno dei parametri
6828!! \a sort, \a uniq o \a miss è fornito uguale a \c .TRUE., altrimenti
6829!! è solo una perdita di tempo.
6830!! Può essere utile, ad esempio, per eliminare stazioni
6831!! o istanti temporali indesiderati, basta assegnare il loro corrispondente
6832!! elemento del descrittore a valore mancante e chiamare vol7d_reform
6833!! con miss=.TRUE. .
6834SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6835 lsort_time, lsort_timerange, lsort_level, &
6836 ltime, ltimerange, llevel, lana, lnetwork, &
6837 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6838 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6839 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6840 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6841 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6842 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6843 ,purgeana)
6844TYPE(vol7d),INTENT(INOUT) :: this !< oggetto da riformare
6845LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
6846LOGICAL,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)
6847LOGICAL,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
6848LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
6849LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
6850LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
6851!> se fornito, deve essere un vettore logico della stessa lunghezza di
6852!! this%time indicante quali elementi della dimensione \a time
6853!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
6854!! nel volume copiato; in alternativa può essere un vettore di
6855!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
6856!! gli elementi (utile principalmente per le variabili); è compatibile
6857!! col parametro \a miss
6858LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6859LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:) !< come il precedente per la dimensione \a timerange
6860LOGICAL,INTENT(IN),OPTIONAL :: llevel(:) !< come il precedente per la dimensione \a level
6861LOGICAL,INTENT(IN),OPTIONAL :: lana(:) !< come il precedente per la dimensione \a ana
6862LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:) !< come il precedente per la dimensione \a network
6863!> come il precedente per tutte le possibili dimensioni variabile
6864LOGICAL,INTENT(in),OPTIONAL :: &
6865 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6866 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6867 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6868 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6869 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6870 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6871LOGICAL,INTENT(IN),OPTIONAL :: purgeana !< if true remove ana with all data missing
6872
6873TYPE(vol7d) :: v7dtmp
6874logical,allocatable :: llana(:)
6875integer :: i
6876
6877CALL vol7d_copy(this, v7dtmp, sort, unique, miss, &
6878 lsort_time, lsort_timerange, lsort_level, &
6879 ltime, ltimerange, llevel, lana, lnetwork, &
6880 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6881 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6882 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6883 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6884 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6885 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6886
6887! destroy old volume
6888CALL delete(this)
6889
6890if (optio_log(purgeana)) then
6891 allocate(llana(size(v7dtmp%ana)))
6892 llana =.false.
6893 do i =1,size(v7dtmp%ana)
6894 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6895 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6896 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6897 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6898 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6899 end do
6900 CALL vol7d_copy(v7dtmp, this,lana=llana)
6901 CALL delete(v7dtmp)
6902 deallocate(llana)
6903else
6904 this=v7dtmp
6905end if
6906
6907END SUBROUTINE vol7d_reform
6908
6909
6910!> Sorts the sortable dimensions in the volume \a this only when necessary.
6911!! Most of the times, the time, timerange and level dimensions in a
6912!! vol7d object are correctly sorted; on the other side many methods
6913!! strictly rely on this fact in order to work correctly. This method
6914!! performs a quick check and sorts the required dimensions only if
6915!! they are not sorted in ascending order yet, improving safety
6916!! without impairing much performance.
6917SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6918TYPE(vol7d),INTENT(INOUT) :: this !< object to be sorted
6919LOGICAL,OPTIONAL,INTENT(in) :: lsort_time !< if present and \a .TRUE., sort time dimension if it is not sorted in ascending order
6920LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange !< if present and \a .TRUE., sort timerange dimension if it is not sorted in ascending order
6921LOGICAL,OPTIONAL,INTENT(in) :: lsort_level !< if present and \a .TRUE., sort vertical level dimension if it is not sorted in ascending order
6922
6923INTEGER :: i
6924LOGICAL :: to_be_sorted
6925
6926to_be_sorted = .false.
6927CALL vol7d_alloc_vol(this) ! usual safety check
6928
6929IF (optio_log(lsort_time)) THEN
6930 DO i = 2, SIZE(this%time)
6931 IF (this%time(i) < this%time(i-1)) THEN
6932 to_be_sorted = .true.
6933 EXIT
6934 ENDIF
6935 ENDDO
6936ENDIF
6937IF (optio_log(lsort_timerange)) THEN
6938 DO i = 2, SIZE(this%timerange)
6939 IF (this%timerange(i) < this%timerange(i-1)) THEN
6940 to_be_sorted = .true.
6941 EXIT
6942 ENDIF
6943 ENDDO
6944ENDIF
6945IF (optio_log(lsort_level)) THEN
6946 DO i = 2, SIZE(this%level)
6947 IF (this%level(i) < this%level(i-1)) THEN
6948 to_be_sorted = .true.
6949 EXIT
6950 ENDIF
6951 ENDDO
6952ENDIF
6953
6954IF (to_be_sorted) CALL vol7d_reform(this, &
6955 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6956
6957END SUBROUTINE vol7d_smart_sort
6958
6959!> Filter the contents of a volume keeping only desired data.
6960!! This subroutine filters a vol7d object by keeping only a subset of
6961!! the data contained. It can keep only times within a specified
6962!! interval, only station networks contained in a list and only
6963!! specified station or data variables. If a filter parameter is not
6964!! provided, no filtering will take place according to that criterion.
6965!! The volume is reallocated keeping only the desired data.
6966SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6967TYPE(vol7d),INTENT(inout) :: this !< volume to be filtered
6968CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:) !< list of station variables to be kept, if not provided or of zero length, all variables are kept
6969CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:) !< list of data variables to be kept, if not provided or of zero length, all variables are kept
6970TYPE(vol7d_network),OPTIONAL :: nl(:) !< list of station networks to be kept, if not provided or of zero length, all networks are kept
6971TYPE(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
6972TYPE(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
6973
6974INTEGER :: i
6975
6976IF (PRESENT(avl)) THEN
6977 IF (SIZE(avl) > 0) THEN
6978
6979 IF (ASSOCIATED(this%anavar%r)) THEN
6980 DO i = 1, SIZE(this%anavar%r)
6981 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6982 ENDDO
6983 ENDIF
6984
6985 IF (ASSOCIATED(this%anavar%i)) THEN
6986 DO i = 1, SIZE(this%anavar%i)
6987 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6988 ENDDO
6989 ENDIF
6990
6991 IF (ASSOCIATED(this%anavar%b)) THEN
6992 DO i = 1, SIZE(this%anavar%b)
6993 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6994 ENDDO
6995 ENDIF
6996
6997 IF (ASSOCIATED(this%anavar%d)) THEN
6998 DO i = 1, SIZE(this%anavar%d)
6999 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
7000 ENDDO
7001 ENDIF
7002
7003 IF (ASSOCIATED(this%anavar%c)) THEN
7004 DO i = 1, SIZE(this%anavar%c)
7005 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
7006 ENDDO
7007 ENDIF
7008
7009 ENDIF
7010ENDIF
7011
7012
7013IF (PRESENT(vl)) THEN
7014 IF (size(vl) > 0) THEN
7015 IF (ASSOCIATED(this%dativar%r)) THEN
7016 DO i = 1, SIZE(this%dativar%r)
7017 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
7018 ENDDO
7019 ENDIF
7020
7021 IF (ASSOCIATED(this%dativar%i)) THEN
7022 DO i = 1, SIZE(this%dativar%i)
7023 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
7024 ENDDO
7025 ENDIF
7026
7027 IF (ASSOCIATED(this%dativar%b)) THEN
7028 DO i = 1, SIZE(this%dativar%b)
7029 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
7030 ENDDO
7031 ENDIF
7032
7033 IF (ASSOCIATED(this%dativar%d)) THEN
7034 DO i = 1, SIZE(this%dativar%d)
7035 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
7036 ENDDO
7037 ENDIF
7038
7039 IF (ASSOCIATED(this%dativar%c)) THEN
7040 DO i = 1, SIZE(this%dativar%c)
7041 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7042 ENDDO
7043 ENDIF
7044
7045 IF (ASSOCIATED(this%dativar%c)) THEN
7046 DO i = 1, SIZE(this%dativar%c)
7047 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7048 ENDDO
7049 ENDIF
7050
7051 ENDIF
7052ENDIF
7053
7054IF (PRESENT(nl)) THEN
7055 IF (SIZE(nl) > 0) THEN
7056 DO i = 1, SIZE(this%network)
7057 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
7058 ENDDO
7059 ENDIF
7060ENDIF
7061
7062IF (PRESENT(s_d)) THEN
7063 IF (c_e(s_d)) THEN
7064 WHERE (this%time < s_d)
7065 this%time = datetime_miss
7066 END WHERE
7067 ENDIF
7068ENDIF
7069
7070IF (PRESENT(e_d)) THEN
7071 IF (c_e(e_d)) THEN
7072 WHERE (this%time > e_d)
7073 this%time = datetime_miss
7074 END WHERE
7075 ENDIF
7076ENDIF
7077
7078CALL vol7d_reform(this, miss=.true.)
7079
7080END SUBROUTINE vol7d_filter
7081
7082
7083!> Metodo per convertire i volumi di dati di un oggetto vol7d in dati
7084!! reali dove possibile. L'oggetto convertito è una copia completa
7085!! dell'originale che può essere quindi distrutto dopo la chiamata.
7086!! Per i dati di anagrafica, al momento sono convertiti solo
7087!! i dati CHARACTER se è passato \a anaconv=.TRUE.
7088!! Gli attributi non sono toccati.
7089SUBROUTINE vol7d_convr(this, that, anaconv)
7090TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
7091TYPE(vol7d),INTENT(INOUT) :: that !< oggetto convertito
7092LOGICAL,OPTIONAL,INTENT(in) :: anaconv !< converti anche anagrafica
7093INTEGER :: i
7094LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
7095TYPE(vol7d) :: v7d_tmp
7096
7097IF (optio_log(anaconv)) THEN
7098 acp=fv
7099 acn=tv
7100ELSE
7101 acp=tv
7102 acn=fv
7103ENDIF
7104
7105! Volume con solo i dati reali e tutti gli attributi
7106! l'anagrafica e` copiata interamente se necessario
7107CALL vol7d_copy(this, that, &
7108 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7109 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7110
7111! Volume solo di dati double
7112CALL vol7d_copy(this, v7d_tmp, &
7113 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7114 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7115 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7116 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7117 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7118 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7119
7120! converto a dati reali
7121IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7122
7123 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7124! alloco i dati reali e vi trasferisco i double
7125 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7126 SIZE(v7d_tmp%volanad, 3)))
7127 DO i = 1, SIZE(v7d_tmp%anavar%d)
7128 v7d_tmp%volanar(:,i,:) = &
7129 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7130 ENDDO
7131 DEALLOCATE(v7d_tmp%volanad)
7132! trasferisco le variabili
7133 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7134 NULLIFY(v7d_tmp%anavar%d)
7135 ENDIF
7136
7137 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7138! alloco i dati reali e vi trasferisco i double
7139 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7140 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7141 SIZE(v7d_tmp%voldatid, 6)))
7142 DO i = 1, SIZE(v7d_tmp%dativar%d)
7143 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7144 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7145 ENDDO
7146 DEALLOCATE(v7d_tmp%voldatid)
7147! trasferisco le variabili
7148 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7149 NULLIFY(v7d_tmp%dativar%d)
7150 ENDIF
7151
7152! fondo con il volume definitivo
7153 CALL vol7d_merge(that, v7d_tmp)
7154ELSE
7155 CALL delete(v7d_tmp)
7156ENDIF
7157
7158
7159! Volume solo di dati interi
7160CALL vol7d_copy(this, v7d_tmp, &
7161 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7162 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7163 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7164 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7165 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7166 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7167
7168! converto a dati reali
7169IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7170
7171 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7172! alloco i dati reali e vi trasferisco gli interi
7173 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7174 SIZE(v7d_tmp%volanai, 3)))
7175 DO i = 1, SIZE(v7d_tmp%anavar%i)
7176 v7d_tmp%volanar(:,i,:) = &
7177 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7178 ENDDO
7179 DEALLOCATE(v7d_tmp%volanai)
7180! trasferisco le variabili
7181 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7182 NULLIFY(v7d_tmp%anavar%i)
7183 ENDIF
7184
7185 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7186! alloco i dati reali e vi trasferisco gli interi
7187 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7188 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7189 SIZE(v7d_tmp%voldatii, 6)))
7190 DO i = 1, SIZE(v7d_tmp%dativar%i)
7191 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7192 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7193 ENDDO
7194 DEALLOCATE(v7d_tmp%voldatii)
7195! trasferisco le variabili
7196 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7197 NULLIFY(v7d_tmp%dativar%i)
7198 ENDIF
7199
7200! fondo con il volume definitivo
7201 CALL vol7d_merge(that, v7d_tmp)
7202ELSE
7203 CALL delete(v7d_tmp)
7204ENDIF
7205
7206
7207! Volume solo di dati byte
7208CALL vol7d_copy(this, v7d_tmp, &
7209 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7210 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7211 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7212 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7213 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7214 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7215
7216! converto a dati reali
7217IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7218
7219 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7220! alloco i dati reali e vi trasferisco i byte
7221 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7222 SIZE(v7d_tmp%volanab, 3)))
7223 DO i = 1, SIZE(v7d_tmp%anavar%b)
7224 v7d_tmp%volanar(:,i,:) = &
7225 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7226 ENDDO
7227 DEALLOCATE(v7d_tmp%volanab)
7228! trasferisco le variabili
7229 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7230 NULLIFY(v7d_tmp%anavar%b)
7231 ENDIF
7232
7233 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7234! alloco i dati reali e vi trasferisco i byte
7235 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7236 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7237 SIZE(v7d_tmp%voldatib, 6)))
7238 DO i = 1, SIZE(v7d_tmp%dativar%b)
7239 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7240 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7241 ENDDO
7242 DEALLOCATE(v7d_tmp%voldatib)
7243! trasferisco le variabili
7244 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7245 NULLIFY(v7d_tmp%dativar%b)
7246 ENDIF
7247
7248! fondo con il volume definitivo
7249 CALL vol7d_merge(that, v7d_tmp)
7250ELSE
7251 CALL delete(v7d_tmp)
7252ENDIF
7253
7254
7255! Volume solo di dati character
7256CALL vol7d_copy(this, v7d_tmp, &
7257 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7258 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7259 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7260 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7261 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7262 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7263
7264! converto a dati reali
7265IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
7266
7267 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
7268! alloco i dati reali e vi trasferisco i character
7269 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
7270 SIZE(v7d_tmp%volanac, 3)))
7271 DO i = 1, SIZE(v7d_tmp%anavar%c)
7272 v7d_tmp%volanar(:,i,:) = &
7273 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
7274 ENDDO
7275 DEALLOCATE(v7d_tmp%volanac)
7276! trasferisco le variabili
7277 v7d_tmp%anavar%r => v7d_tmp%anavar%c
7278 NULLIFY(v7d_tmp%anavar%c)
7279 ENDIF
7280
7281 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
7282! alloco i dati reali e vi trasferisco i character
7283 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
7284 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
7285 SIZE(v7d_tmp%voldatic, 6)))
7286 DO i = 1, SIZE(v7d_tmp%dativar%c)
7287 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7288 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
7289 ENDDO
7290 DEALLOCATE(v7d_tmp%voldatic)
7291! trasferisco le variabili
7292 v7d_tmp%dativar%r => v7d_tmp%dativar%c
7293 NULLIFY(v7d_tmp%dativar%c)
7294 ENDIF
7295
7296! fondo con il volume definitivo
7297 CALL vol7d_merge(that, v7d_tmp)
7298ELSE
7299 CALL delete(v7d_tmp)
7300ENDIF
7301
7302END SUBROUTINE vol7d_convr
7303
7304
7305!> Metodo per ottenere solo le differenze tra due oggetti vol7d.
7306!! Il primo volume viene confrontato col secondo; nel secondo volume ovunque
7307!! i dati confrontati siano coincidenti viene impostato valore mancante.
7308SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
7309TYPE(vol7d),INTENT(IN) :: this !< primo volume da confrontare
7310TYPE(vol7d),INTENT(OUT) :: that !< secondo volume da confrontare in cui eliminare i dati coincidenti
7311logical , optional, intent(in) :: data_only !< attiva l'elaborazione dei soli dati e non dell'anagrafica (default: .false.)
7312logical , optional, intent(in) :: ana !< attiva l'elaborazione dell'anagrafica (coordinate e ident) (default: .false.)
7313logical :: ldata_only,lana
7314
7315IF (PRESENT(data_only)) THEN
7316 ldata_only = data_only
7317ELSE
7318 ldata_only = .false.
7319ENDIF
7320
7321IF (PRESENT(ana)) THEN
7322 lana = ana
7323ELSE
7324 lana = .false.
7325ENDIF
7326
7327
7328#undef VOL7D_POLY_ARRAY
7329#define VOL7D_POLY_ARRAY voldati
7330#include "vol7d_class_diff.F90"
7331#undef VOL7D_POLY_ARRAY
7332#define VOL7D_POLY_ARRAY voldatiattr
7333#include "vol7d_class_diff.F90"
7334#undef VOL7D_POLY_ARRAY
7335
7336if ( .not. ldata_only) then
7337
7338#define VOL7D_POLY_ARRAY volana
7339#include "vol7d_class_diff.F90"
7340#undef VOL7D_POLY_ARRAY
7341#define VOL7D_POLY_ARRAY volanaattr
7342#include "vol7d_class_diff.F90"
7343#undef VOL7D_POLY_ARRAY
7344
7345 if(lana)then
7346 where ( this%ana == that%ana )
7347 that%ana = vol7d_ana_miss
7348 end where
7349 end if
7350
7351end if
7352
7353
7354
7355END SUBROUTINE vol7d_diff_only
7356
7357
7358
7359! Creo le routine da ripetere per i vari tipi di dati di v7d
7360! tramite un template e il preprocessore
7361#undef VOL7D_POLY_TYPE
7362#undef VOL7D_POLY_TYPES
7363#define VOL7D_POLY_TYPE REAL
7364#define VOL7D_POLY_TYPES r
7365#include "vol7d_class_type_templ.F90"
7366#undef VOL7D_POLY_TYPE
7367#undef VOL7D_POLY_TYPES
7368#define VOL7D_POLY_TYPE DOUBLE PRECISION
7369#define VOL7D_POLY_TYPES d
7370#include "vol7d_class_type_templ.F90"
7371#undef VOL7D_POLY_TYPE
7372#undef VOL7D_POLY_TYPES
7373#define VOL7D_POLY_TYPE INTEGER
7374#define VOL7D_POLY_TYPES i
7375#include "vol7d_class_type_templ.F90"
7376#undef VOL7D_POLY_TYPE
7377#undef VOL7D_POLY_TYPES
7378#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
7379#define VOL7D_POLY_TYPES b
7380#include "vol7d_class_type_templ.F90"
7381#undef VOL7D_POLY_TYPE
7382#undef VOL7D_POLY_TYPES
7383#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
7384#define VOL7D_POLY_TYPES c
7385#include "vol7d_class_type_templ.F90"
7386
7387! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
7388! tramite un template e il preprocessore
7389#define VOL7D_SORT
7390#undef VOL7D_NO_ZERO_ALLOC
7391#undef VOL7D_POLY_TYPE
7392#define VOL7D_POLY_TYPE datetime
7393#include "vol7d_class_desc_templ.F90"
7394#undef VOL7D_POLY_TYPE
7395#define VOL7D_POLY_TYPE vol7d_timerange
7396#include "vol7d_class_desc_templ.F90"
7397#undef VOL7D_POLY_TYPE
7398#define VOL7D_POLY_TYPE vol7d_level
7399#include "vol7d_class_desc_templ.F90"
7400#undef VOL7D_SORT
7401#undef VOL7D_POLY_TYPE
7402#define VOL7D_POLY_TYPE vol7d_network
7403#include "vol7d_class_desc_templ.F90"
7404#undef VOL7D_POLY_TYPE
7405#define VOL7D_POLY_TYPE vol7d_ana
7406#include "vol7d_class_desc_templ.F90"
7407#define VOL7D_NO_ZERO_ALLOC
7408#undef VOL7D_POLY_TYPE
7409#define VOL7D_POLY_TYPE vol7d_var
7410#include "vol7d_class_desc_templ.F90"
7411
7412!>\brief Scrittura su file di un volume Vol7d.
7413!! Scrittura su file unformatted di un intero volume Vol7d.
7414!! Il volume viene serializzato e scritto su file.
7415!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
7416!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
7417!! tali parametri saranno in output.
7418!! Se non viene fornito il nome file viene utilizzato un file di default con nome pari al nome del programma in
7419!! esecuzione con postfisso ".v7d".
7420!! Come parametro opzionale c'è la description che insieme alla data corrente viene inserita nell'header del file.
7421subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
7422
7423TYPE(vol7d),INTENT(IN) :: this !< volume vol7d da scrivere
7424integer,optional,intent(inout) :: unit !< unità su cui scrivere; se passata =0 ritorna il valore rielaborato (default =rielaborato internamente con getlun )
7425character(len=*),intent(in),optional :: filename !< nome del file su cui scrivere
7426character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
7427character(len=*),INTENT(IN),optional :: description !< descrizione del volume
7428
7429integer :: lunit
7430character(len=254) :: ldescription,arg,lfilename
7431integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7432 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7433 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7434 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7435 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7436 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7437 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7438!integer :: im,id,iy
7439integer :: tarray(8)
7440logical :: opened,exist
7441
7442 nana=0
7443 ntime=0
7444 ntimerange=0
7445 nlevel=0
7446 nnetwork=0
7447 ndativarr=0
7448 ndativari=0
7449 ndativarb=0
7450 ndativard=0
7451 ndativarc=0
7452 ndatiattrr=0
7453 ndatiattri=0
7454 ndatiattrb=0
7455 ndatiattrd=0
7456 ndatiattrc=0
7457 ndativarattrr=0
7458 ndativarattri=0
7459 ndativarattrb=0
7460 ndativarattrd=0
7461 ndativarattrc=0
7462 nanavarr=0
7463 nanavari=0
7464 nanavarb=0
7465 nanavard=0
7466 nanavarc=0
7467 nanaattrr=0
7468 nanaattri=0
7469 nanaattrb=0
7470 nanaattrd=0
7471 nanaattrc=0
7472 nanavarattrr=0
7473 nanavarattri=0
7474 nanavarattrb=0
7475 nanavarattrd=0
7476 nanavarattrc=0
7477
7478
7479!call idate(im,id,iy)
7480call date_and_time(values=tarray)
7481call getarg(0,arg)
7482
7483if (present(description))then
7484 ldescription=description
7485else
7486 ldescription="Vol7d generated by: "//trim(arg)
7487end if
7488
7489if (.not. present(unit))then
7490 lunit=getunit()
7491else
7492 if (unit==0)then
7493 lunit=getunit()
7494 unit=lunit
7495 else
7496 lunit=unit
7497 end if
7498end if
7499
7500lfilename=trim(arg)//".v7d"
7501if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
7502
7503if (present(filename))then
7504 if (filename /= "")then
7505 lfilename=filename
7506 end if
7507end if
7508
7509if (present(filename_auto))filename_auto=lfilename
7510
7511
7512inquire(unit=lunit,opened=opened)
7513if (.not. opened) then
7514! inquire(file=lfilename, EXIST=exist)
7515! IF (exist) THEN
7516! CALL l4f_log(L4F_FATAL, &
7517! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
7518! CALL raise_fatal_error()
7519! ENDIF
7520 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
7521 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7522end if
7523
7524if (associated(this%ana)) nana=size(this%ana)
7525if (associated(this%time)) ntime=size(this%time)
7526if (associated(this%timerange)) ntimerange=size(this%timerange)
7527if (associated(this%level)) nlevel=size(this%level)
7528if (associated(this%network)) nnetwork=size(this%network)
7529
7530if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
7531if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
7532if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
7533if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
7534if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
7535
7536if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
7537if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
7538if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
7539if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
7540if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
7541
7542if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
7543if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
7544if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
7545if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
7546if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
7547
7548if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
7549if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
7550if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
7551if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
7552if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
7553
7554if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
7555if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
7556if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
7557if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
7558if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
7559
7560if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
7561if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
7562if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
7563if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
7564if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
7565
7566write(unit=lunit)ldescription
7567write(unit=lunit)tarray
7568
7569write(unit=lunit)&
7570 nana, ntime, ntimerange, nlevel, nnetwork, &
7571 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7572 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7573 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7574 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7575 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7576 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7577 this%time_definition
7578
7579
7580!write(unit=lunit)this
7581
7582
7583!! prime 5 dimensioni
7584if (associated(this%ana)) call write_unit(this%ana, lunit)
7585if (associated(this%time)) call write_unit(this%time, lunit)
7586if (associated(this%level)) write(unit=lunit)this%level
7587if (associated(this%timerange)) write(unit=lunit)this%timerange
7588if (associated(this%network)) write(unit=lunit)this%network
7589
7590 !! 6a dimensione: variabile dell'anagrafica e dei dati
7591 !! con relativi attributi e in 5 tipi diversi
7592
7593if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
7594if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
7595if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
7596if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
7597if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
7598
7599if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
7600if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
7601if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
7602if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
7603if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
7604
7605if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
7606if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
7607if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
7608if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
7609if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
7610
7611if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
7612if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
7613if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
7614if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
7615if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
7616
7617if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
7618if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
7619if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
7620if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
7621if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
7622
7623if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
7624if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
7625if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
7626if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
7627if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
7628
7629!! Volumi di valori e attributi per anagrafica e dati
7630
7631if (associated(this%volanar)) write(unit=lunit)this%volanar
7632if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
7633if (associated(this%voldatir)) write(unit=lunit)this%voldatir
7634if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
7635
7636if (associated(this%volanai)) write(unit=lunit)this%volanai
7637if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
7638if (associated(this%voldatii)) write(unit=lunit)this%voldatii
7639if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
7640
7641if (associated(this%volanab)) write(unit=lunit)this%volanab
7642if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
7643if (associated(this%voldatib)) write(unit=lunit)this%voldatib
7644if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
7645
7646if (associated(this%volanad)) write(unit=lunit)this%volanad
7647if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
7648if (associated(this%voldatid)) write(unit=lunit)this%voldatid
7649if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
7650
7651if (associated(this%volanac)) write(unit=lunit)this%volanac
7652if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
7653if (associated(this%voldatic)) write(unit=lunit)this%voldatic
7654if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
7655
7656if (.not. present(unit)) close(unit=lunit)
7657
7658end subroutine vol7d_write_on_file
7659
7660
7661!>\brief Lettura da file di un volume Vol7d.
7662!! Lettura da file unformatted di un intero volume Vol7d.
7663!! Questa subroutine comprende vol7d_alloc e vol7d_alloc_vol.
7664!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
7665!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
7666!! tali parametri saranno in output.
7667
7668
7669subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
7670
7671TYPE(vol7d),INTENT(OUT) :: this !< Volume vol7d da leggere
7672integer,intent(inout),optional :: unit !< unità su cui è stato aperto un file; se =0 rielaborato internamente (default = elaborato internamente con getunit)
7673character(len=*),INTENT(in),optional :: filename !< nome del file eventualmente da aprire (default = (nome dell'eseguibile)//.v7d )
7674character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
7675character(len=*),INTENT(out),optional :: description !< descrizione del volume letto
7676integer,intent(out),optional :: tarray(8) !< vettore come definito da "date_and_time" della data di scrittura del volume
7677
7678
7679integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7680 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7681 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7682 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7683 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7684 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7685 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7686
7687character(len=254) :: ldescription,lfilename,arg
7688integer :: ltarray(8),lunit,ios
7689logical :: opened,exist
7690
7691
7692call getarg(0,arg)
7693
7694if (.not. present(unit))then
7695 lunit=getunit()
7696else
7697 if (unit==0)then
7698 lunit=getunit()
7699 unit=lunit
7700 else
7701 lunit=unit
7702 end if
7703end if
7704
7705lfilename=trim(arg)//".v7d"
7706if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
7707
7708if (present(filename))then
7709 if (filename /= "")then
7710 lfilename=filename
7711 end if
7712end if
7713
7714if (present(filename_auto))filename_auto=lfilename
7715
7716
7717inquire(unit=lunit,opened=opened)
7718IF (.NOT. opened) THEN
7719 inquire(file=lfilename,exist=exist)
7720 IF (.NOT.exist) THEN
7721 CALL l4f_log(l4f_fatal, &
7722 'in vol7d_read_from_file, file does not exists, cannot open')
7723 CALL raise_fatal_error()
7724 ENDIF
7725 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
7726 status='OLD', action='READ')
7727 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7728end if
7729
7730
7731call init(this)
7732read(unit=lunit,iostat=ios)ldescription
7733
7734if (ios < 0) then ! A negative value indicates that the End of File or End of Record
7735 call vol7d_alloc (this)
7736 call vol7d_alloc_vol (this)
7737 if (present(description))description=ldescription
7738 if (present(tarray))tarray=ltarray
7739 if (.not. present(unit)) close(unit=lunit)
7740end if
7741
7742read(unit=lunit)ltarray
7743
7744CALL l4f_log(l4f_info, 'Reading vol7d from file')
7745CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
7746CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
7747 trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
7748
7749if (present(description))description=ldescription
7750if (present(tarray))tarray=ltarray
7751
7752read(unit=lunit)&
7753 nana, ntime, ntimerange, nlevel, nnetwork, &
7754 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7755 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7756 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7757 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7758 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7759 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7760 this%time_definition
7761
7762call vol7d_alloc (this, &
7763 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
7764 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
7765 ndativard=ndativard, ndativarc=ndativarc,&
7766 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
7767 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
7768 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
7769 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
7770 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
7771 nanavard=nanavard, nanavarc=nanavarc,&
7772 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
7773 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
7774 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7775 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7776
7777
7778if (associated(this%ana)) call read_unit(this%ana, lunit)
7779if (associated(this%time)) call read_unit(this%time, lunit)
7780if (associated(this%level)) read(unit=lunit)this%level
7781if (associated(this%timerange)) read(unit=lunit)this%timerange
7782if (associated(this%network)) read(unit=lunit)this%network
7783
7784if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7785if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7786if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7787if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7788if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7789
7790if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7791if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7792if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7793if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7794if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7795
7796if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7797if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7798if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7799if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7800if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7801
7802if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7803if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7804if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7805if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7806if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7807
7808if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7809if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7810if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7811if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7812if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7813
7814if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7815if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7816if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7817if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7818if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7819
7820call vol7d_alloc_vol (this)
7821
7822!! Volumi di valori e attributi per anagrafica e dati
7823
7824if (associated(this%volanar)) read(unit=lunit)this%volanar
7825if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7826if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7827if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7828
7829if (associated(this%volanai)) read(unit=lunit)this%volanai
7830if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7831if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7832if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7833
7834if (associated(this%volanab)) read(unit=lunit)this%volanab
7835if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7836if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7837if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7838
7839if (associated(this%volanad)) read(unit=lunit)this%volanad
7840if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7841if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7842if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7843
7844if (associated(this%volanac)) read(unit=lunit)this%volanac
7845if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7846if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7847if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7848
7849if (.not. present(unit)) close(unit=lunit)
7850
7851end subroutine vol7d_read_from_file
7852
7853
7854! to double precision
7855elemental doubleprecision function doubledatd(voldat,var)
7856doubleprecision,intent(in) :: voldat
7857type(vol7d_var),intent(in) :: var
7858
7859doubledatd=voldat
7860
7861end function doubledatd
7862
7863
7864elemental doubleprecision function doubledatr(voldat,var)
7865real,intent(in) :: voldat
7866type(vol7d_var),intent(in) :: var
7867
7868if (c_e(voldat))then
7869 doubledatr=dble(voldat)
7870else
7871 doubledatr=dmiss
7872end if
7873
7874end function doubledatr
7875
7876
7877elemental doubleprecision function doubledati(voldat,var)
7878integer,intent(in) :: voldat
7879type(vol7d_var),intent(in) :: var
7880
7881if (c_e(voldat)) then
7882 if (c_e(var%scalefactor))then
7883 doubledati=dble(voldat)/10.d0**var%scalefactor
7884 else
7885 doubledati=dble(voldat)
7886 endif
7887else
7888 doubledati=dmiss
7889end if
7890
7891end function doubledati
7892
7893
7894elemental doubleprecision function doubledatb(voldat,var)
7895integer(kind=int_b),intent(in) :: voldat
7896type(vol7d_var),intent(in) :: var
7897
7898if (c_e(voldat)) then
7899 if (c_e(var%scalefactor))then
7900 doubledatb=dble(voldat)/10.d0**var%scalefactor
7901 else
7902 doubledatb=dble(voldat)
7903 endif
7904else
7905 doubledatb=dmiss
7906end if
7907
7908end function doubledatb
7909
7910
7911elemental doubleprecision function doubledatc(voldat,var)
7912CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7913type(vol7d_var),intent(in) :: var
7914
7915doubledatc = c2d(voldat)
7916if (c_e(doubledatc) .and. c_e(var%scalefactor))then
7917 doubledatc=doubledatc/10.d0**var%scalefactor
7918end if
7919
7920end function doubledatc
7921
7922
7923! to integer
7924elemental integer function integerdatd(voldat,var)
7925doubleprecision,intent(in) :: voldat
7926type(vol7d_var),intent(in) :: var
7927
7928if (c_e(voldat))then
7929 if (c_e(var%scalefactor)) then
7930 integerdatd=nint(voldat*10d0**var%scalefactor)
7931 else
7932 integerdatd=nint(voldat)
7933 endif
7934else
7935 integerdatd=imiss
7936end if
7937
7938end function integerdatd
7939
7940
7941elemental integer function integerdatr(voldat,var)
7942real,intent(in) :: voldat
7943type(vol7d_var),intent(in) :: var
7944
7945if (c_e(voldat))then
7946 if (c_e(var%scalefactor)) then
7947 integerdatr=nint(voldat*10d0**var%scalefactor)
7948 else
7949 integerdatr=nint(voldat)
7950 endif
7951else
7952 integerdatr=imiss
7953end if
7954
7955end function integerdatr
7956
7957
7958elemental integer function integerdati(voldat,var)
7959integer,intent(in) :: voldat
7960type(vol7d_var),intent(in) :: var
7961
7962integerdati=voldat
7963
7964end function integerdati
7965
7966
7967elemental integer function integerdatb(voldat,var)
7968integer(kind=int_b),intent(in) :: voldat
7969type(vol7d_var),intent(in) :: var
7970
7971if (c_e(voldat))then
7972 integerdatb=voldat
7973else
7974 integerdatb=imiss
7975end if
7976
7977end function integerdatb
7978
7979
7980elemental integer function integerdatc(voldat,var)
7981CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7982type(vol7d_var),intent(in) :: var
7983
7984integerdatc=c2i(voldat)
7985
7986end function integerdatc
7987
7988
7989! to real
7990elemental real function realdatd(voldat,var)
7991doubleprecision,intent(in) :: voldat
7992type(vol7d_var),intent(in) :: var
7993
7994if (c_e(voldat))then
7995 realdatd=real(voldat)
7996else
7997 realdatd=rmiss
7998end if
7999
8000end function realdatd
8001
8002
8003elemental real function realdatr(voldat,var)
8004real,intent(in) :: voldat
8005type(vol7d_var),intent(in) :: var
8006
8007realdatr=voldat
8008
8009end function realdatr
8010
8011
8012elemental real function realdati(voldat,var)
8013integer,intent(in) :: voldat
8014type(vol7d_var),intent(in) :: var
8015
8016if (c_e(voldat)) then
8017 if (c_e(var%scalefactor))then
8018 realdati=float(voldat)/10.**var%scalefactor
8019 else
8020 realdati=float(voldat)
8021 endif
8022else
8023 realdati=rmiss
8024end if
8025
8026end function realdati
8027
8028
8029elemental real function realdatb(voldat,var)
8030integer(kind=int_b),intent(in) :: voldat
8031type(vol7d_var),intent(in) :: var
8032
8033if (c_e(voldat)) then
8034 if (c_e(var%scalefactor))then
8035 realdatb=float(voldat)/10**var%scalefactor
8036 else
8037 realdatb=float(voldat)
8038 endif
8039else
8040 realdatb=rmiss
8041end if
8042
8043end function realdatb
8044
8045
8046elemental real function realdatc(voldat,var)
8047CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8048type(vol7d_var),intent(in) :: var
8049
8050realdatc=c2r(voldat)
8051if (c_e(realdatc) .and. c_e(var%scalefactor))then
8052 realdatc=realdatc/10.**var%scalefactor
8053end if
8054
8055end function realdatc
8056
8057
8058!> Return an ana volume of a requested variable as real data.
8059!! It returns a 2-d array of the proper shape (ana x network) for the
8060!! ana variable requested, converted to real type. If the conversion
8061!! fails or if the variable is not contained in the ana volume,
8062!! missing data are returned.
8063FUNCTION realanavol(this, var) RESULT(vol)
8064TYPE(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
8065TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
8066REAL :: vol(SIZE(this%ana),size(this%network))
8067
8068CHARACTER(len=1) :: dtype
8069INTEGER :: indvar
8070
8071dtype = cmiss
8072indvar = index(this%anavar, var, type=dtype)
8073
8074IF (indvar > 0) THEN
8075 SELECT CASE (dtype)
8076 CASE("d")
8077 vol = realdat(this%volanad(:,indvar,:), var)
8078 CASE("r")
8079 vol = this%volanar(:,indvar,:)
8080 CASE("i")
8081 vol = realdat(this%volanai(:,indvar,:), var)
8082 CASE("b")
8083 vol = realdat(this%volanab(:,indvar,:), var)
8084 CASE("c")
8085 vol = realdat(this%volanac(:,indvar,:), var)
8086 CASE default
8087 vol = rmiss
8088 END SELECT
8089ELSE
8090 vol = rmiss
8091ENDIF
8092
8093END FUNCTION realanavol
8094
8095
8096!> Return an ana volume of a requested variable as integer data.
8097!! It returns a 2-d array of the proper shape (ana x network) for the
8098!! ana variable requested, converted to integer type. If the conversion
8099!! fails or if the variable is not contained in the ana volume,
8100!! missing data are returned.
8101FUNCTION integeranavol(this, var) RESULT(vol)
8102TYPE(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
8103TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
8104INTEGER :: vol(SIZE(this%ana),size(this%network))
8105
8106CHARACTER(len=1) :: dtype
8107INTEGER :: indvar
8108
8109dtype = cmiss
8110indvar = index(this%anavar, var, type=dtype)
8111
8112IF (indvar > 0) THEN
8113 SELECT CASE (dtype)
8114 CASE("d")
8115 vol = integerdat(this%volanad(:,indvar,:), var)
8116 CASE("r")
8117 vol = integerdat(this%volanar(:,indvar,:), var)
8118 CASE("i")
8119 vol = this%volanai(:,indvar,:)
8120 CASE("b")
8121 vol = integerdat(this%volanab(:,indvar,:), var)
8122 CASE("c")
8123 vol = integerdat(this%volanac(:,indvar,:), var)
8124 CASE default
8125 vol = imiss
8126 END SELECT
8127ELSE
8128 vol = imiss
8129ENDIF
8130
8131END FUNCTION integeranavol
8132
8133
8134!> Move data for all variables from one coordinate in the character volume to other.
8135!! Only not missing data will be copyed and all attributes will be moved together.
8136!! Usefull to colapse data spread in more indices (level or time or ....).
8137!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
8138!! to obtain a new vol7d with less data shape.
8139subroutine move_datac (v7d,&
8140 indana,indtime,indlevel,indtimerange,indnetwork,&
8141 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8142
8143TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
8144
8145integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
8146integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
8147integer :: inddativar,inddativarattr
8148
8149
8150do inddativar=1,size(v7d%dativar%c)
8151
8152 if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
8153 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8154 ) then
8155
8156 ! dati
8157 v7d%voldatic &
8158 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8159 v7d%voldatic &
8160 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8161
8162
8163 ! attributi
8164 if (associated (v7d%dativarattr%i)) then
8165 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8166 if (inddativarattr > 0 ) then
8167 v7d%voldatiattri &
8168 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8169 v7d%voldatiattri &
8170 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8171 end if
8172 end if
8173
8174 if (associated (v7d%dativarattr%r)) then
8175 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8176 if (inddativarattr > 0 ) then
8177 v7d%voldatiattrr &
8178 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8179 v7d%voldatiattrr &
8180 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8181 end if
8182 end if
8183
8184 if (associated (v7d%dativarattr%d)) then
8185 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8186 if (inddativarattr > 0 ) then
8187 v7d%voldatiattrd &
8188 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8189 v7d%voldatiattrd &
8190 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8191 end if
8192 end if
8193
8194 if (associated (v7d%dativarattr%b)) then
8195 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8196 if (inddativarattr > 0 ) then
8197 v7d%voldatiattrb &
8198 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8199 v7d%voldatiattrb &
8200 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8201 end if
8202 end if
8203
8204 if (associated (v7d%dativarattr%c)) then
8205 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8206 if (inddativarattr > 0 ) then
8207 v7d%voldatiattrc &
8208 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8209 v7d%voldatiattrc &
8210 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8211 end if
8212 end if
8213
8214 end if
8215
8216end do
8217
8218end subroutine move_datac
8219
8220!> Move data for all variables from one coordinate in the real volume to other.
8221!! Only not missing data will be copyed and all attributes will be moved together.
8222!! Usefull to colapse data spread in more indices (level or time or ....).
8223!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
8224!! to obtain a new vol7d with less data shape.
8225subroutine move_datar (v7d,&
8226 indana,indtime,indlevel,indtimerange,indnetwork,&
8227 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8228
8229TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
8230
8231integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
8232integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
8233integer :: inddativar,inddativarattr
8234
8235
8236do inddativar=1,size(v7d%dativar%r)
8237
8238 if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
8239 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8240 ) then
8241
8242 ! dati
8243 v7d%voldatir &
8244 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8245 v7d%voldatir &
8246 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8247
8248
8249 ! attributi
8250 if (associated (v7d%dativarattr%i)) then
8251 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8252 if (inddativarattr > 0 ) then
8253 v7d%voldatiattri &
8254 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8255 v7d%voldatiattri &
8256 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8257 end if
8258 end if
8259
8260 if (associated (v7d%dativarattr%r)) then
8261 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
8262 if (inddativarattr > 0 ) then
8263 v7d%voldatiattrr &
8264 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8265 v7d%voldatiattrr &
8266 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8267 end if
8268 end if
8269
8270 if (associated (v7d%dativarattr%d)) then
8271 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
8272 if (inddativarattr > 0 ) then
8273 v7d%voldatiattrd &
8274 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8275 v7d%voldatiattrd &
8276 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8277 end if
8278 end if
8279
8280 if (associated (v7d%dativarattr%b)) then
8281 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
8282 if (inddativarattr > 0 ) then
8283 v7d%voldatiattrb &
8284 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8285 v7d%voldatiattrb &
8286 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8287 end if
8288 end if
8289
8290 if (associated (v7d%dativarattr%c)) then
8291 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
8292 if (inddativarattr > 0 ) then
8293 v7d%voldatiattrc &
8294 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8295 v7d%voldatiattrc &
8296 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8297 end if
8298 end if
8299
8300 end if
8301
8302end do
8303
8304end subroutine move_datar
8305
8306
8307!> Reduce some dimensions (level and timerage) for semplification (rounding).
8308!! You can use this for simplify and use variables in computation like alchimia
8309!! where fields have to be on the same coordinate
8310!! It return real or character data only: if input is charcter data only it return character otherwise il return
8311!! all the data converted to real.
8312!! examples:
8313!! means in time for short periods and istantaneous values
8314!! 2 meter and surface levels
8315!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
8316!! will be taken (order is by icreasing var index).
8317!! You can use predefined values for classic semplification
8318!! almost_equal_levels and almost_equal_timeranges
8319!! The level or timerange in output will be defined by the first element of level and timerange list
8320subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
8321type(vol7d),intent(inout) :: v7din !< input volume
8322type(vol7d),intent(out) :: v7dout !> output volume
8323type(vol7d_level),intent(in),optional :: level(:) !< almost equal level list
8324type(vol7d_timerange),intent(in),optional :: timerange(:) !< almost equal timerange list
8325!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
8326!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
8327logical,intent(in),optional :: nostatproc !< do not take in account statistical processing code in timerange and P2
8328
8329integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
8330integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
8331type(vol7d_level) :: roundlevel(size(v7din%level))
8332type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
8333type(vol7d) :: v7d_tmp
8334
8335
8336nbin=0
8337
8338if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
8339if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
8340if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
8341if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
8342
8343call init(v7d_tmp)
8344
8345roundlevel=v7din%level
8346
8347if (present(level))then
8348 do ilevel = 1, size(v7din%level)
8349 if ((any(v7din%level(ilevel) .almosteq. level))) then
8350 roundlevel(ilevel)=level(1)
8351 end if
8352 end do
8353end if
8354
8355roundtimerange=v7din%timerange
8356
8357if (present(timerange))then
8358 do itimerange = 1, size(v7din%timerange)
8359 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
8360 roundtimerange(itimerange)=timerange(1)
8361 end if
8362 end do
8363end if
8364
8365!set istantaneous values everywere
8366!preserve p1 for forecast time
8367if (optio_log(nostatproc)) then
8368 roundtimerange(:)%timerange=254
8369 roundtimerange(:)%p2=0
8370end if
8371
8372
8373nana=size(v7din%ana)
8374nlevel=count_distinct(roundlevel,back=.true.)
8375ntime=size(v7din%time)
8376ntimerange=count_distinct(roundtimerange,back=.true.)
8377nnetwork=size(v7din%network)
8378
8379call init(v7d_tmp)
8380
8381if (nbin == 0) then
8382 call copy(v7din,v7d_tmp)
8383else
8384 call vol7d_convr(v7din,v7d_tmp)
8385end if
8386
8387v7d_tmp%level=roundlevel
8388v7d_tmp%timerange=roundtimerange
8389
8390do ilevel=1, size(v7d_tmp%level)
8391 indl=index(v7d_tmp%level,roundlevel(ilevel))
8392 do itimerange=1,size(v7d_tmp%timerange)
8393 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
8394
8395 if (indl /= ilevel .or. indt /= itimerange) then
8396
8397 do iana=1, nana
8398 do itime=1,ntime
8399 do inetwork=1,nnetwork
8400
8401 if (nbin > 0) then
8402 call move_datar (v7d_tmp,&
8403 iana,itime,ilevel,itimerange,inetwork,&
8404 iana,itime,indl,indt,inetwork)
8405 else
8406 call move_datac (v7d_tmp,&
8407 iana,itime,ilevel,itimerange,inetwork,&
8408 iana,itime,indl,indt,inetwork)
8409 end if
8410
8411 end do
8412 end do
8413 end do
8414
8415 end if
8416
8417 end do
8418end do
8419
8420! set to missing level and time > nlevel
8421do ilevel=nlevel+1,size(v7d_tmp%level)
8422 call init (v7d_tmp%level(ilevel))
8423end do
8424
8425do itimerange=ntimerange+1,size(v7d_tmp%timerange)
8426 call init (v7d_tmp%timerange(itimerange))
8427end do
8428
8429!copy with remove
8430CALL copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
8431CALL delete(v7d_tmp)
8432
8433!call display(v7dout)
8434
8435end subroutine v7d_rounding
8436
8437
8438END MODULE vol7d_class
8439
8440!>\example esempio_qc_convert.f90
8441!!\brief Programma esempio semplice per la scrittura su file di un volume vol7d
8442!!
8443!!Programma che scrive su file un volume vol7d letto da una serie di file ASCII.
8444!!Questo programma scrive i dati del clima che poi verranno letti da modqccli
8445
8446
8447!>\example esempio_v7ddballe_move_and_collapse.f90
8448!!\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.