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