libsim Versione 7.2.6

◆ vol7d_get_volanai()

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

Crea una vista a dimensione ridotta di un volume di anagrafica 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 :: vol1d(:)
...
CALL vol7d_get_volanai(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d

Definizione alla linea 4892 del file vol7d_class.F90.

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