libsim Versione 7.2.6

◆ vol7d_get_volanaattri()

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

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

Definizione alla linea 4944 del file vol7d_class.F90.

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