libsim Versione 7.2.6
|
◆ vol7d_get_volanab()
Crea una vista a dimensione ridotta di un volume di anagrafica di tipo INTEGER(kind=int_b). È 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(kind=int_b), POINTER :: vol1d(:)
...
CALL vol7d_get_volanab(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 5568 del file vol7d_class.F90. 5570! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
5571! authors:
5572! Davide Cesari <dcesari@arpa.emr.it>
5573! Paolo Patruno <ppatruno@arpa.emr.it>
5574
5575! This program is free software; you can redistribute it and/or
5576! modify it under the terms of the GNU General Public License as
5577! published by the Free Software Foundation; either version 2 of
5578! the License, or (at your option) any later version.
5579
5580! This program is distributed in the hope that it will be useful,
5581! but WITHOUT ANY WARRANTY; without even the implied warranty of
5582! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5583! GNU General Public License for more details.
5584
5585! You should have received a copy of the GNU General Public License
5586! along with this program. If not, see <http://www.gnu.org/licenses/>.
5587#include "config.h"
5588
5589!> \defgroup vol7d Libsim package, vol7d library.
5590!! The libsim vol7d library contains classes for managing pointwise
5591!! data, tipically weather observations, and for their import from a
5592!! Db-All.e database or from a WMO BUFR file. In order to compile and
5593!! link programs using this library, you have to insert the required
5594!! \c USE statements in the program units involved, specify the
5595!! location of module files when compiling (tipically \c
5596!! -I/usr/lib/gfortran/modules or \c -I/usr/lib64/gfortran/modules or
5597!! \c -I/usr/include) and indicate the library name \c -lsim_vol7d
5598!! when linking, assuming that the library has been installed in a
5599!! default location.
5600
5601!> Classe per la gestione di un volume completo di dati osservati.
5602!! Questo modulo definisce gli oggetti e i metodi per gestire
5603!! volumi di dati meteorologici sparsi.
5604!! I volumi definiti sono principalmente di 4 categorie:
5605!! - volumi di anagrafica (vol7d::volanar & c.), hanno 3 dimensioni:
5606!! - anagrafica
5607!! - variabile di anagrafica
5608!! - rete
5609!! - volumi di attributi di anagrafica (vol7d::volanaattrr & c.), hanno 4 dimensioni:
5610!! - anagrafica
5611!! - variabile di anagrafica
5612!! - rete
5613!! - variabile di attributi delle variabili di anagrafica
5614!! - volumi di dati (vol7d::voldatir & c.), hanno 6 dimensioni:
5615!! - anagrafica
5616!! - tempo
5617!! - livello verticale
5618!! - intervallo temporale (timerange)
5619!! - variabile di dati
5620!! - rete
5621!! - volumi di attributi di dati (vol7d::voldatiattrr & c.), hanno 7 dimensioni:
5622!! - anagrafica
5623!! - tempo
5624!! - livello verticale
5625!! - intervallo temporale (timerange)
5626!! - variabile di dati
5627!! - rete
5628!! - variabile di attributi delle variabili di dati
5629!!
5630!! Tutte le variabili sono inoltre disponibil1 in 5 tipi diversi:
5631!! - reale (abbreviato r)
5632!! - doppia precisione (abbreviato d)
5633!! - intero (abbreviato i)
5634!! - byte (abbreviato b)
5635!! - carattere (abbreviato c)
5636!!
5637!! Per ognuna delle dimensioni possibili, incluse le variabili e gli
5638!! attributi con i loro diversi tipi,
5639!! è definito un cosiddetto "vettore di descrittori", con un
5640!! numero di elementi pari all'estensione della dimensione stessa,
5641!! che contiene le informazioni necessarie a descrivere
5642!! gli elementi di quella dimensione.
5643!! In realtà l'utente non dovrà generalmente occuparsi di costruire
5644!! un oggetto vol7d con le proprie mani ma utilizzerà nella maggior parte
5645!! dei casi i metodi di importazione preconfezionati che importano dati da
5646!! DB-All.e (vol7d_dballe_class) o dal DB Oracle del SIM (vol7d_oraclesim_class).
5647!!
5648!!
5649!! Il programma esempio_v7d.f90 contiene un esempio elementare di uso
5650!! della classe vol7d:
5651!! \include esempio_v7d.f90
5652!!
5653!! \ingroup vol7d
5661USE io_units
5668IMPLICIT NONE
5669
5670
5671INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
5672 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
5673
5674INTEGER, PARAMETER :: vol7d_ana_a=1 !< indice della dimensione "anagrafica" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5675INTEGER, PARAMETER :: vol7d_var_a=2 !< indice della dimensione "variabile" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5676INTEGER, PARAMETER :: vol7d_network_a=3 !< indice della dimensione "rete" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5677INTEGER, PARAMETER :: vol7d_attr_a=4 !< indice della dimensione "attributo" nei volumi di anagrafica, da usare nei metodi vol7d_get_volana*
5678INTEGER, PARAMETER :: vol7d_ana_d=1 !< indice della dimensione "anagrafica" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5679INTEGER, PARAMETER :: vol7d_time_d=2 !< indice della dimensione "tempo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5680INTEGER, PARAMETER :: vol7d_level_d=3 !< indice della dimensione "livello verticale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5681INTEGER, PARAMETER :: vol7d_timerange_d=4 !< indice della dimensione "intervallo temporale" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5682INTEGER, PARAMETER :: vol7d_var_d=5 !< indice della dimensione "variabile" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5683INTEGER, PARAMETER :: vol7d_network_d=6 !< indice della dimensione "rete" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5684INTEGER, PARAMETER :: vol7d_attr_d=7 !< indice della dimensione "attributo" nei volumi di dati, da usare nei metodi vol7d_get_voldati*
5685INTEGER, PARAMETER :: vol7d_cdatalen=32
5686
5687TYPE vol7d_varmap
5688 INTEGER :: r, d, i, b, c
5689END TYPE vol7d_varmap
5690
5691!> Definisce un oggetto contenente i volumi anagrafica e dati e tutti
5692!! i descrittori delle loro dimensioni.
5694!> vettore descrittore della dimensione anagrafica
5695 TYPE(vol7d_ana),POINTER :: ana(:)
5696!> vettore descrittore della dimensione tempo
5697 TYPE(datetime),POINTER :: time(:)
5698!> vettore descrittore della dimensione livello verticale
5699 TYPE(vol7d_level),POINTER :: level(:)
5700!> vettore descrittore della dimensione intervallo temporale (timerange)
5701 TYPE(vol7d_timerange),POINTER :: timerange(:)
5702!> vettore descrittore della dimensione rete
5703 TYPE(vol7d_network),POINTER :: network(:)
5704!> vettore descrittore della dimensione variabile di anagrafica
5705 TYPE(vol7d_varvect) :: anavar
5706!> vettore descrittore della dimensione attributo delle variabili di anagrafica
5707 TYPE(vol7d_varvect) :: anaattr
5708!> vettore descrittore della dimensione variabile di anagrafica che ha tali attributi
5709 TYPE(vol7d_varvect) :: anavarattr
5710!> vettore descrittore della dimensione variabile di dati
5711 TYPE(vol7d_varvect) :: dativar
5712!> vettore descrittore della dimensione attributo delle variabili di dati
5713 TYPE(vol7d_varvect) :: datiattr
5714!> vettore descrittore della dimensione variabile di dati che ha tali attributi
5715 TYPE(vol7d_varvect) :: dativarattr
5716
5717!> volume di anagrafica a valori reali
5718 REAL,POINTER :: volanar(:,:,:)
5719!> volume di anagrafica a valori a doppia precisione
5720 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5721!> volume di anagrafica a valori interi
5722 INTEGER,POINTER :: volanai(:,:,:)
5723!> volume di anagrafica a valori byte
5724 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5725!> volume di anagrafica a valori carattere
5726 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5727
5728!> volume di attributi di anagrafica a valori reali
5729 REAL,POINTER :: volanaattrr(:,:,:,:)
5730!> volume di attributi di anagrafica a valori a doppia precisione
5731 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5732!> volume di attributi di anagrafica a valori interi
5733 INTEGER,POINTER :: volanaattri(:,:,:,:)
5734!> volume di attributi di anagrafica a valori byte
5735 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5736!> volume di attributi di anagrafica a valori carattere
5737 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5738
5739!> volume di dati a valori reali
5740 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5741!> volume di dati a valori a doppia precisione
5742 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5743!> volume di dati a valori interi
5744 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5745!> volume di dati a valori byte
5746 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5747!> volume di dati a valori carattere
5748 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5749
5750!> volume di attributi di dati a valori reali
5751 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5752!> volume di attributi di dati a valori a doppia precisione
5753 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5754!> volume di attributi di dati a valori interi
5755 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5756!> volume di attributi di dati a valori byte
5757 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5758!> volume di attributi di dati a valori carattere
5759 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5760
5761!> time definition; 0=time is reference time, 1=time is validity time
5762 integer :: time_definition
5763
5765
5766!> Costruttore per la classe vol7d.
5767!! Deve essere richiamato
5768!! per tutti gli oggetti di questo tipo definiti in un programma.
5770 MODULE PROCEDURE vol7d_init
5771END INTERFACE
5772
5773!> Distruttore per la classe vol7d.
5775 MODULE PROCEDURE vol7d_delete
5776END INTERFACE
5777
5778!> Scrittura su file.
5780 MODULE PROCEDURE vol7d_write_on_file
5781END INTERFACE
5782
5783!> Lettura da file.
5784INTERFACE import
5785 MODULE PROCEDURE vol7d_read_from_file
5786END INTERFACE
5787
5788!>Print object
5790 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5791END INTERFACE
5792
5793!>Represent data in a pretty string
5795 MODULE PROCEDURE to_char_dat
5796END INTERFACE
5797
5798!>doubleprecision data conversion
5800 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5801END INTERFACE
5802
5803!>real data conversion
5805 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5806END INTERFACE
5807
5808!>integer data conversion
5810 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5811END INTERFACE
5812
5813!>copy object
5815 MODULE PROCEDURE vol7d_copy
5816END INTERFACE
5817
5818!> Test for a missing volume
5820 MODULE PROCEDURE vol7d_c_e
5821END INTERFACE
5822
5823!> Check for problems
5824!! return 0 if all check passed
5825!! print diagnostics with log4f
5827 MODULE PROCEDURE vol7d_check
5828END INTERFACE
5829
5830!> Reduce some dimensions (level and timerage) for semplification (rounding).
5831!! You can use this for simplify and use variables in computation like alchimia
5832!! where fields have to be on the same coordinate
5833!! It return real or character data only: if input is charcter data only it return character otherwise il return
5834!! all the data converted to real.
5835!! examples:
5836!! means in time for short periods and istantaneous values
5837!! 2 meter and surface levels
5838!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
5839!! will be taken (order is by icreasing var index).
5840!! You can use predefined values for classic semplification
5841!! almost_equal_levels and almost_equal_timeranges
5842!! The level or timerange in output will be defined by the first element of level and timerange list
5844 MODULE PROCEDURE v7d_rounding
5845END INTERFACE
5846
5847!!$INTERFACE get_volana
5848!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
5849!!$ vol7d_get_volanab, vol7d_get_volanac
5850!!$END INTERFACE
5851!!$
5852!!$INTERFACE get_voldati
5853!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
5854!!$ vol7d_get_voldatib, vol7d_get_voldatic
5855!!$END INTERFACE
5856!!$
5857!!$INTERFACE get_volanaattr
5858!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
5859!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
5860!!$END INTERFACE
5861!!$
5862!!$INTERFACE get_voldatiattr
5863!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
5864!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
5865!!$END INTERFACE
5866
5867PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
5868 vol7d_get_volc, &
5869 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
5870 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
5871 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
5872 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
5873 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
5874 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
5875 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
5876 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
5877 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
5878 vol7d_display, dat_display, dat_vect_display, &
5879 to_char_dat, vol7d_check
5880
5881PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5882
5883PRIVATE vol7d_c_e
5884
5885CONTAINS
5886
5887
5888!> Inizializza un oggetto di tipo vol7d.
5889!! Non riceve alcun parametro tranne l'oggetto stesso. Attenzione, è necessario
5890!! comunque chiamare sempre il costruttore per evitare di avere dei puntatori in
5891!! uno stato indefinito.
5892SUBROUTINE vol7d_init(this,time_definition)
5893TYPE(vol7d),intent(out) :: this !< oggetto da inizializzare
5894integer,INTENT(IN),OPTIONAL :: time_definition !< 0=time is reference time ; 1=time is validity time (default=1)
5895
5902CALL vol7d_var_features_init() ! initialise var features table once
5903
5904NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
5905
5906NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
5907NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
5908NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
5909NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
5910NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
5911
5912if(present(time_definition)) then
5913 this%time_definition=time_definition
5914else
5915 this%time_definition=1 !default to validity time
5916end if
5917
5918END SUBROUTINE vol7d_init
5919
5920
5921!> Distrugge l'oggetto in maniera pulita, liberando l'eventuale memoria
5922!! dinamicamente allocata. Permette di distruggere la sola parte di dati
5923!! mantenendo l'anagrafica.
5924ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
5925TYPE(vol7d),intent(inout) :: this !< oggetto da distruggere
5926LOGICAL, INTENT(in), OPTIONAL :: dataonly !< dealloca solo i dati, tenendo l'anagrafica, (default \c .FALSE.)
5927
5928
5929IF (.NOT. optio_log(dataonly)) THEN
5930 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
5931 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
5932 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
5933 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
5934 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
5935 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
5936 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
5937 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
5938 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
5939 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
5940ENDIF
5941IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
5942IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
5943IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
5944IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
5945IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
5946IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
5947IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
5948IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
5949IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
5950IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
5951
5952IF (.NOT. optio_log(dataonly)) THEN
5953 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5954 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5955ENDIF
5956IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5957IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5958IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5959
5960IF (.NOT. optio_log(dataonly)) THEN
5964ENDIF
5968
5969END SUBROUTINE vol7d_delete
5970
5971
5972
5973integer function vol7d_check(this)
5974TYPE(vol7d),intent(in) :: this !< object to check
5975integer :: i,j,k,l,m,n
5976
5977vol7d_check=0
5978
5979if (associated(this%voldatii)) then
5980do i = 1,size(this%voldatii,1)
5981 do j = 1,size(this%voldatii,2)
5982 do k = 1,size(this%voldatii,3)
5983 do l = 1,size(this%voldatii,4)
5984 do m = 1,size(this%voldatii,5)
5985 do n = 1,size(this%voldatii,6)
5986 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
5987 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
5989 vol7d_check=1
5990 end if
5991 end do
5992 end do
5993 end do
5994 end do
5995 end do
5996end do
5997end if
5998
5999
6000if (associated(this%voldatir)) then
6001do i = 1,size(this%voldatir,1)
6002 do j = 1,size(this%voldatir,2)
6003 do k = 1,size(this%voldatir,3)
6004 do l = 1,size(this%voldatir,4)
6005 do m = 1,size(this%voldatir,5)
6006 do n = 1,size(this%voldatir,6)
6007 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
6008 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
6010 vol7d_check=2
6011 end if
6012 end do
6013 end do
6014 end do
6015 end do
6016 end do
6017end do
6018end if
6019
6020if (associated(this%voldatid)) then
6021do i = 1,size(this%voldatid,1)
6022 do j = 1,size(this%voldatid,2)
6023 do k = 1,size(this%voldatid,3)
6024 do l = 1,size(this%voldatid,4)
6025 do m = 1,size(this%voldatid,5)
6026 do n = 1,size(this%voldatid,6)
6027 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
6028 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
6030 vol7d_check=3
6031 end if
6032 end do
6033 end do
6034 end do
6035 end do
6036 end do
6037end do
6038end if
6039
6040if (associated(this%voldatib)) then
6041do i = 1,size(this%voldatib,1)
6042 do j = 1,size(this%voldatib,2)
6043 do k = 1,size(this%voldatib,3)
6044 do l = 1,size(this%voldatib,4)
6045 do m = 1,size(this%voldatib,5)
6046 do n = 1,size(this%voldatib,6)
6047 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
6048 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
6050 vol7d_check=4
6051 end if
6052 end do
6053 end do
6054 end do
6055 end do
6056 end do
6057end do
6058end if
6059
6060end function vol7d_check
6061
6062
6063
6064!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
6065!> stampa a video una sintesi del contenuto
6066SUBROUTINE vol7d_display(this)
6067TYPE(vol7d),intent(in) :: this !< oggetto da visualizzare
6068integer :: i
6069
6070REAL :: rdat
6071DOUBLE PRECISION :: ddat
6072INTEGER :: idat
6073INTEGER(kind=int_b) :: bdat
6074CHARACTER(len=vol7d_cdatalen) :: cdat
6075
6076
6077print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
6078if (this%time_definition == 0) then
6079 print*,"TIME DEFINITION: time is reference time"
6080else if (this%time_definition == 1) then
6081 print*,"TIME DEFINITION: time is validity time"
6082else
6083 print*,"Time definition have a wrong walue:", this%time_definition
6084end if
6085
6086IF (ASSOCIATED(this%network))then
6087 print*,"---- network vector ----"
6088 print*,"elements=",size(this%network)
6089 do i=1, size(this%network)
6091 end do
6092end IF
6093
6094IF (ASSOCIATED(this%ana))then
6095 print*,"---- ana vector ----"
6096 print*,"elements=",size(this%ana)
6097 do i=1, size(this%ana)
6099 end do
6100end IF
6101
6102IF (ASSOCIATED(this%time))then
6103 print*,"---- time vector ----"
6104 print*,"elements=",size(this%time)
6105 do i=1, size(this%time)
6107 end do
6108end if
6109
6110IF (ASSOCIATED(this%level)) then
6111 print*,"---- level vector ----"
6112 print*,"elements=",size(this%level)
6113 do i =1,size(this%level)
6115 end do
6116end if
6117
6118IF (ASSOCIATED(this%timerange))then
6119 print*,"---- timerange vector ----"
6120 print*,"elements=",size(this%timerange)
6121 do i =1,size(this%timerange)
6123 end do
6124end if
6125
6126
6127print*,"---- ana vector ----"
6128print*,""
6129print*,"->>>>>>>>> anavar -"
6131print*,""
6132print*,"->>>>>>>>> anaattr -"
6134print*,""
6135print*,"->>>>>>>>> anavarattr -"
6137
6138print*,"-- ana data section (first point) --"
6139
6140idat=imiss
6141rdat=rmiss
6142ddat=dmiss
6143bdat=ibmiss
6144cdat=cmiss
6145
6146!ntime = MIN(SIZE(this%time),nprint)
6147!ntimerange = MIN(SIZE(this%timerange),nprint)
6148!nlevel = MIN(SIZE(this%level),nprint)
6149!nnetwork = MIN(SIZE(this%network),nprint)
6150!nana = MIN(SIZE(this%ana),nprint)
6151
6152IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
6153if (associated(this%volanai)) then
6154 do i=1,size(this%anavar%i)
6155 idat=this%volanai(1,i,1)
6157 end do
6158end if
6159idat=imiss
6160
6161if (associated(this%volanar)) then
6162 do i=1,size(this%anavar%r)
6163 rdat=this%volanar(1,i,1)
6165 end do
6166end if
6167rdat=rmiss
6168
6169if (associated(this%volanad)) then
6170 do i=1,size(this%anavar%d)
6171 ddat=this%volanad(1,i,1)
6173 end do
6174end if
6175ddat=dmiss
6176
6177if (associated(this%volanab)) then
6178 do i=1,size(this%anavar%b)
6179 bdat=this%volanab(1,i,1)
6181 end do
6182end if
6183bdat=ibmiss
6184
6185if (associated(this%volanac)) then
6186 do i=1,size(this%anavar%c)
6187 cdat=this%volanac(1,i,1)
6189 end do
6190end if
6191cdat=cmiss
6192ENDIF
6193
6194print*,"---- data vector ----"
6195print*,""
6196print*,"->>>>>>>>> dativar -"
6198print*,""
6199print*,"->>>>>>>>> datiattr -"
6201print*,""
6202print*,"->>>>>>>>> dativarattr -"
6204
6205print*,"-- data data section (first point) --"
6206
6207idat=imiss
6208rdat=rmiss
6209ddat=dmiss
6210bdat=ibmiss
6211cdat=cmiss
6212
6213IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
6214 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
6215if (associated(this%voldatii)) then
6216 do i=1,size(this%dativar%i)
6217 idat=this%voldatii(1,1,1,1,i,1)
6219 end do
6220end if
6221idat=imiss
6222
6223if (associated(this%voldatir)) then
6224 do i=1,size(this%dativar%r)
6225 rdat=this%voldatir(1,1,1,1,i,1)
6227 end do
6228end if
6229rdat=rmiss
6230
6231if (associated(this%voldatid)) then
6232 do i=1,size(this%dativar%d)
6233 ddat=this%voldatid(1,1,1,1,i,1)
6235 end do
6236end if
6237ddat=dmiss
6238
6239if (associated(this%voldatib)) then
6240 do i=1,size(this%dativar%b)
6241 bdat=this%voldatib(1,1,1,1,i,1)
6243 end do
6244end if
6245bdat=ibmiss
6246
6247if (associated(this%voldatic)) then
6248 do i=1,size(this%dativar%c)
6249 cdat=this%voldatic(1,1,1,1,i,1)
6251 end do
6252end if
6253cdat=cmiss
6254ENDIF
6255
6256print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
6257
6258END SUBROUTINE vol7d_display
6259
6260
6261!> stampa a video una sintesi del contenuto
6262SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
6263TYPE(vol7d_var),intent(in) :: this !< oggetto da visualizzare
6264!> real
6265REAL :: rdat
6266!> double precision
6267DOUBLE PRECISION :: ddat
6268!> integer
6269INTEGER :: idat
6270!> byte
6271INTEGER(kind=int_b) :: bdat
6272!> character
6273CHARACTER(len=*) :: cdat
6274
6275print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6276
6277end SUBROUTINE dat_display
6278
6279!> stampa a video una sintesi del contenuto
6280SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
6281
6282TYPE(vol7d_var),intent(in) :: this(:) !< oggetto da visualizzare
6283!> real
6284REAL :: rdat(:)
6285!> double precision
6286DOUBLE PRECISION :: ddat(:)
6287!> integer
6288INTEGER :: idat(:)
6289!> byte
6290INTEGER(kind=int_b) :: bdat(:)
6291!> character
6292CHARACTER(len=*):: cdat(:)
6293
6294integer :: i
6295
6296do i =1,size(this)
6298end do
6299
6300end SUBROUTINE dat_vect_display
6301
6302
6303FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6304#ifdef HAVE_DBALLE
6305USE dballef
6306#endif
6307TYPE(vol7d_var),INTENT(in) :: this
6308!> real
6309REAL :: rdat
6310!> double precision
6311DOUBLE PRECISION :: ddat
6312!> integer
6313INTEGER :: idat
6314!> byte
6315INTEGER(kind=int_b) :: bdat
6316!> character
6317CHARACTER(len=*) :: cdat
6318CHARACTER(len=80) :: to_char_dat
6319
6320CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
6321
6322
6323#ifdef HAVE_DBALLE
6324INTEGER :: handle, ier
6325
6326handle = 0
6327to_char_dat="VALUE: "
6328
6333
6335 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
6336 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
6337 ier = idba_fatto(handle)
6338 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
6339endif
6340
6341#else
6342
6343to_char_dat="VALUE: "
6349
6350#endif
6351
6352END FUNCTION to_char_dat
6353
6354
6355!> Tests whether anything has ever been assigned to a vol7d object
6356!! (.TRUE.) or it is as clean as after an init (.FALSE.).
6357FUNCTION vol7d_c_e(this) RESULT(c_e)
6358TYPE(vol7d), INTENT(in) :: this
6359
6360LOGICAL :: c_e
6361
6363 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
6364 ASSOCIATED(this%network) .OR. &
6365 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6366 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6367 ASSOCIATED(this%anavar%c) .OR. &
6368 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
6369 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
6370 ASSOCIATED(this%anaattr%c) .OR. &
6371 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6372 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6373 ASSOCIATED(this%dativar%c) .OR. &
6374 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
6375 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
6376 ASSOCIATED(this%datiattr%c)
6377
6378END FUNCTION vol7d_c_e
6379
6380
6381!> Metodo per allocare i descrittori delle 7 dimensioni.
6382!! Riceve un grande numero di parametri opzionali che
6383!! indicano quali descrittori allocare e con quale estensione;
6384!! i descrittori non specificati non vengono toccati.
6385!! Può essere quindi chiamato più volte allocando via via
6386!! descrittori relativi a dimensioni diverse.
6387!! Se un descrittore richiesto è già allocato, viene deallocato
6388!! (perdendone l'eventuale contenuto) e riallocato con l'estensione
6389!! richiesta.
6390!! Per i descrittori relativi a dimensioni che non siano variabili o attributi,
6391!! è possibile specificare l'estensione di una dimensione a 0,
6392!! in tal caso il descrittore viene comunque allocato con lunghezza nulla,
6393!! che è diverso da non allocarlo. Per i descrittori di variabili e attributi
6394!! passare un'estensione 0 equivale a non fornire il parametro.
6395!! Avere uno o più descrittori dimensionati con estensione nulla fa sì
6396!! che anche il volume dati successivamente allocato abbia estensione nulla;
6397!! sebbene ciò appaia inutile, un volume del genere può in realtà servire,
6398!! in associazione ai metodi ::vol7d_merge o ::vol7d_append per estendere
6399!! un volume esistente aggiungendo elementi in alcune dimensioni (quelle
6400!! a estensione non nulla, ovviamente) e mantenendo invariato tutto il resto.
6401!! Per quanto riguarda i descrittori delle dimensioni relative alle
6402!! variabili, la relativa estensione è specificata con la nomenclatura
6403!! \a n<x><y><z> dove <x> può valere:
6404!! - \a ana per variabili relative a voumi di anagrafica
6405!! - \a dati per variabili relative a voumi di dati
6406!!
6407!! <y> può valere:
6408!! - \a var per variabili
6409!! - \a attr per attributi
6410!! - \a varattr variabili aventi attributi nei volumi di attributi
6411!!
6412!! <z> può valere:
6413!! - \a r per variabili o attributi a valori reali
6414!! - \a d per variabili o attributi a valori a doppia precisione
6415!! - \a i per variabili o attributi a valori interi
6416!! - \a b per variabili o attributi a valori byte
6417!! - \a c per variabili o attributi a valori carattere
6418!!
6419SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
6420 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6421 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6422 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6423 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6424 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6425 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
6426 ini)
6427TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i descrittori
6428INTEGER,INTENT(in),OPTIONAL :: nana !< estensione della dimensione anagrafica
6429INTEGER,INTENT(in),OPTIONAL :: ntime !< estensione della dimensione tempo
6430INTEGER,INTENT(in),OPTIONAL :: nlevel !< estensione della dimensione livello varticale
6431INTEGER,INTENT(in),OPTIONAL :: ntimerange !< estensione della dimensione intervallo temporale (timerange)
6432INTEGER,INTENT(in),OPTIONAL :: nnetwork !< estensione della dimensione rete
6433!> estensione delle possibili dimensioni variabile
6434INTEGER,INTENT(in),OPTIONAL :: &
6435 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6436 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6437 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6438 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6439 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6440 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
6441LOGICAL,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
6442
6443INTEGER :: i
6444LOGICAL :: linit
6445
6446IF (PRESENT(ini)) THEN
6447 linit = ini
6448ELSE
6449 linit = .false.
6450ENDIF
6451
6452! Dimensioni principali
6453IF (PRESENT(nana)) THEN
6454 IF (nana >= 0) THEN
6455 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6456 ALLOCATE(this%ana(nana))
6457 IF (linit) THEN
6458 DO i = 1, nana
6460 ENDDO
6461 ENDIF
6462 ENDIF
6463ENDIF
6464IF (PRESENT(ntime)) THEN
6465 IF (ntime >= 0) THEN
6466 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6467 ALLOCATE(this%time(ntime))
6468 IF (linit) THEN
6469 DO i = 1, ntime
6471 ENDDO
6472 ENDIF
6473 ENDIF
6474ENDIF
6475IF (PRESENT(nlevel)) THEN
6476 IF (nlevel >= 0) THEN
6477 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6478 ALLOCATE(this%level(nlevel))
6479 IF (linit) THEN
6480 DO i = 1, nlevel
6482 ENDDO
6483 ENDIF
6484 ENDIF
6485ENDIF
6486IF (PRESENT(ntimerange)) THEN
6487 IF (ntimerange >= 0) THEN
6488 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6489 ALLOCATE(this%timerange(ntimerange))
6490 IF (linit) THEN
6491 DO i = 1, ntimerange
6493 ENDDO
6494 ENDIF
6495 ENDIF
6496ENDIF
6497IF (PRESENT(nnetwork)) THEN
6498 IF (nnetwork >= 0) THEN
6499 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6500 ALLOCATE(this%network(nnetwork))
6501 IF (linit) THEN
6502 DO i = 1, nnetwork
6504 ENDDO
6505 ENDIF
6506 ENDIF
6507ENDIF
6508! Dimensioni dei tipi delle variabili
6509CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
6510 nanavari, nanavarb, nanavarc, ini)
6511CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
6512 nanaattri, nanaattrb, nanaattrc, ini)
6513CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
6514 nanavarattri, nanavarattrb, nanavarattrc, ini)
6515CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
6516 ndativari, ndativarb, ndativarc, ini)
6517CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
6518 ndatiattri, ndatiattrb, ndatiattrc, ini)
6519CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
6520 ndativarattri, ndativarattrb, ndativarattrc, ini)
6521
6522END SUBROUTINE vol7d_alloc
6523
6524
6525FUNCTION vol7d_check_alloc_ana(this)
6526TYPE(vol7d),INTENT(in) :: this
6527LOGICAL :: vol7d_check_alloc_ana
6528
6529vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
6530
6531END FUNCTION vol7d_check_alloc_ana
6532
6533SUBROUTINE vol7d_force_alloc_ana(this, ini)
6534TYPE(vol7d),INTENT(inout) :: this
6535LOGICAL,INTENT(in),OPTIONAL :: ini
6536
6537! Alloco i descrittori minimi per avere un volume di anagrafica
6538IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
6539IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
6540
6541END SUBROUTINE vol7d_force_alloc_ana
6542
6543
6544FUNCTION vol7d_check_alloc_dati(this)
6545TYPE(vol7d),INTENT(in) :: this
6546LOGICAL :: vol7d_check_alloc_dati
6547
6548vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
6549 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
6550 ASSOCIATED(this%timerange)
6551
6552END FUNCTION vol7d_check_alloc_dati
6553
6554SUBROUTINE vol7d_force_alloc_dati(this, ini)
6555TYPE(vol7d),INTENT(inout) :: this
6556LOGICAL,INTENT(in),OPTIONAL :: ini
6557
6558! Alloco i descrittori minimi per avere un volume di dati
6559CALL vol7d_force_alloc_ana(this, ini)
6560IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
6561IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
6562IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
6563
6564END SUBROUTINE vol7d_force_alloc_dati
6565
6566
6567SUBROUTINE vol7d_force_alloc(this)
6568TYPE(vol7d),INTENT(inout) :: this
6569
6570! If anything really not allocated yet, allocate with size 0
6571IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
6572IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
6573IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
6574IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
6575IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
6576
6577END SUBROUTINE vol7d_force_alloc
6578
6579
6580FUNCTION vol7d_check_vol(this)
6581TYPE(vol7d),INTENT(in) :: this !< oggetto da controllare
6582LOGICAL :: vol7d_check_vol
6583
6584vol7d_check_vol = c_e(this)
6585
6586! Anagrafica
6587IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6588 vol7d_check_vol = .false.
6589ENDIF
6590
6591IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6592 vol7d_check_vol = .false.
6593ENDIF
6594
6595IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6596 vol7d_check_vol = .false.
6597ENDIF
6598
6599IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6600 vol7d_check_vol = .false.
6601ENDIF
6602
6603IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6604 vol7d_check_vol = .false.
6605ENDIF
6606IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6607 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6608 ASSOCIATED(this%anavar%c)) THEN
6609 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
6610ENDIF
6611
6612! Attributi dell'anagrafica
6613IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6614 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6615 vol7d_check_vol = .false.
6616ENDIF
6617
6618IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6619 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6620 vol7d_check_vol = .false.
6621ENDIF
6622
6623IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6624 .NOT.ASSOCIATED(this%volanaattri)) THEN
6625 vol7d_check_vol = .false.
6626ENDIF
6627
6628IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6629 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6630 vol7d_check_vol = .false.
6631ENDIF
6632
6633IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6634 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6635 vol7d_check_vol = .false.
6636ENDIF
6637
6638! Dati
6639IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6640 vol7d_check_vol = .false.
6641ENDIF
6642
6643IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6644 vol7d_check_vol = .false.
6645ENDIF
6646
6647IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6648 vol7d_check_vol = .false.
6649ENDIF
6650
6651IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6652 vol7d_check_vol = .false.
6653ENDIF
6654
6655IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6656 vol7d_check_vol = .false.
6657ENDIF
6658
6659! Attributi dei dati
6660IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6661 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6662 vol7d_check_vol = .false.
6663ENDIF
6664
6665IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6666 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6667 vol7d_check_vol = .false.
6668ENDIF
6669
6670IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6671 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6672 vol7d_check_vol = .false.
6673ENDIF
6674
6675IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6676 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6677 vol7d_check_vol = .false.
6678ENDIF
6679
6680IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6681 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6682 vol7d_check_vol = .false.
6683ENDIF
6684IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6685 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6686 ASSOCIATED(this%dativar%c)) THEN
6687 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6688ENDIF
6689
6690END FUNCTION vol7d_check_vol
6691
6692
6693!> Metodo per allocare i volumi richiesti di variabili e attributi per
6694!! anagrafica e dati.
6695!! Se alcuni dei descrittori relativi alle dimensioni anagrafica,
6696!! livello verticale, tempo, intervallo temporale (timerange), rete non sono
6697!! stati richiesti preventivamente con la ::vol7d_alloc, essi vengono allocati
6698!! automaticamente da questo metodo
6699!! con estensione di default pari a 1 (non 0!), questo significa, ad esempio,
6700!! che se prevedo di avere soli dati superficiali, cioè ad un solo livello
6701!! verticale, o una sola rete di stazioni, non devo preoccuparmi di
6702!! specificare questa informazione.
6703!! Tra i 20 possibili volumi allocabili
6704!! ((variabili,attributi)*(anagrafica,dati)*(r,d,i,b,c)=20)
6705!! saranno allocati solo quelli per cui è stato precedentemente richiesto il
6706!! corrispondente descrittore variabili/attributi con la ::vol7d_alloc.
6707SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6708TYPE(vol7d),INTENT(inout) :: this !< oggetto di cui allocare i volumi
6709LOGICAL,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
6710LOGICAL,INTENT(in),OPTIONAL :: inivol !< se fornito e vale \c .TRUE., i volumi allocati saranno inizializzati a valore mancante
6711
6712LOGICAL :: linivol
6713
6714IF (PRESENT(inivol)) THEN
6715 linivol = inivol
6716ELSE
6717 linivol = .true.
6718ENDIF
6719
6720! Anagrafica
6721IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6722 CALL vol7d_force_alloc_ana(this, ini)
6723 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6724 IF (linivol) this%volanar(:,:,:) = rmiss
6725ENDIF
6726
6727IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6728 CALL vol7d_force_alloc_ana(this, ini)
6729 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6730 IF (linivol) this%volanad(:,:,:) = rdmiss
6731ENDIF
6732
6733IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6734 CALL vol7d_force_alloc_ana(this, ini)
6735 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6736 IF (linivol) this%volanai(:,:,:) = imiss
6737ENDIF
6738
6739IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6740 CALL vol7d_force_alloc_ana(this, ini)
6741 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6742 IF (linivol) this%volanab(:,:,:) = ibmiss
6743ENDIF
6744
6745IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6746 CALL vol7d_force_alloc_ana(this, ini)
6747 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6748 IF (linivol) this%volanac(:,:,:) = cmiss
6749ENDIF
6750
6751! Attributi dell'anagrafica
6752IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6753 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6754 CALL vol7d_force_alloc_ana(this, ini)
6755 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6756 SIZE(this%network), SIZE(this%anaattr%r)))
6757 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6758ENDIF
6759
6760IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6761 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6762 CALL vol7d_force_alloc_ana(this, ini)
6763 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6764 SIZE(this%network), SIZE(this%anaattr%d)))
6765 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6766ENDIF
6767
6768IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6769 .NOT.ASSOCIATED(this%volanaattri)) THEN
6770 CALL vol7d_force_alloc_ana(this, ini)
6771 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6772 SIZE(this%network), SIZE(this%anaattr%i)))
6773 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6774ENDIF
6775
6776IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6777 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6778 CALL vol7d_force_alloc_ana(this, ini)
6779 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6780 SIZE(this%network), SIZE(this%anaattr%b)))
6781 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6782ENDIF
6783
6784IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6785 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6786 CALL vol7d_force_alloc_ana(this, ini)
6787 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6788 SIZE(this%network), SIZE(this%anaattr%c)))
6789 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6790ENDIF
6791
6792! Dati
6793IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6794 CALL vol7d_force_alloc_dati(this, ini)
6795 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6796 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6797 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6798ENDIF
6799
6800IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6801 CALL vol7d_force_alloc_dati(this, ini)
6802 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6803 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6804 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6805ENDIF
6806
6807IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6808 CALL vol7d_force_alloc_dati(this, ini)
6809 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6810 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6811 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6812ENDIF
6813
6814IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6815 CALL vol7d_force_alloc_dati(this, ini)
6816 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6817 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6818 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6819ENDIF
6820
6821IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6822 CALL vol7d_force_alloc_dati(this, ini)
6823 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6824 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6825 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6826ENDIF
6827
6828! Attributi dei dati
6829IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6830 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6831 CALL vol7d_force_alloc_dati(this, ini)
6832 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6833 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
6834 SIZE(this%datiattr%r)))
6835 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
6836ENDIF
6837
6838IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6839 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6840 CALL vol7d_force_alloc_dati(this, ini)
6841 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6842 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
6843 SIZE(this%datiattr%d)))
6844 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
6845ENDIF
6846
6847IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6848 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6849 CALL vol7d_force_alloc_dati(this, ini)
6850 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6851 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
6852 SIZE(this%datiattr%i)))
6853 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
6854ENDIF
6855
6856IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6857 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6858 CALL vol7d_force_alloc_dati(this, ini)
6859 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6860 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
6861 SIZE(this%datiattr%b)))
6862 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
6863ENDIF
6864
6865IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6866 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6867 CALL vol7d_force_alloc_dati(this, ini)
6868 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6869 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
6870 SIZE(this%datiattr%c)))
6871 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
6872ENDIF
6873
6874! Catch-all method
6875CALL vol7d_force_alloc(this)
6876
6877! Creo gli indici var-attr
6878
6879#ifdef DEBUG
6880CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
6881#endif
6882
6883CALL vol7d_set_attr_ind(this)
6884
6885
6886
6887END SUBROUTINE vol7d_alloc_vol
6888
6889
6890!> Metodo per creare gli indici che associano le variabili aventi attributo
6891!! alle variabili nei relativi descrittori.
6892!! Ha senso chiamare questo metodo solo dopo che i descrittori delle variabili
6893!! e degli attributi desiderati sono stati allocati ed è stato assegnato un
6894!! valore ai relativi membri btable (vedi vol7d_var_class::vol7d_var), se
6895!! i descrittori non sono stati allocati o assegnati, il metodo non fa niente.
6896SUBROUTINE vol7d_set_attr_ind(this)
6897TYPE(vol7d),INTENT(inout) :: this !< oggetto in cui creare gli indici
6898
6899INTEGER :: i
6900
6901! real
6902IF (ASSOCIATED(this%dativar%r)) THEN
6903 IF (ASSOCIATED(this%dativarattr%r)) THEN
6904 DO i = 1, SIZE(this%dativar%r)
6905 this%dativar%r(i)%r = &
6906 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
6907 ENDDO
6908 ENDIF
6909
6910 IF (ASSOCIATED(this%dativarattr%d)) THEN
6911 DO i = 1, SIZE(this%dativar%r)
6912 this%dativar%r(i)%d = &
6913 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
6914 ENDDO
6915 ENDIF
6916
6917 IF (ASSOCIATED(this%dativarattr%i)) THEN
6918 DO i = 1, SIZE(this%dativar%r)
6919 this%dativar%r(i)%i = &
6920 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
6921 ENDDO
6922 ENDIF
6923
6924 IF (ASSOCIATED(this%dativarattr%b)) THEN
6925 DO i = 1, SIZE(this%dativar%r)
6926 this%dativar%r(i)%b = &
6927 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
6928 ENDDO
6929 ENDIF
6930
6931 IF (ASSOCIATED(this%dativarattr%c)) THEN
6932 DO i = 1, SIZE(this%dativar%r)
6933 this%dativar%r(i)%c = &
6934 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
6935 ENDDO
6936 ENDIF
6937ENDIF
6938! double
6939IF (ASSOCIATED(this%dativar%d)) THEN
6940 IF (ASSOCIATED(this%dativarattr%r)) THEN
6941 DO i = 1, SIZE(this%dativar%d)
6942 this%dativar%d(i)%r = &
6943 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
6944 ENDDO
6945 ENDIF
6946
6947 IF (ASSOCIATED(this%dativarattr%d)) THEN
6948 DO i = 1, SIZE(this%dativar%d)
6949 this%dativar%d(i)%d = &
6950 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
6951 ENDDO
6952 ENDIF
6953
6954 IF (ASSOCIATED(this%dativarattr%i)) THEN
6955 DO i = 1, SIZE(this%dativar%d)
6956 this%dativar%d(i)%i = &
6957 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
6958 ENDDO
6959 ENDIF
6960
6961 IF (ASSOCIATED(this%dativarattr%b)) THEN
6962 DO i = 1, SIZE(this%dativar%d)
6963 this%dativar%d(i)%b = &
6964 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
6965 ENDDO
6966 ENDIF
6967
6968 IF (ASSOCIATED(this%dativarattr%c)) THEN
6969 DO i = 1, SIZE(this%dativar%d)
6970 this%dativar%d(i)%c = &
6971 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
6972 ENDDO
6973 ENDIF
6974ENDIF
6975! integer
6976IF (ASSOCIATED(this%dativar%i)) THEN
6977 IF (ASSOCIATED(this%dativarattr%r)) THEN
6978 DO i = 1, SIZE(this%dativar%i)
6979 this%dativar%i(i)%r = &
6980 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
6981 ENDDO
6982 ENDIF
6983
6984 IF (ASSOCIATED(this%dativarattr%d)) THEN
6985 DO i = 1, SIZE(this%dativar%i)
6986 this%dativar%i(i)%d = &
6987 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
6988 ENDDO
6989 ENDIF
6990
6991 IF (ASSOCIATED(this%dativarattr%i)) THEN
6992 DO i = 1, SIZE(this%dativar%i)
6993 this%dativar%i(i)%i = &
6994 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
6995 ENDDO
6996 ENDIF
6997
6998 IF (ASSOCIATED(this%dativarattr%b)) THEN
6999 DO i = 1, SIZE(this%dativar%i)
7000 this%dativar%i(i)%b = &
7001 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
7002 ENDDO
7003 ENDIF
7004
7005 IF (ASSOCIATED(this%dativarattr%c)) THEN
7006 DO i = 1, SIZE(this%dativar%i)
7007 this%dativar%i(i)%c = &
7008 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
7009 ENDDO
7010 ENDIF
7011ENDIF
7012! byte
7013IF (ASSOCIATED(this%dativar%b)) THEN
7014 IF (ASSOCIATED(this%dativarattr%r)) THEN
7015 DO i = 1, SIZE(this%dativar%b)
7016 this%dativar%b(i)%r = &
7017 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
7018 ENDDO
7019 ENDIF
7020
7021 IF (ASSOCIATED(this%dativarattr%d)) THEN
7022 DO i = 1, SIZE(this%dativar%b)
7023 this%dativar%b(i)%d = &
7024 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
7025 ENDDO
7026 ENDIF
7027
7028 IF (ASSOCIATED(this%dativarattr%i)) THEN
7029 DO i = 1, SIZE(this%dativar%b)
7030 this%dativar%b(i)%i = &
7031 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
7032 ENDDO
7033 ENDIF
7034
7035 IF (ASSOCIATED(this%dativarattr%b)) THEN
7036 DO i = 1, SIZE(this%dativar%b)
7037 this%dativar%b(i)%b = &
7038 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
7039 ENDDO
7040 ENDIF
7041
7042 IF (ASSOCIATED(this%dativarattr%c)) THEN
7043 DO i = 1, SIZE(this%dativar%b)
7044 this%dativar%b(i)%c = &
7045 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
7046 ENDDO
7047 ENDIF
7048ENDIF
7049! character
7050IF (ASSOCIATED(this%dativar%c)) THEN
7051 IF (ASSOCIATED(this%dativarattr%r)) THEN
7052 DO i = 1, SIZE(this%dativar%c)
7053 this%dativar%c(i)%r = &
7054 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
7055 ENDDO
7056 ENDIF
7057
7058 IF (ASSOCIATED(this%dativarattr%d)) THEN
7059 DO i = 1, SIZE(this%dativar%c)
7060 this%dativar%c(i)%d = &
7061 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
7062 ENDDO
7063 ENDIF
7064
7065 IF (ASSOCIATED(this%dativarattr%i)) THEN
7066 DO i = 1, SIZE(this%dativar%c)
7067 this%dativar%c(i)%i = &
7068 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
7069 ENDDO
7070 ENDIF
7071
7072 IF (ASSOCIATED(this%dativarattr%b)) THEN
7073 DO i = 1, SIZE(this%dativar%c)
7074 this%dativar%c(i)%b = &
7075 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
7076 ENDDO
7077 ENDIF
7078
7079 IF (ASSOCIATED(this%dativarattr%c)) THEN
7080 DO i = 1, SIZE(this%dativar%c)
7081 this%dativar%c(i)%c = &
7082 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
7083 ENDDO
7084 ENDIF
7085ENDIF
7086
7087END SUBROUTINE vol7d_set_attr_ind
7088
7089
7090!> Metodo per fondere 2 oggetti vol7d.
7091!! Il secondo volume viene accodato al primo e poi distrutto, si veda
7092!! quindi la descrizione di ::vol7d_append. Se uno degli oggetti \a
7093!! this o \a that sono vuoti non perde tempo inutile,
7094SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
7095 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7096TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, alla fine conterrà il risultato della fusione
7097TYPE(vol7d),INTENT(INOUT) :: that !< secondo oggetto in ingresso, alla fine sarà distrutto
7098LOGICAL,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
7099LOGICAL,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
7100LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
7101
7102TYPE(vol7d) :: v7d_clean
7103
7104
7106 this = that
7108 that = v7d_clean ! destroy that without deallocating
7109ELSE ! Append that to this and destroy that
7111 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7113ENDIF
7114
7115END SUBROUTINE vol7d_merge
7116
7117
7118!> Metodo per accodare un oggetto vol7d ad un altro.
7119!! Si tratta di un metodo molto potente e versatile;
7120!! i descrittori delle dimensioni del volume finale conterranno i valori
7121!! dei corrispondenti descrittori del primo e del secondo volume
7122!! e i volumi di anagrafica e dati conterranno i valori dei due volumi
7123!! ai posti giusti, e valori mancanti per le nuove combinazioni che
7124!! eventualmente si verranno a creare.
7125!! Se i volumi multidimensionali di anagrafica e/o dati dei 2 oggetti
7126!! hanno un'intersezione non nulla, negli elementi comuni il volume finale
7127!! conterrà il corrispondente elemento del \b secondo volume.
7128!! Attenzione che, durante l'esecuzione del metodo, la memoria richiesta è
7129!! pari alla memoria complessiva occupata dai 2 volumi iniziali più
7130!! la memoria complessiva del volume finale, per cui, nel caso di volumi grandi,
7131!! ci potrebbero essere problemi di esaurimento della memoria centrale.
7132!! Se l'oggetto \a that è vuoto non perde tempo inutile,
7133!!
7134!! \todo nel caso di elementi comuni inserire la possibiità (opzionale per
7135!! non penalizzare le prestazioni quando ciò non serve) di effettuare una scelta
7136!! più ragionata dell'elemento da tenere, almeno controllando i dati mancanti
7137!! se non le flag di qualità
7138!!
7139!! \todo "rateizzare" l'allocazione dei volumi per ridurre l'occupazione di
7140!! memoria nel caso siano allocati contemporaneamente volumi di variabili e
7141!! di attributi o più volumi di tipi diversi
7142!!
7143!! \todo il parametro \a that è dichiarato \a INOUT perché la vol7d_alloc_vol
7144!! può modificarlo, bisognerebbe implementare una vol7d_check_vol che restituisca
7145!! errore anziché usare la vol7d_alloc_vol.
7146SUBROUTINE vol7d_append(this, that, sort, bestdata, &
7147 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
7148TYPE(vol7d),INTENT(INOUT) :: this !< primo oggetto in ingresso, a cui sarà accodato il secondo
7149TYPE(vol7d),INTENT(IN) :: that !< secondo oggetto in ingresso, non viene modificato dal metodo
7150LOGICAL,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
7151! experimental, please do not use outside the library now, they force the use
7152! of a simplified mapping algorithm which is valid only whene the dimension
7153! content is the same in both volumes , or when one of them is empty
7154LOGICAL,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
7155LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
7156
7157
7158TYPE(vol7d) :: v7dtmp
7159LOGICAL :: lsort, lbestdata
7160INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
7161 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
7162
7164IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
7167 RETURN
7168ENDIF
7169
7170IF (this%time_definition /= that%time_definition) THEN
7171 CALL l4f_log(l4f_fatal, &
7172 'in vol7d_append, cannot append volumes with different &
7173 &time definition')
7174 CALL raise_fatal_error()
7175ENDIF
7176
7177! Completo l'allocazione per avere volumi a norma
7178CALL vol7d_alloc_vol(this)
7179
7183
7184! Calcolo le mappature tra volumi vecchi e volume nuovo
7185! I puntatori remap* vengono tutti o allocati o nullificati
7186IF (optio_log(ltimesimple)) THEN
7187 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
7188 lsort, remapt1, remapt2)
7189ELSE
7190 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
7191 lsort, remapt1, remapt2)
7192ENDIF
7193IF (optio_log(ltimerangesimple)) THEN
7194 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
7195 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7196ELSE
7197 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
7198 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7199ENDIF
7200IF (optio_log(llevelsimple)) THEN
7201 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
7202 lsort, remapl1, remapl2)
7203ELSE
7204 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
7205 lsort, remapl1, remapl2)
7206ENDIF
7207IF (optio_log(lanasimple)) THEN
7208 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7209 .false., remapa1, remapa2)
7210ELSE
7211 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7212 .false., remapa1, remapa2)
7213ENDIF
7214IF (optio_log(lnetworksimple)) THEN
7215 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
7216 .false., remapn1, remapn2)
7217ELSE
7218 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
7219 .false., remapn1, remapn2)
7220ENDIF
7221
7222! Faccio la fusione fisica dei volumi
7223CALL vol7d_merge_finalr(this, that, v7dtmp, &
7224 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7225 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7226CALL vol7d_merge_finald(this, that, v7dtmp, &
7227 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7228 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7229CALL vol7d_merge_finali(this, that, v7dtmp, &
7230 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7231 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7232CALL vol7d_merge_finalb(this, that, v7dtmp, &
7233 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7234 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7235CALL vol7d_merge_finalc(this, that, v7dtmp, &
7236 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7237 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7238
7239! Dealloco i vettori di rimappatura
7240IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
7241IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
7242IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
7243IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
7244IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
7245IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
7246IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
7247IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
7248IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
7249IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
7250
7251! Distruggo il vecchio volume e assegno il nuovo a this
7253this = v7dtmp
7254! Ricreo gli indici var-attr
7255CALL vol7d_set_attr_ind(this)
7256
7257END SUBROUTINE vol7d_append
7258
7259
7260!> Metodo per creare una copia completa e indipendente di un oggetto vol7d.
7261!! Questo metodo crea un duplicato di tutti i membri di un oggetto vol7d,
7262!! con la possibilità di rielaborarlo durante la copia. Se l'oggetto da copiare
7263!! è vuoto non perde tempo inutile.
7264!! Attenzione, il codice:
7265!! \code
7266!! USE vol7d_class
7267!! TYPE(vol7d) :: vol1, vol2
7268!! CALL init(vol1)
7269!! CALL init(vol2)
7270!! ... ! riempio vol1
7271!! vol2 = vol1
7272!! \endcode
7273!! fa una cosa diversa rispetto a:
7274!! \code
7275!! USE vol7d_class
7276!! TYPE(vol7d) :: vol1, vol2
7277!! CALL init(vol1)
7278!! CALL init(vol2)
7279!! ... ! riempio vol1
7280!! CALL vol7d_copy(vol1, vol2)
7281!! \endcode
7282!! nel primo caso, infatti, l'operatore di assegnazione copia solo i componenti
7283!! statici di \a vol1 nei corrispondenti elementi di \a vol2, mentre i componenti che
7284!! sono allocati dinamicamente (cioè quelli che in ::vol7d hanno l'attributo
7285!! \c POINTER, in pratica quasi tutti) non vengono duplicati, ma per essi vol2
7286!! conterrà un puntatore al corrispondente elemento a cui già punta vol1, e quindi
7287!! eventuali cambiamenti al contenuto di uno dei due oggetti influenzerà il
7288!! contenuto dell'altro; nel secondo caso, invece, vol1 e vol2 sono, dopo la
7289!! vol7d_copy, 2 istanze
7290!! completamente indipendenti, ma uguali tra loro per contenuto, della classe
7291!! vol7d, e quindi hanno vita indipendente.
7292SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
7293 lsort_time, lsort_timerange, lsort_level, &
7294 ltime, ltimerange, llevel, lana, lnetwork, &
7295 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7296 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7297 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7298 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7299 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7300 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7301TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
7302TYPE(vol7d),INTENT(INOUT) :: that !< oggetto destinazione
7303LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
7304LOGICAL,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)
7305LOGICAL,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
7306LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
7307LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
7308LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
7309!> se fornito, deve essere un vettore logico della stessa lunghezza di
7310!! this%time indicante quali elementi della dimensione \a time
7311!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
7312!! nel volume copiato; in alternativa può essere un vettore di
7313!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
7314!! gli elementi (utile principalmente per le variabili); è compatibile
7315!! col parametro \a miss
7316LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7317!> come il precedente per la dimensione \a timerange
7318LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
7319!> come il precedente per la dimensione \a level
7320LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
7321!> come il precedente per la dimensione \a ana
7322LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
7323!> come il precedente per la dimensione \a network
7324LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
7325!> come il precedente per tutte le possibili dimensioni variabile
7326LOGICAL,INTENT(in),OPTIONAL :: &
7327 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7328 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7329 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7330 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7331 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7332 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7333
7334LOGICAL :: lsort, lunique, lmiss
7335INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
7336
7339IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
7340
7344
7345! Calcolo le mappature tra volume vecchio e volume nuovo
7346! I puntatori remap* vengono tutti o allocati o nullificati
7347CALL vol7d_remap1_datetime(this%time, that%time, &
7348 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
7349CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
7350 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
7351CALL vol7d_remap1_vol7d_level(this%level, that%level, &
7352 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
7353CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
7354 lsort, lunique, lmiss, remapa, lana)
7355CALL vol7d_remap1_vol7d_network(this%network, that%network, &
7356 lsort, lunique, lmiss, remapn, lnetwork)
7357
7358! lanavari, lanavarb, lanavarc, &
7359! lanaattri, lanaattrb, lanaattrc, &
7360! lanavarattri, lanavarattrb, lanavarattrc, &
7361! ldativari, ldativarb, ldativarc, &
7362! ldatiattri, ldatiattrb, ldatiattrc, &
7363! ldativarattri, ldativarattrb, ldativarattrc
7364! Faccio la riforma fisica dei volumi
7365CALL vol7d_reform_finalr(this, that, &
7366 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7367 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
7368CALL vol7d_reform_finald(this, that, &
7369 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7370 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
7371CALL vol7d_reform_finali(this, that, &
7372 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7373 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
7374CALL vol7d_reform_finalb(this, that, &
7375 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7376 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
7377CALL vol7d_reform_finalc(this, that, &
7378 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7379 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
7380
7381! Dealloco i vettori di rimappatura
7382IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
7383IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
7384IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
7385IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
7386IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
7387
7388! Ricreo gli indici var-attr
7389CALL vol7d_set_attr_ind(that)
7390that%time_definition = this%time_definition
7391
7392END SUBROUTINE vol7d_copy
7393
7394
7395!> Metodo per riformare in varie maniere un oggetto vol7d.
7396!! Equivale ad una copia (vedi ::vol7d_copy)
7397!! seguita dalla distruzione del volume iniziale e alla
7398!! sua riassegnazione al volume copiato. Ha senso se almeno uno dei parametri
7399!! \a sort, \a uniq o \a miss è fornito uguale a \c .TRUE., altrimenti
7400!! è solo una perdita di tempo.
7401!! Può essere utile, ad esempio, per eliminare stazioni
7402!! o istanti temporali indesiderati, basta assegnare il loro corrispondente
7403!! elemento del descrittore a valore mancante e chiamare vol7d_reform
7404!! con miss=.TRUE. .
7405SUBROUTINE vol7d_reform(this, sort, unique, miss, &
7406 lsort_time, lsort_timerange, lsort_level, &
7407 ltime, ltimerange, llevel, lana, lnetwork, &
7408 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7409 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7410 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7411 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7412 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7413 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
7414 ,purgeana)
7415TYPE(vol7d),INTENT(INOUT) :: this !< oggetto da riformare
7416LOGICAL,INTENT(IN),OPTIONAL :: sort !< if present and \a .TRUE., sort all the sortable dimensions
7417LOGICAL,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)
7418LOGICAL,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
7419LOGICAL,INTENT(IN),OPTIONAL :: lsort_time !< if present and \a .TRUE., sort only time dimension (alternative to \a sort )
7420LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange !< if present and \a .TRUE., sort only timerange dimension (alternative to \a sort )
7421LOGICAL,INTENT(IN),OPTIONAL :: lsort_level !< if present and \a .TRUE., sort only level dimension (alternative to \a sort )
7422!> se fornito, deve essere un vettore logico della stessa lunghezza di
7423!! this%time indicante quali elementi della dimensione \a time
7424!! mantenere (valori \c .TRUE.) e quali scartare (valori \c .FALSE.)
7425!! nel volume copiato; in alternativa può essere un vettore di
7426!! lunghezza 1, in tal caso, se \c .FALSE. , equivale a scartare tutti
7427!! gli elementi (utile principalmente per le variabili); è compatibile
7428!! col parametro \a miss
7429LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7430LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:) !< come il precedente per la dimensione \a timerange
7431LOGICAL,INTENT(IN),OPTIONAL :: llevel(:) !< come il precedente per la dimensione \a level
7432LOGICAL,INTENT(IN),OPTIONAL :: lana(:) !< come il precedente per la dimensione \a ana
7433LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:) !< come il precedente per la dimensione \a network
7434!> come il precedente per tutte le possibili dimensioni variabile
7435LOGICAL,INTENT(in),OPTIONAL :: &
7436 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7437 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7438 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7439 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7440 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7441 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7442LOGICAL,INTENT(IN),OPTIONAL :: purgeana !< if true remove ana with all data missing
7443
7444TYPE(vol7d) :: v7dtmp
7445logical,allocatable :: llana(:)
7446integer :: i
7447
7449 lsort_time, lsort_timerange, lsort_level, &
7450 ltime, ltimerange, llevel, lana, lnetwork, &
7451 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7452 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7453 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7454 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7455 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7456 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7457
7458! destroy old volume
7460
7461if (optio_log(purgeana)) then
7462 allocate(llana(size(v7dtmp%ana)))
7463 llana =.false.
7464 do i =1,size(v7dtmp%ana)
7465 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
7466 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
7467 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
7468 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
7469 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
7470 end do
7471 CALL vol7d_copy(v7dtmp, this,lana=llana)
7473 deallocate(llana)
7474else
7475 this=v7dtmp
7476end if
7477
7478END SUBROUTINE vol7d_reform
7479
7480
7481!> Sorts the sortable dimensions in the volume \a this only when necessary.
7482!! Most of the times, the time, timerange and level dimensions in a
7483!! vol7d object are correctly sorted; on the other side many methods
7484!! strictly rely on this fact in order to work correctly. This method
7485!! performs a quick check and sorts the required dimensions only if
7486!! they are not sorted in ascending order yet, improving safety
7487!! without impairing much performance.
7488SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
7489TYPE(vol7d),INTENT(INOUT) :: this !< object to be sorted
7490LOGICAL,OPTIONAL,INTENT(in) :: lsort_time !< if present and \a .TRUE., sort time dimension if it is not sorted in ascending order
7491LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange !< if present and \a .TRUE., sort timerange dimension if it is not sorted in ascending order
7492LOGICAL,OPTIONAL,INTENT(in) :: lsort_level !< if present and \a .TRUE., sort vertical level dimension if it is not sorted in ascending order
7493
7494INTEGER :: i
7495LOGICAL :: to_be_sorted
7496
7497to_be_sorted = .false.
7498CALL vol7d_alloc_vol(this) ! usual safety check
7499
7500IF (optio_log(lsort_time)) THEN
7501 DO i = 2, SIZE(this%time)
7502 IF (this%time(i) < this%time(i-1)) THEN
7503 to_be_sorted = .true.
7504 EXIT
7505 ENDIF
7506 ENDDO
7507ENDIF
7508IF (optio_log(lsort_timerange)) THEN
7509 DO i = 2, SIZE(this%timerange)
7510 IF (this%timerange(i) < this%timerange(i-1)) THEN
7511 to_be_sorted = .true.
7512 EXIT
7513 ENDIF
7514 ENDDO
7515ENDIF
7516IF (optio_log(lsort_level)) THEN
7517 DO i = 2, SIZE(this%level)
7518 IF (this%level(i) < this%level(i-1)) THEN
7519 to_be_sorted = .true.
7520 EXIT
7521 ENDIF
7522 ENDDO
7523ENDIF
7524
7525IF (to_be_sorted) CALL vol7d_reform(this, &
7526 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
7527
7528END SUBROUTINE vol7d_smart_sort
7529
7530!> Filter the contents of a volume keeping only desired data.
7531!! This subroutine filters a vol7d object by keeping only a subset of
7532!! the data contained. It can keep only times within a specified
7533!! interval, only station networks contained in a list and only
7534!! specified station or data variables. If a filter parameter is not
7535!! provided, no filtering will take place according to that criterion.
7536!! The volume is reallocated keeping only the desired data.
7537SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
7538TYPE(vol7d),INTENT(inout) :: this !< volume to be filtered
7539CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:) !< list of station variables to be kept, if not provided or of zero length, all variables are kept
7540CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:) !< list of data variables to be kept, if not provided or of zero length, all variables are kept
7541TYPE(vol7d_network),OPTIONAL :: nl(:) !< list of station networks to be kept, if not provided or of zero length, all networks are kept
7542TYPE(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
7543TYPE(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
7544
7545INTEGER :: i
7546
7547IF (PRESENT(avl)) THEN
7548 IF (SIZE(avl) > 0) THEN
7549
7550 IF (ASSOCIATED(this%anavar%r)) THEN
7551 DO i = 1, SIZE(this%anavar%r)
7552 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
7553 ENDDO
7554 ENDIF
7555
7556 IF (ASSOCIATED(this%anavar%i)) THEN
7557 DO i = 1, SIZE(this%anavar%i)
7558 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
7559 ENDDO
7560 ENDIF
7561
7562 IF (ASSOCIATED(this%anavar%b)) THEN
7563 DO i = 1, SIZE(this%anavar%b)
7564 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
7565 ENDDO
7566 ENDIF
7567
7568 IF (ASSOCIATED(this%anavar%d)) THEN
7569 DO i = 1, SIZE(this%anavar%d)
7570 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
7571 ENDDO
7572 ENDIF
7573
7574 IF (ASSOCIATED(this%anavar%c)) THEN
7575 DO i = 1, SIZE(this%anavar%c)
7576 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
7577 ENDDO
7578 ENDIF
7579
7580 ENDIF
7581ENDIF
7582
7583
7584IF (PRESENT(vl)) THEN
7585 IF (size(vl) > 0) THEN
7586 IF (ASSOCIATED(this%dativar%r)) THEN
7587 DO i = 1, SIZE(this%dativar%r)
7588 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
7589 ENDDO
7590 ENDIF
7591
7592 IF (ASSOCIATED(this%dativar%i)) THEN
7593 DO i = 1, SIZE(this%dativar%i)
7594 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
7595 ENDDO
7596 ENDIF
7597
7598 IF (ASSOCIATED(this%dativar%b)) THEN
7599 DO i = 1, SIZE(this%dativar%b)
7600 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
7601 ENDDO
7602 ENDIF
7603
7604 IF (ASSOCIATED(this%dativar%d)) THEN
7605 DO i = 1, SIZE(this%dativar%d)
7606 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
7607 ENDDO
7608 ENDIF
7609
7610 IF (ASSOCIATED(this%dativar%c)) THEN
7611 DO i = 1, SIZE(this%dativar%c)
7612 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7613 ENDDO
7614 ENDIF
7615
7616 IF (ASSOCIATED(this%dativar%c)) THEN
7617 DO i = 1, SIZE(this%dativar%c)
7618 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7619 ENDDO
7620 ENDIF
7621
7622 ENDIF
7623ENDIF
7624
7625IF (PRESENT(nl)) THEN
7626 IF (SIZE(nl) > 0) THEN
7627 DO i = 1, SIZE(this%network)
7628 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
7629 ENDDO
7630 ENDIF
7631ENDIF
7632
7633IF (PRESENT(s_d)) THEN
7635 WHERE (this%time < s_d)
7636 this%time = datetime_miss
7637 END WHERE
7638 ENDIF
7639ENDIF
7640
7641IF (PRESENT(e_d)) THEN
7643 WHERE (this%time > e_d)
7644 this%time = datetime_miss
7645 END WHERE
7646 ENDIF
7647ENDIF
7648
7649CALL vol7d_reform(this, miss=.true.)
7650
7651END SUBROUTINE vol7d_filter
7652
7653
7654!> Metodo per convertire i volumi di dati di un oggetto vol7d in dati
7655!! reali dove possibile. L'oggetto convertito è una copia completa
7656!! dell'originale che può essere quindi distrutto dopo la chiamata.
7657!! Per i dati di anagrafica, al momento sono convertiti solo
7658!! i dati CHARACTER se è passato \a anaconv=.TRUE.
7659!! Gli attributi non sono toccati.
7660SUBROUTINE vol7d_convr(this, that, anaconv)
7661TYPE(vol7d),INTENT(IN) :: this !< oggetto origine
7662TYPE(vol7d),INTENT(INOUT) :: that !< oggetto convertito
7663LOGICAL,OPTIONAL,INTENT(in) :: anaconv !< converti anche anagrafica
7664INTEGER :: i
7665LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
7666TYPE(vol7d) :: v7d_tmp
7667
7668IF (optio_log(anaconv)) THEN
7669 acp=fv
7670 acn=tv
7671ELSE
7672 acp=tv
7673 acn=fv
7674ENDIF
7675
7676! Volume con solo i dati reali e tutti gli attributi
7677! l'anagrafica e` copiata interamente se necessario
7678CALL vol7d_copy(this, that, &
7679 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7680 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7681
7682! Volume solo di dati double
7683CALL vol7d_copy(this, v7d_tmp, &
7684 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7685 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7686 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7687 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7688 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7689 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7690
7691! converto a dati reali
7692IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7693
7694 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7695! alloco i dati reali e vi trasferisco i double
7696 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7697 SIZE(v7d_tmp%volanad, 3)))
7698 DO i = 1, SIZE(v7d_tmp%anavar%d)
7699 v7d_tmp%volanar(:,i,:) = &
7700 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7701 ENDDO
7702 DEALLOCATE(v7d_tmp%volanad)
7703! trasferisco le variabili
7704 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7705 NULLIFY(v7d_tmp%anavar%d)
7706 ENDIF
7707
7708 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7709! alloco i dati reali e vi trasferisco i double
7710 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7711 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7712 SIZE(v7d_tmp%voldatid, 6)))
7713 DO i = 1, SIZE(v7d_tmp%dativar%d)
7714 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7715 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7716 ENDDO
7717 DEALLOCATE(v7d_tmp%voldatid)
7718! trasferisco le variabili
7719 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7720 NULLIFY(v7d_tmp%dativar%d)
7721 ENDIF
7722
7723! fondo con il volume definitivo
7724 CALL vol7d_merge(that, v7d_tmp)
7725ELSE
7727ENDIF
7728
7729
7730! Volume solo di dati interi
7731CALL vol7d_copy(this, v7d_tmp, &
7732 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7733 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7734 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7735 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7736 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7737 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7738
7739! converto a dati reali
7740IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7741
7742 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7743! alloco i dati reali e vi trasferisco gli interi
7744 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7745 SIZE(v7d_tmp%volanai, 3)))
7746 DO i = 1, SIZE(v7d_tmp%anavar%i)
7747 v7d_tmp%volanar(:,i,:) = &
7748 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7749 ENDDO
7750 DEALLOCATE(v7d_tmp%volanai)
7751! trasferisco le variabili
7752 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7753 NULLIFY(v7d_tmp%anavar%i)
7754 ENDIF
7755
7756 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7757! alloco i dati reali e vi trasferisco gli interi
7758 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7759 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7760 SIZE(v7d_tmp%voldatii, 6)))
7761 DO i = 1, SIZE(v7d_tmp%dativar%i)
7762 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7763 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7764 ENDDO
7765 DEALLOCATE(v7d_tmp%voldatii)
7766! trasferisco le variabili
7767 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7768 NULLIFY(v7d_tmp%dativar%i)
7769 ENDIF
7770
7771! fondo con il volume definitivo
7772 CALL vol7d_merge(that, v7d_tmp)
7773ELSE
7775ENDIF
7776
7777
7778! Volume solo di dati byte
7779CALL vol7d_copy(this, v7d_tmp, &
7780 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7781 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7782 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7783 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7784 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7785 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7786
7787! converto a dati reali
7788IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7789
7790 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7791! alloco i dati reali e vi trasferisco i byte
7792 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7793 SIZE(v7d_tmp%volanab, 3)))
7794 DO i = 1, SIZE(v7d_tmp%anavar%b)
7795 v7d_tmp%volanar(:,i,:) = &
7796 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7797 ENDDO
7798 DEALLOCATE(v7d_tmp%volanab)
7799! trasferisco le variabili
7800 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7801 NULLIFY(v7d_tmp%anavar%b)
7802 ENDIF
7803
7804 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7805! alloco i dati reali e vi trasferisco i byte
7806 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7807 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7808 SIZE(v7d_tmp%voldatib, 6)))
7809 DO i = 1, SIZE(v7d_tmp%dativar%b)
7810 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7811 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7812 ENDDO
7813 DEALLOCATE(v7d_tmp%voldatib)
7814! trasferisco le variabili
7815 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7816 NULLIFY(v7d_tmp%dativar%b)
7817 ENDIF
7818
7819! fondo con il volume definitivo
7820 CALL vol7d_merge(that, v7d_tmp)
7821ELSE
7823ENDIF
7824
7825
7826! Volume solo di dati character
7827CALL vol7d_copy(this, v7d_tmp, &
7828 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7829 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7830 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7831 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7832 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7833 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7834
7835! converto a dati reali
7836IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
7837
7838 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
7839! alloco i dati reali e vi trasferisco i character
7840 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
7841 SIZE(v7d_tmp%volanac, 3)))
7842 DO i = 1, SIZE(v7d_tmp%anavar%c)
7843 v7d_tmp%volanar(:,i,:) = &
7844 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
7845 ENDDO
7846 DEALLOCATE(v7d_tmp%volanac)
7847! trasferisco le variabili
7848 v7d_tmp%anavar%r => v7d_tmp%anavar%c
7849 NULLIFY(v7d_tmp%anavar%c)
7850 ENDIF
7851
7852 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
7853! alloco i dati reali e vi trasferisco i character
7854 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
7855 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
7856 SIZE(v7d_tmp%voldatic, 6)))
7857 DO i = 1, SIZE(v7d_tmp%dativar%c)
7858 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7859 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
7860 ENDDO
7861 DEALLOCATE(v7d_tmp%voldatic)
7862! trasferisco le variabili
7863 v7d_tmp%dativar%r => v7d_tmp%dativar%c
7864 NULLIFY(v7d_tmp%dativar%c)
7865 ENDIF
7866
7867! fondo con il volume definitivo
7868 CALL vol7d_merge(that, v7d_tmp)
7869ELSE
7871ENDIF
7872
7873END SUBROUTINE vol7d_convr
7874
7875
7876!> Metodo per ottenere solo le differenze tra due oggetti vol7d.
7877!! Il primo volume viene confrontato col secondo; nel secondo volume ovunque
7878!! i dati confrontati siano coincidenti viene impostato valore mancante.
7879SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
7880TYPE(vol7d),INTENT(IN) :: this !< primo volume da confrontare
7881TYPE(vol7d),INTENT(OUT) :: that !< secondo volume da confrontare in cui eliminare i dati coincidenti
7882logical , optional, intent(in) :: data_only !< attiva l'elaborazione dei soli dati e non dell'anagrafica (default: .false.)
7883logical , optional, intent(in) :: ana !< attiva l'elaborazione dell'anagrafica (coordinate e ident) (default: .false.)
7884logical :: ldata_only,lana
7885
7886IF (PRESENT(data_only)) THEN
7887 ldata_only = data_only
7888ELSE
7889 ldata_only = .false.
7890ENDIF
7891
7892IF (PRESENT(ana)) THEN
7893 lana = ana
7894ELSE
7895 lana = .false.
7896ENDIF
7897
7898
7899#undef VOL7D_POLY_ARRAY
7900#define VOL7D_POLY_ARRAY voldati
7901#include "vol7d_class_diff.F90"
7902#undef VOL7D_POLY_ARRAY
7903#define VOL7D_POLY_ARRAY voldatiattr
7904#include "vol7d_class_diff.F90"
7905#undef VOL7D_POLY_ARRAY
7906
7907if ( .not. ldata_only) then
7908
7909#define VOL7D_POLY_ARRAY volana
7910#include "vol7d_class_diff.F90"
7911#undef VOL7D_POLY_ARRAY
7912#define VOL7D_POLY_ARRAY volanaattr
7913#include "vol7d_class_diff.F90"
7914#undef VOL7D_POLY_ARRAY
7915
7916 if(lana)then
7917 where ( this%ana == that%ana )
7918 that%ana = vol7d_ana_miss
7919 end where
7920 end if
7921
7922end if
7923
7924
7925
7926END SUBROUTINE vol7d_diff_only
7927
7928
7929
7930! Creo le routine da ripetere per i vari tipi di dati di v7d
7931! tramite un template e il preprocessore
7932#undef VOL7D_POLY_TYPE
7933#undef VOL7D_POLY_TYPES
7934#define VOL7D_POLY_TYPE REAL
7935#define VOL7D_POLY_TYPES r
7936#include "vol7d_class_type_templ.F90"
7937#undef VOL7D_POLY_TYPE
7938#undef VOL7D_POLY_TYPES
7939#define VOL7D_POLY_TYPE DOUBLE PRECISION
7940#define VOL7D_POLY_TYPES d
7941#include "vol7d_class_type_templ.F90"
7942#undef VOL7D_POLY_TYPE
7943#undef VOL7D_POLY_TYPES
7944#define VOL7D_POLY_TYPE INTEGER
7945#define VOL7D_POLY_TYPES i
7946#include "vol7d_class_type_templ.F90"
7947#undef VOL7D_POLY_TYPE
7948#undef VOL7D_POLY_TYPES
7949#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
7950#define VOL7D_POLY_TYPES b
7951#include "vol7d_class_type_templ.F90"
7952#undef VOL7D_POLY_TYPE
7953#undef VOL7D_POLY_TYPES
7954#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
7955#define VOL7D_POLY_TYPES c
7956#include "vol7d_class_type_templ.F90"
7957
7958! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
7959! tramite un template e il preprocessore
7960#define VOL7D_SORT
7961#undef VOL7D_NO_ZERO_ALLOC
7962#undef VOL7D_POLY_TYPE
7963#define VOL7D_POLY_TYPE datetime
7964#include "vol7d_class_desc_templ.F90"
7965#undef VOL7D_POLY_TYPE
7966#define VOL7D_POLY_TYPE vol7d_timerange
7967#include "vol7d_class_desc_templ.F90"
7968#undef VOL7D_POLY_TYPE
7969#define VOL7D_POLY_TYPE vol7d_level
7970#include "vol7d_class_desc_templ.F90"
7971#undef VOL7D_SORT
7972#undef VOL7D_POLY_TYPE
7973#define VOL7D_POLY_TYPE vol7d_network
7974#include "vol7d_class_desc_templ.F90"
7975#undef VOL7D_POLY_TYPE
7976#define VOL7D_POLY_TYPE vol7d_ana
7977#include "vol7d_class_desc_templ.F90"
7978#define VOL7D_NO_ZERO_ALLOC
7979#undef VOL7D_POLY_TYPE
7980#define VOL7D_POLY_TYPE vol7d_var
7981#include "vol7d_class_desc_templ.F90"
7982
7983!>\brief Scrittura su file di un volume Vol7d.
7984!! Scrittura su file unformatted di un intero volume Vol7d.
7985!! Il volume viene serializzato e scritto su file.
7986!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
7987!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
7988!! tali parametri saranno in output.
7989!! Se non viene fornito il nome file viene utilizzato un file di default con nome pari al nome del programma in
7990!! esecuzione con postfisso ".v7d".
7991!! Come parametro opzionale c'è la description che insieme alla data corrente viene inserita nell'header del file.
7992subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
7993
7994TYPE(vol7d),INTENT(IN) :: this !< volume vol7d da scrivere
7995integer,optional,intent(inout) :: unit !< unità su cui scrivere; se passata =0 ritorna il valore rielaborato (default =rielaborato internamente con getlun )
7996character(len=*),intent(in),optional :: filename !< nome del file su cui scrivere
7997character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
7998character(len=*),INTENT(IN),optional :: description !< descrizione del volume
7999
8000integer :: lunit
8001character(len=254) :: ldescription,arg,lfilename
8002integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8003 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8004 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8005 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8006 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8007 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8008 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8009!integer :: im,id,iy
8010integer :: tarray(8)
8011logical :: opened,exist
8012
8013 nana=0
8014 ntime=0
8015 ntimerange=0
8016 nlevel=0
8017 nnetwork=0
8018 ndativarr=0
8019 ndativari=0
8020 ndativarb=0
8021 ndativard=0
8022 ndativarc=0
8023 ndatiattrr=0
8024 ndatiattri=0
8025 ndatiattrb=0
8026 ndatiattrd=0
8027 ndatiattrc=0
8028 ndativarattrr=0
8029 ndativarattri=0
8030 ndativarattrb=0
8031 ndativarattrd=0
8032 ndativarattrc=0
8033 nanavarr=0
8034 nanavari=0
8035 nanavarb=0
8036 nanavard=0
8037 nanavarc=0
8038 nanaattrr=0
8039 nanaattri=0
8040 nanaattrb=0
8041 nanaattrd=0
8042 nanaattrc=0
8043 nanavarattrr=0
8044 nanavarattri=0
8045 nanavarattrb=0
8046 nanavarattrd=0
8047 nanavarattrc=0
8048
8049
8050!call idate(im,id,iy)
8051call date_and_time(values=tarray)
8052call getarg(0,arg)
8053
8054if (present(description))then
8055 ldescription=description
8056else
8057 ldescription="Vol7d generated by: "//trim(arg)
8058end if
8059
8060if (.not. present(unit))then
8061 lunit=getunit()
8062else
8063 if (unit==0)then
8064 lunit=getunit()
8065 unit=lunit
8066 else
8067 lunit=unit
8068 end if
8069end if
8070
8071lfilename=trim(arg)//".v7d"
8073
8074if (present(filename))then
8075 if (filename /= "")then
8076 lfilename=filename
8077 end if
8078end if
8079
8080if (present(filename_auto))filename_auto=lfilename
8081
8082
8083inquire(unit=lunit,opened=opened)
8084if (.not. opened) then
8085! inquire(file=lfilename, EXIST=exist)
8086! IF (exist) THEN
8087! CALL l4f_log(L4F_FATAL, &
8088! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
8089! CALL raise_fatal_error()
8090! ENDIF
8091 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
8092 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8093end if
8094
8095if (associated(this%ana)) nana=size(this%ana)
8096if (associated(this%time)) ntime=size(this%time)
8097if (associated(this%timerange)) ntimerange=size(this%timerange)
8098if (associated(this%level)) nlevel=size(this%level)
8099if (associated(this%network)) nnetwork=size(this%network)
8100
8101if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
8102if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
8103if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
8104if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
8105if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
8106
8107if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
8108if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
8109if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
8110if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
8111if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
8112
8113if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
8114if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
8115if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
8116if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
8117if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
8118
8119if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
8120if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
8121if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
8122if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
8123if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
8124
8125if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
8126if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
8127if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
8128if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
8129if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
8130
8131if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
8132if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
8133if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
8134if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
8135if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
8136
8137write(unit=lunit)ldescription
8138write(unit=lunit)tarray
8139
8140write(unit=lunit)&
8141 nana, ntime, ntimerange, nlevel, nnetwork, &
8142 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8143 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8144 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8145 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8146 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8147 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8148 this%time_definition
8149
8150
8151!write(unit=lunit)this
8152
8153
8154!! prime 5 dimensioni
8157if (associated(this%level)) write(unit=lunit)this%level
8158if (associated(this%timerange)) write(unit=lunit)this%timerange
8159if (associated(this%network)) write(unit=lunit)this%network
8160
8161 !! 6a dimensione: variabile dell'anagrafica e dei dati
8162 !! con relativi attributi e in 5 tipi diversi
8163
8164if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
8165if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
8166if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
8167if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
8168if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
8169
8170if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
8171if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
8172if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
8173if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
8174if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
8175
8176if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
8177if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
8178if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
8179if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
8180if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
8181
8182if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
8183if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
8184if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
8185if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
8186if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
8187
8188if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
8189if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
8190if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
8191if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
8192if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
8193
8194if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
8195if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
8196if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
8197if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
8198if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
8199
8200!! Volumi di valori e attributi per anagrafica e dati
8201
8202if (associated(this%volanar)) write(unit=lunit)this%volanar
8203if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
8204if (associated(this%voldatir)) write(unit=lunit)this%voldatir
8205if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
8206
8207if (associated(this%volanai)) write(unit=lunit)this%volanai
8208if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
8209if (associated(this%voldatii)) write(unit=lunit)this%voldatii
8210if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
8211
8212if (associated(this%volanab)) write(unit=lunit)this%volanab
8213if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
8214if (associated(this%voldatib)) write(unit=lunit)this%voldatib
8215if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
8216
8217if (associated(this%volanad)) write(unit=lunit)this%volanad
8218if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
8219if (associated(this%voldatid)) write(unit=lunit)this%voldatid
8220if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
8221
8222if (associated(this%volanac)) write(unit=lunit)this%volanac
8223if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
8224if (associated(this%voldatic)) write(unit=lunit)this%voldatic
8225if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
8226
8227if (.not. present(unit)) close(unit=lunit)
8228
8229end subroutine vol7d_write_on_file
8230
8231
8232!>\brief Lettura da file di un volume Vol7d.
8233!! Lettura da file unformatted di un intero volume Vol7d.
8234!! Questa subroutine comprende vol7d_alloc e vol7d_alloc_vol.
8235!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
8236!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
8237!! tali parametri saranno in output.
8238
8239
8240subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
8241
8242TYPE(vol7d),INTENT(OUT) :: this !< Volume vol7d da leggere
8243integer,intent(inout),optional :: unit !< unità su cui è stato aperto un file; se =0 rielaborato internamente (default = elaborato internamente con getunit)
8244character(len=*),INTENT(in),optional :: filename !< nome del file eventualmente da aprire (default = (nome dell'eseguibile)//.v7d )
8245character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
8246character(len=*),INTENT(out),optional :: description !< descrizione del volume letto
8247integer,intent(out),optional :: tarray(8) !< vettore come definito da "date_and_time" della data di scrittura del volume
8248
8249
8250integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8251 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8252 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8253 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8254 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8255 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8256 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8257
8258character(len=254) :: ldescription,lfilename,arg
8259integer :: ltarray(8),lunit,ios
8260logical :: opened,exist
8261
8262
8263call getarg(0,arg)
8264
8265if (.not. present(unit))then
8266 lunit=getunit()
8267else
8268 if (unit==0)then
8269 lunit=getunit()
8270 unit=lunit
8271 else
8272 lunit=unit
8273 end if
8274end if
8275
8276lfilename=trim(arg)//".v7d"
8278
8279if (present(filename))then
8280 if (filename /= "")then
8281 lfilename=filename
8282 end if
8283end if
8284
8285if (present(filename_auto))filename_auto=lfilename
8286
8287
8288inquire(unit=lunit,opened=opened)
8289IF (.NOT. opened) THEN
8290 inquire(file=lfilename,exist=exist)
8291 IF (.NOT.exist) THEN
8292 CALL l4f_log(l4f_fatal, &
8293 'in vol7d_read_from_file, file does not exists, cannot open')
8294 CALL raise_fatal_error()
8295 ENDIF
8296 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
8297 status='OLD', action='READ')
8298 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8299end if
8300
8301
8303read(unit=lunit,iostat=ios)ldescription
8304
8305if (ios < 0) then ! A negative value indicates that the End of File or End of Record
8306 call vol7d_alloc (this)
8307 call vol7d_alloc_vol (this)
8308 if (present(description))description=ldescription
8309 if (present(tarray))tarray=ltarray
8310 if (.not. present(unit)) close(unit=lunit)
8311end if
8312
8313read(unit=lunit)ltarray
8314
8315CALL l4f_log(l4f_info, 'Reading vol7d from file')
8316CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
8319
8320if (present(description))description=ldescription
8321if (present(tarray))tarray=ltarray
8322
8323read(unit=lunit)&
8324 nana, ntime, ntimerange, nlevel, nnetwork, &
8325 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8326 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8327 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8328 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8329 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8330 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8331 this%time_definition
8332
8333call vol7d_alloc (this, &
8334 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
8335 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
8336 ndativard=ndativard, ndativarc=ndativarc,&
8337 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
8338 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
8339 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
8340 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
8341 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
8342 nanavard=nanavard, nanavarc=nanavarc,&
8343 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
8344 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
8345 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
8346 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
8347
8348
8351if (associated(this%level)) read(unit=lunit)this%level
8352if (associated(this%timerange)) read(unit=lunit)this%timerange
8353if (associated(this%network)) read(unit=lunit)this%network
8354
8355if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
8356if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
8357if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
8358if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
8359if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
8360
8361if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
8362if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
8363if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
8364if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
8365if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
8366
8367if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
8368if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
8369if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
8370if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
8371if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
8372
8373if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
8374if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
8375if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
8376if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
8377if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
8378
8379if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
8380if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
8381if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
8382if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
8383if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
8384
8385if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
8386if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
8387if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
8388if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
8389if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
8390
8391call vol7d_alloc_vol (this)
8392
8393!! Volumi di valori e attributi per anagrafica e dati
8394
8395if (associated(this%volanar)) read(unit=lunit)this%volanar
8396if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
8397if (associated(this%voldatir)) read(unit=lunit)this%voldatir
8398if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
8399
8400if (associated(this%volanai)) read(unit=lunit)this%volanai
8401if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
8402if (associated(this%voldatii)) read(unit=lunit)this%voldatii
8403if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
8404
8405if (associated(this%volanab)) read(unit=lunit)this%volanab
8406if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
8407if (associated(this%voldatib)) read(unit=lunit)this%voldatib
8408if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
8409
8410if (associated(this%volanad)) read(unit=lunit)this%volanad
8411if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
8412if (associated(this%voldatid)) read(unit=lunit)this%voldatid
8413if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
8414
8415if (associated(this%volanac)) read(unit=lunit)this%volanac
8416if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
8417if (associated(this%voldatic)) read(unit=lunit)this%voldatic
8418if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
8419
8420if (.not. present(unit)) close(unit=lunit)
8421
8422end subroutine vol7d_read_from_file
8423
8424
8425! to double precision
8426elemental doubleprecision function doubledatd(voldat,var)
8427doubleprecision,intent(in) :: voldat
8428type(vol7d_var),intent(in) :: var
8429
8430doubledatd=voldat
8431
8432end function doubledatd
8433
8434
8435elemental doubleprecision function doubledatr(voldat,var)
8436real,intent(in) :: voldat
8437type(vol7d_var),intent(in) :: var
8438
8440 doubledatr=dble(voldat)
8441else
8442 doubledatr=dmiss
8443end if
8444
8445end function doubledatr
8446
8447
8448elemental doubleprecision function doubledati(voldat,var)
8449integer,intent(in) :: voldat
8450type(vol7d_var),intent(in) :: var
8451
8454 doubledati=dble(voldat)/10.d0**var%scalefactor
8455 else
8456 doubledati=dble(voldat)
8457 endif
8458else
8459 doubledati=dmiss
8460end if
8461
8462end function doubledati
8463
8464
8465elemental doubleprecision function doubledatb(voldat,var)
8466integer(kind=int_b),intent(in) :: voldat
8467type(vol7d_var),intent(in) :: var
8468
8471 doubledatb=dble(voldat)/10.d0**var%scalefactor
8472 else
8473 doubledatb=dble(voldat)
8474 endif
8475else
8476 doubledatb=dmiss
8477end if
8478
8479end function doubledatb
8480
8481
8482elemental doubleprecision function doubledatc(voldat,var)
8483CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8484type(vol7d_var),intent(in) :: var
8485
8486doubledatc = c2d(voldat)
8488 doubledatc=doubledatc/10.d0**var%scalefactor
8489end if
8490
8491end function doubledatc
8492
8493
8494! to integer
8495elemental integer function integerdatd(voldat,var)
8496doubleprecision,intent(in) :: voldat
8497type(vol7d_var),intent(in) :: var
8498
8501 integerdatd=nint(voldat*10d0**var%scalefactor)
8502 else
8503 integerdatd=nint(voldat)
8504 endif
8505else
8506 integerdatd=imiss
8507end if
8508
8509end function integerdatd
8510
8511
8512elemental integer function integerdatr(voldat,var)
8513real,intent(in) :: voldat
8514type(vol7d_var),intent(in) :: var
8515
8518 integerdatr=nint(voldat*10d0**var%scalefactor)
8519 else
8520 integerdatr=nint(voldat)
8521 endif
8522else
8523 integerdatr=imiss
8524end if
8525
8526end function integerdatr
8527
8528
8529elemental integer function integerdati(voldat,var)
8530integer,intent(in) :: voldat
8531type(vol7d_var),intent(in) :: var
8532
8533integerdati=voldat
8534
8535end function integerdati
8536
8537
8538elemental integer function integerdatb(voldat,var)
8539integer(kind=int_b),intent(in) :: voldat
8540type(vol7d_var),intent(in) :: var
8541
8543 integerdatb=voldat
8544else
8545 integerdatb=imiss
8546end if
8547
8548end function integerdatb
8549
8550
8551elemental integer function integerdatc(voldat,var)
8552CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8553type(vol7d_var),intent(in) :: var
8554
8555integerdatc=c2i(voldat)
8556
8557end function integerdatc
8558
8559
8560! to real
8561elemental real function realdatd(voldat,var)
8562doubleprecision,intent(in) :: voldat
8563type(vol7d_var),intent(in) :: var
8564
8566 realdatd=real(voldat)
8567else
8568 realdatd=rmiss
8569end if
8570
8571end function realdatd
8572
8573
8574elemental real function realdatr(voldat,var)
8575real,intent(in) :: voldat
8576type(vol7d_var),intent(in) :: var
8577
8578realdatr=voldat
8579
8580end function realdatr
8581
8582
8583elemental real function realdati(voldat,var)
8584integer,intent(in) :: voldat
8585type(vol7d_var),intent(in) :: var
8586
8589 realdati=float(voldat)/10.**var%scalefactor
8590 else
8591 realdati=float(voldat)
8592 endif
8593else
8594 realdati=rmiss
8595end if
8596
8597end function realdati
8598
8599
8600elemental real function realdatb(voldat,var)
8601integer(kind=int_b),intent(in) :: voldat
8602type(vol7d_var),intent(in) :: var
8603
8606 realdatb=float(voldat)/10**var%scalefactor
8607 else
8608 realdatb=float(voldat)
8609 endif
8610else
8611 realdatb=rmiss
8612end if
8613
8614end function realdatb
8615
8616
8617elemental real function realdatc(voldat,var)
8618CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8619type(vol7d_var),intent(in) :: var
8620
8621realdatc=c2r(voldat)
8623 realdatc=realdatc/10.**var%scalefactor
8624end if
8625
8626end function realdatc
8627
8628
8629!> Return an ana volume of a requested variable as real data.
8630!! It returns a 2-d array of the proper shape (ana x network) for the
8631!! ana variable requested, converted to real type. If the conversion
8632!! fails or if the variable is not contained in the ana volume,
8633!! missing data are returned.
8634FUNCTION realanavol(this, var) RESULT(vol)
8635TYPE(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
8636TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
8637REAL :: vol(SIZE(this%ana),size(this%network))
8638
8639CHARACTER(len=1) :: dtype
8640INTEGER :: indvar
8641
8642dtype = cmiss
8643indvar = index(this%anavar, var, type=dtype)
8644
8645IF (indvar > 0) THEN
8646 SELECT CASE (dtype)
8647 CASE("d")
8648 vol = realdat(this%volanad(:,indvar,:), var)
8649 CASE("r")
8650 vol = this%volanar(:,indvar,:)
8651 CASE("i")
8652 vol = realdat(this%volanai(:,indvar,:), var)
8653 CASE("b")
8654 vol = realdat(this%volanab(:,indvar,:), var)
8655 CASE("c")
8656 vol = realdat(this%volanac(:,indvar,:), var)
8657 CASE default
8658 vol = rmiss
8659 END SELECT
8660ELSE
8661 vol = rmiss
8662ENDIF
8663
8664END FUNCTION realanavol
8665
8666
8667!> Return an ana volume of a requested variable as integer data.
8668!! It returns a 2-d array of the proper shape (ana x network) for the
8669!! ana variable requested, converted to integer type. If the conversion
8670!! fails or if the variable is not contained in the ana volume,
8671!! missing data are returned.
8672FUNCTION integeranavol(this, var) RESULT(vol)
8673TYPE(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
8674TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
8675INTEGER :: vol(SIZE(this%ana),size(this%network))
8676
8677CHARACTER(len=1) :: dtype
8678INTEGER :: indvar
8679
8680dtype = cmiss
8681indvar = index(this%anavar, var, type=dtype)
8682
8683IF (indvar > 0) THEN
8684 SELECT CASE (dtype)
8685 CASE("d")
8686 vol = integerdat(this%volanad(:,indvar,:), var)
8687 CASE("r")
8688 vol = integerdat(this%volanar(:,indvar,:), var)
8689 CASE("i")
8690 vol = this%volanai(:,indvar,:)
8691 CASE("b")
8692 vol = integerdat(this%volanab(:,indvar,:), var)
8693 CASE("c")
8694 vol = integerdat(this%volanac(:,indvar,:), var)
8695 CASE default
8696 vol = imiss
8697 END SELECT
8698ELSE
8699 vol = imiss
8700ENDIF
8701
8702END FUNCTION integeranavol
8703
8704
8705!> Move data for all variables from one coordinate in the character volume to other.
8706!! Only not missing data will be copyed and all attributes will be moved together.
8707!! Usefull to colapse data spread in more indices (level or time or ....).
8708!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
8709!! to obtain a new vol7d with less data shape.
8710subroutine move_datac (v7d,&
8711 indana,indtime,indlevel,indtimerange,indnetwork,&
8712 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8713
8714TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
8715
8716integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
8717integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
8718integer :: inddativar,inddativarattr
8719
8720
8721do inddativar=1,size(v7d%dativar%c)
8722
8724 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8725 ) then
8726
8727 ! dati
8728 v7d%voldatic &
8729 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8730 v7d%voldatic &
8731 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8732
8733
8734 ! attributi
8735 if (associated (v7d%dativarattr%i)) then
8736 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8737 if (inddativarattr > 0 ) then
8738 v7d%voldatiattri &
8739 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8740 v7d%voldatiattri &
8741 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8742 end if
8743 end if
8744
8745 if (associated (v7d%dativarattr%r)) then
8746 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8747 if (inddativarattr > 0 ) then
8748 v7d%voldatiattrr &
8749 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8750 v7d%voldatiattrr &
8751 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8752 end if
8753 end if
8754
8755 if (associated (v7d%dativarattr%d)) then
8756 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8757 if (inddativarattr > 0 ) then
8758 v7d%voldatiattrd &
8759 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8760 v7d%voldatiattrd &
8761 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8762 end if
8763 end if
8764
8765 if (associated (v7d%dativarattr%b)) then
8766 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8767 if (inddativarattr > 0 ) then
8768 v7d%voldatiattrb &
8769 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8770 v7d%voldatiattrb &
8771 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8772 end if
8773 end if
8774
8775 if (associated (v7d%dativarattr%c)) then
8776 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8777 if (inddativarattr > 0 ) then
8778 v7d%voldatiattrc &
8779 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8780 v7d%voldatiattrc &
8781 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8782 end if
8783 end if
8784
8785 end if
8786
8787end do
8788
8789end subroutine move_datac
8790
8791!> Move data for all variables from one coordinate in the real volume to other.
8792!! Only not missing data will be copyed and all attributes will be moved together.
8793!! Usefull to colapse data spread in more indices (level or time or ....).
8794!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
8795!! to obtain a new vol7d with less data shape.
8796subroutine move_datar (v7d,&
8797 indana,indtime,indlevel,indtimerange,indnetwork,&
8798 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8799
8800TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
8801
8802integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
8803integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
8804integer :: inddativar,inddativarattr
8805
8806
8807do inddativar=1,size(v7d%dativar%r)
8808
8810 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8811 ) then
8812
8813 ! dati
8814 v7d%voldatir &
8815 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8816 v7d%voldatir &
8817 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8818
8819
8820 ! attributi
8821 if (associated (v7d%dativarattr%i)) then
8822 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8823 if (inddativarattr > 0 ) then
8824 v7d%voldatiattri &
8825 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8826 v7d%voldatiattri &
8827 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8828 end if
8829 end if
8830
8831 if (associated (v7d%dativarattr%r)) then
8832 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
8833 if (inddativarattr > 0 ) then
8834 v7d%voldatiattrr &
8835 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8836 v7d%voldatiattrr &
8837 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8838 end if
8839 end if
8840
8841 if (associated (v7d%dativarattr%d)) then
8842 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
8843 if (inddativarattr > 0 ) then
8844 v7d%voldatiattrd &
8845 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8846 v7d%voldatiattrd &
8847 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8848 end if
8849 end if
8850
8851 if (associated (v7d%dativarattr%b)) then
8852 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
8853 if (inddativarattr > 0 ) then
8854 v7d%voldatiattrb &
8855 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8856 v7d%voldatiattrb &
8857 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8858 end if
8859 end if
8860
8861 if (associated (v7d%dativarattr%c)) then
8862 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
8863 if (inddativarattr > 0 ) then
8864 v7d%voldatiattrc &
8865 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8866 v7d%voldatiattrc &
8867 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8868 end if
8869 end if
8870
8871 end if
8872
8873end do
8874
8875end subroutine move_datar
8876
8877
8878!> Reduce some dimensions (level and timerage) for semplification (rounding).
8879!! You can use this for simplify and use variables in computation like alchimia
8880!! where fields have to be on the same coordinate
8881!! It return real or character data only: if input is charcter data only it return character otherwise il return
8882!! all the data converted to real.
8883!! examples:
8884!! means in time for short periods and istantaneous values
8885!! 2 meter and surface levels
8886!! If there are data on more then one almost equal levels or timeranges, the first var present (at least one point)
8887!! will be taken (order is by icreasing var index).
8888!! You can use predefined values for classic semplification
8889!! almost_equal_levels and almost_equal_timeranges
8890!! The level or timerange in output will be defined by the first element of level and timerange list
8891subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
8892type(vol7d),intent(inout) :: v7din !< input volume
8893type(vol7d),intent(out) :: v7dout !> output volume
8894type(vol7d_level),intent(in),optional :: level(:) !< almost equal level list
8895type(vol7d_timerange),intent(in),optional :: timerange(:) !< almost equal timerange list
8896!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
8897!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
8898logical,intent(in),optional :: nostatproc !< do not take in account statistical processing code in timerange and P2
8899
8900integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
8901integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
8902type(vol7d_level) :: roundlevel(size(v7din%level))
8903type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
8904type(vol7d) :: v7d_tmp
8905
8906
8907nbin=0
8908
8909if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
8910if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
8911if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
8912if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
8913
8915
8916roundlevel=v7din%level
8917
8918if (present(level))then
8919 do ilevel = 1, size(v7din%level)
8920 if ((any(v7din%level(ilevel) .almosteq. level))) then
8921 roundlevel(ilevel)=level(1)
8922 end if
8923 end do
8924end if
8925
8926roundtimerange=v7din%timerange
8927
8928if (present(timerange))then
8929 do itimerange = 1, size(v7din%timerange)
8930 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
8931 roundtimerange(itimerange)=timerange(1)
8932 end if
8933 end do
8934end if
8935
8936!set istantaneous values everywere
8937!preserve p1 for forecast time
8938if (optio_log(nostatproc)) then
8939 roundtimerange(:)%timerange=254
8940 roundtimerange(:)%p2=0
8941end if
8942
8943
8944nana=size(v7din%ana)
8945nlevel=count_distinct(roundlevel,back=.true.)
8946ntime=size(v7din%time)
8947ntimerange=count_distinct(roundtimerange,back=.true.)
8948nnetwork=size(v7din%network)
8949
8951
8952if (nbin == 0) then
8954else
8955 call vol7d_convr(v7din,v7d_tmp)
8956end if
8957
8958v7d_tmp%level=roundlevel
8959v7d_tmp%timerange=roundtimerange
8960
8961do ilevel=1, size(v7d_tmp%level)
8962 indl=index(v7d_tmp%level,roundlevel(ilevel))
8963 do itimerange=1,size(v7d_tmp%timerange)
8964 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
8965
8966 if (indl /= ilevel .or. indt /= itimerange) then
8967
8968 do iana=1, nana
8969 do itime=1,ntime
8970 do inetwork=1,nnetwork
8971
8972 if (nbin > 0) then
8973 call move_datar (v7d_tmp,&
8974 iana,itime,ilevel,itimerange,inetwork,&
8975 iana,itime,indl,indt,inetwork)
8976 else
8977 call move_datac (v7d_tmp,&
8978 iana,itime,ilevel,itimerange,inetwork,&
8979 iana,itime,indl,indt,inetwork)
8980 end if
8981
8982 end do
8983 end do
8984 end do
8985
8986 end if
8987
8988 end do
8989end do
8990
8991! set to missing level and time > nlevel
8992do ilevel=nlevel+1,size(v7d_tmp%level)
8994end do
8995
8996do itimerange=ntimerange+1,size(v7d_tmp%timerange)
8998end do
8999
9000!copy with remove
9003
9004!call display(v7dout)
9005
9006end subroutine v7d_rounding
9007
9008
9010
9011!>\example esempio_qc_convert.f90
9012!!\brief Programma esempio semplice per la scrittura su file di un volume vol7d
9013!!
9014!!Programma che scrive su file un volume vol7d letto da una serie di file ASCII.
9015!!Questo programma scrive i dati del clima che poi verranno letti da modqccli
9016
9017
9018!>\example esempio_v7ddballe_move_and_collapse.f90
9019!!\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 |