libsim Versione 7.1.11

◆ vol7d_get_voldatiattrb()

subroutine vol7d_get_voldatiattrb ( type(vol7d), intent(in)  this,
integer, dimension(:), intent(in)  dimlist,
integer(kind=int_b), dimension(:), optional, pointer  vol1dp,
integer(kind=int_b), dimension(:,:), optional, pointer  vol2dp,
integer(kind=int_b), dimension(:,:,:), optional, pointer  vol3dp,
integer(kind=int_b), dimension(:,:,:,:), optional, pointer  vol4dp,
integer(kind=int_b), dimension(:,:,:,:,:), optional, pointer  vol5dp,
integer(kind=int_b), dimension(:,:,:,:,:,:), optional, pointer  vol6dp,
integer(kind=int_b), dimension(:,:,:,:,:,:,:), optional, pointer  vol7dp 
)

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

Definizione alla linea 5735 del file vol7d_class.F90.

5737! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
5738! authors:
5739! Davide Cesari <dcesari@arpa.emr.it>
5740! Paolo Patruno <ppatruno@arpa.emr.it>
5741
5742! This program is free software; you can redistribute it and/or
5743! modify it under the terms of the GNU General Public License as
5744! published by the Free Software Foundation; either version 2 of
5745! the License, or (at your option) any later version.
5746
5747! This program is distributed in the hope that it will be useful,
5748! but WITHOUT ANY WARRANTY; without even the implied warranty of
5749! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5750! GNU General Public License for more details.
5751
5752! You should have received a copy of the GNU General Public License
5753! along with this program. If not, see <http://www.gnu.org/licenses/>.
5754#include "config.h"
5755
5767
5821MODULE vol7d_class
5822USE kinds
5826USE log4fortran
5827USE err_handling
5828USE io_units
5835IMPLICIT NONE
5836
5837
5838INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
5839 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
5840
5841INTEGER, PARAMETER :: vol7d_ana_a=1
5842INTEGER, PARAMETER :: vol7d_var_a=2
5843INTEGER, PARAMETER :: vol7d_network_a=3
5844INTEGER, PARAMETER :: vol7d_attr_a=4
5845INTEGER, PARAMETER :: vol7d_ana_d=1
5846INTEGER, PARAMETER :: vol7d_time_d=2
5847INTEGER, PARAMETER :: vol7d_level_d=3
5848INTEGER, PARAMETER :: vol7d_timerange_d=4
5849INTEGER, PARAMETER :: vol7d_var_d=5
5850INTEGER, PARAMETER :: vol7d_network_d=6
5851INTEGER, PARAMETER :: vol7d_attr_d=7
5852INTEGER, PARAMETER :: vol7d_cdatalen=32
5853
5854TYPE vol7d_varmap
5855 INTEGER :: r, d, i, b, c
5856END TYPE vol7d_varmap
5857
5860TYPE vol7d
5862 TYPE(vol7d_ana),POINTER :: ana(:)
5864 TYPE(datetime),POINTER :: time(:)
5866 TYPE(vol7d_level),POINTER :: level(:)
5868 TYPE(vol7d_timerange),POINTER :: timerange(:)
5870 TYPE(vol7d_network),POINTER :: network(:)
5872 TYPE(vol7d_varvect) :: anavar
5874 TYPE(vol7d_varvect) :: anaattr
5876 TYPE(vol7d_varvect) :: anavarattr
5878 TYPE(vol7d_varvect) :: dativar
5880 TYPE(vol7d_varvect) :: datiattr
5882 TYPE(vol7d_varvect) :: dativarattr
5883
5885 REAL,POINTER :: volanar(:,:,:)
5887 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5889 INTEGER,POINTER :: volanai(:,:,:)
5891 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5893 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5894
5896 REAL,POINTER :: volanaattrr(:,:,:,:)
5898 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5900 INTEGER,POINTER :: volanaattri(:,:,:,:)
5902 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5904 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5905
5907 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5909 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5911 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5913 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5915 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5916
5918 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5920 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5922 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5924 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5926 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5927
5929 integer :: time_definition
5930
5931END TYPE vol7d
5932
5936INTERFACE init
5937 MODULE PROCEDURE vol7d_init
5938END INTERFACE
5939
5941INTERFACE delete
5942 MODULE PROCEDURE vol7d_delete
5943END INTERFACE
5944
5946INTERFACE export
5947 MODULE PROCEDURE vol7d_write_on_file
5948END INTERFACE
5949
5951INTERFACE import
5952 MODULE PROCEDURE vol7d_read_from_file
5953END INTERFACE
5954
5956INTERFACE display
5957 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5958END INTERFACE
5959
5961INTERFACE to_char
5962 MODULE PROCEDURE to_char_dat
5963END INTERFACE
5964
5966INTERFACE doubledat
5967 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5968END INTERFACE
5969
5971INTERFACE realdat
5972 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5973END INTERFACE
5974
5976INTERFACE integerdat
5977 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5978END INTERFACE
5979
5981INTERFACE copy
5982 MODULE PROCEDURE vol7d_copy
5983END INTERFACE
5984
5986INTERFACE c_e
5987 MODULE PROCEDURE vol7d_c_e
5988END INTERFACE
5989
5993INTERFACE check
5994 MODULE PROCEDURE vol7d_check
5995END INTERFACE
5996
6010INTERFACE rounding
6011 MODULE PROCEDURE v7d_rounding
6012END INTERFACE
6013
6014!!$INTERFACE get_volana
6015!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
6016!!$ vol7d_get_volanab, vol7d_get_volanac
6017!!$END INTERFACE
6018!!$
6019!!$INTERFACE get_voldati
6020!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
6021!!$ vol7d_get_voldatib, vol7d_get_voldatic
6022!!$END INTERFACE
6023!!$
6024!!$INTERFACE get_volanaattr
6025!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
6026!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
6027!!$END INTERFACE
6028!!$
6029!!$INTERFACE get_voldatiattr
6030!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
6031!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
6032!!$END INTERFACE
6033
6034PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
6035 vol7d_get_volc, &
6036 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
6037 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
6038 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
6039 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
6040 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
6041 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
6042 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
6043 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
6044 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
6045 vol7d_display, dat_display, dat_vect_display, &
6046 to_char_dat, vol7d_check
6047
6048PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
6049
6050PRIVATE vol7d_c_e
6051
6052CONTAINS
6053
6054
6059SUBROUTINE vol7d_init(this,time_definition)
6060TYPE(vol7d),intent(out) :: this
6061integer,INTENT(IN),OPTIONAL :: time_definition
6062
6063CALL init(this%anavar)
6064CALL init(this%anaattr)
6065CALL init(this%anavarattr)
6066CALL init(this%dativar)
6067CALL init(this%datiattr)
6068CALL init(this%dativarattr)
6069CALL vol7d_var_features_init() ! initialise var features table once
6070
6071NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
6072
6073NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
6074NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
6075NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
6076NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
6077NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
6078
6079if(present(time_definition)) then
6080 this%time_definition=time_definition
6081else
6082 this%time_definition=1 !default to validity time
6083end if
6084
6085END SUBROUTINE vol7d_init
6086
6087
6091ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
6092TYPE(vol7d),intent(inout) :: this
6093LOGICAL, INTENT(in), OPTIONAL :: dataonly
6094
6095
6096IF (.NOT. optio_log(dataonly)) THEN
6097 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
6098 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
6099 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
6100 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
6101 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
6102 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
6103 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
6104 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
6105 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
6106 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
6107ENDIF
6108IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
6109IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
6110IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
6111IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
6112IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
6113IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
6114IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
6115IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
6116IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
6117IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
6118
6119IF (.NOT. optio_log(dataonly)) THEN
6120 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6121 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6122ENDIF
6123IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6124IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6125IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6126
6127IF (.NOT. optio_log(dataonly)) THEN
6128 CALL delete(this%anavar)
6129 CALL delete(this%anaattr)
6130 CALL delete(this%anavarattr)
6131ENDIF
6132CALL delete(this%dativar)
6133CALL delete(this%datiattr)
6134CALL delete(this%dativarattr)
6135
6136END SUBROUTINE vol7d_delete
6137
6138
6139
6140integer function vol7d_check(this)
6141TYPE(vol7d),intent(in) :: this
6142integer :: i,j,k,l,m,n
6143
6144vol7d_check=0
6145
6146if (associated(this%voldatii)) then
6147do i = 1,size(this%voldatii,1)
6148 do j = 1,size(this%voldatii,2)
6149 do k = 1,size(this%voldatii,3)
6150 do l = 1,size(this%voldatii,4)
6151 do m = 1,size(this%voldatii,5)
6152 do n = 1,size(this%voldatii,6)
6153 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
6154 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
6155 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
6156 vol7d_check=1
6157 end if
6158 end do
6159 end do
6160 end do
6161 end do
6162 end do
6163end do
6164end if
6165
6166
6167if (associated(this%voldatir)) then
6168do i = 1,size(this%voldatir,1)
6169 do j = 1,size(this%voldatir,2)
6170 do k = 1,size(this%voldatir,3)
6171 do l = 1,size(this%voldatir,4)
6172 do m = 1,size(this%voldatir,5)
6173 do n = 1,size(this%voldatir,6)
6174 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
6175 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
6176 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
6177 vol7d_check=2
6178 end if
6179 end do
6180 end do
6181 end do
6182 end do
6183 end do
6184end do
6185end if
6186
6187if (associated(this%voldatid)) then
6188do i = 1,size(this%voldatid,1)
6189 do j = 1,size(this%voldatid,2)
6190 do k = 1,size(this%voldatid,3)
6191 do l = 1,size(this%voldatid,4)
6192 do m = 1,size(this%voldatid,5)
6193 do n = 1,size(this%voldatid,6)
6194 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
6195 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
6196 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
6197 vol7d_check=3
6198 end if
6199 end do
6200 end do
6201 end do
6202 end do
6203 end do
6204end do
6205end if
6206
6207if (associated(this%voldatib)) then
6208do i = 1,size(this%voldatib,1)
6209 do j = 1,size(this%voldatib,2)
6210 do k = 1,size(this%voldatib,3)
6211 do l = 1,size(this%voldatib,4)
6212 do m = 1,size(this%voldatib,5)
6213 do n = 1,size(this%voldatib,6)
6214 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
6215 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
6216 //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
6217 vol7d_check=4
6218 end if
6219 end do
6220 end do
6221 end do
6222 end do
6223 end do
6224end do
6225end if
6226
6227end function vol7d_check
6228
6229
6230
6231!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
6233SUBROUTINE vol7d_display(this)
6234TYPE(vol7d),intent(in) :: this
6235integer :: i
6236
6237REAL :: rdat
6238DOUBLE PRECISION :: ddat
6239INTEGER :: idat
6240INTEGER(kind=int_b) :: bdat
6241CHARACTER(len=vol7d_cdatalen) :: cdat
6242
6243
6244print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
6245if (this%time_definition == 0) then
6246 print*,"TIME DEFINITION: time is reference time"
6247else if (this%time_definition == 1) then
6248 print*,"TIME DEFINITION: time is validity time"
6249else
6250 print*,"Time definition have a wrong walue:", this%time_definition
6251end if
6252
6253IF (ASSOCIATED(this%network))then
6254 print*,"---- network vector ----"
6255 print*,"elements=",size(this%network)
6256 do i=1, size(this%network)
6257 call display(this%network(i))
6258 end do
6259end IF
6260
6261IF (ASSOCIATED(this%ana))then
6262 print*,"---- ana vector ----"
6263 print*,"elements=",size(this%ana)
6264 do i=1, size(this%ana)
6265 call display(this%ana(i))
6266 end do
6267end IF
6268
6269IF (ASSOCIATED(this%time))then
6270 print*,"---- time vector ----"
6271 print*,"elements=",size(this%time)
6272 do i=1, size(this%time)
6273 call display(this%time(i))
6274 end do
6275end if
6276
6277IF (ASSOCIATED(this%level)) then
6278 print*,"---- level vector ----"
6279 print*,"elements=",size(this%level)
6280 do i =1,size(this%level)
6281 call display(this%level(i))
6282 end do
6283end if
6284
6285IF (ASSOCIATED(this%timerange))then
6286 print*,"---- timerange vector ----"
6287 print*,"elements=",size(this%timerange)
6288 do i =1,size(this%timerange)
6289 call display(this%timerange(i))
6290 end do
6291end if
6292
6293
6294print*,"---- ana vector ----"
6295print*,""
6296print*,"->>>>>>>>> anavar -"
6297call display(this%anavar)
6298print*,""
6299print*,"->>>>>>>>> anaattr -"
6300call display(this%anaattr)
6301print*,""
6302print*,"->>>>>>>>> anavarattr -"
6303call display(this%anavarattr)
6304
6305print*,"-- ana data section (first point) --"
6306
6307idat=imiss
6308rdat=rmiss
6309ddat=dmiss
6310bdat=ibmiss
6311cdat=cmiss
6312
6313!ntime = MIN(SIZE(this%time),nprint)
6314!ntimerange = MIN(SIZE(this%timerange),nprint)
6315!nlevel = MIN(SIZE(this%level),nprint)
6316!nnetwork = MIN(SIZE(this%network),nprint)
6317!nana = MIN(SIZE(this%ana),nprint)
6318
6319IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
6320if (associated(this%volanai)) then
6321 do i=1,size(this%anavar%i)
6322 idat=this%volanai(1,i,1)
6323 if (associated(this%anavar%i)) call display(this%anavar%i(i),idat,rdat,ddat,bdat,cdat)
6324 end do
6325end if
6326idat=imiss
6327
6328if (associated(this%volanar)) then
6329 do i=1,size(this%anavar%r)
6330 rdat=this%volanar(1,i,1)
6331 if (associated(this%anavar%r)) call display(this%anavar%r(i),idat,rdat,ddat,bdat,cdat)
6332 end do
6333end if
6334rdat=rmiss
6335
6336if (associated(this%volanad)) then
6337 do i=1,size(this%anavar%d)
6338 ddat=this%volanad(1,i,1)
6339 if (associated(this%anavar%d)) call display(this%anavar%d(i),idat,rdat,ddat,bdat,cdat)
6340 end do
6341end if
6342ddat=dmiss
6343
6344if (associated(this%volanab)) then
6345 do i=1,size(this%anavar%b)
6346 bdat=this%volanab(1,i,1)
6347 if (associated(this%anavar%b)) call display(this%anavar%b(i),idat,rdat,ddat,bdat,cdat)
6348 end do
6349end if
6350bdat=ibmiss
6351
6352if (associated(this%volanac)) then
6353 do i=1,size(this%anavar%c)
6354 cdat=this%volanac(1,i,1)
6355 if (associated(this%anavar%c)) call display(this%anavar%c(i),idat,rdat,ddat,bdat,cdat)
6356 end do
6357end if
6358cdat=cmiss
6359ENDIF
6360
6361print*,"---- data vector ----"
6362print*,""
6363print*,"->>>>>>>>> dativar -"
6364call display(this%dativar)
6365print*,""
6366print*,"->>>>>>>>> datiattr -"
6367call display(this%datiattr)
6368print*,""
6369print*,"->>>>>>>>> dativarattr -"
6370call display(this%dativarattr)
6371
6372print*,"-- data data section (first point) --"
6373
6374idat=imiss
6375rdat=rmiss
6376ddat=dmiss
6377bdat=ibmiss
6378cdat=cmiss
6379
6380IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
6381 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
6382if (associated(this%voldatii)) then
6383 do i=1,size(this%dativar%i)
6384 idat=this%voldatii(1,1,1,1,i,1)
6385 if (associated(this%dativar%i)) call display(this%dativar%i(i),idat,rdat,ddat,bdat,cdat)
6386 end do
6387end if
6388idat=imiss
6389
6390if (associated(this%voldatir)) then
6391 do i=1,size(this%dativar%r)
6392 rdat=this%voldatir(1,1,1,1,i,1)
6393 if (associated(this%dativar%r)) call display(this%dativar%r(i),idat,rdat,ddat,bdat,cdat)
6394 end do
6395end if
6396rdat=rmiss
6397
6398if (associated(this%voldatid)) then
6399 do i=1,size(this%dativar%d)
6400 ddat=this%voldatid(1,1,1,1,i,1)
6401 if (associated(this%dativar%d)) call display(this%dativar%d(i),idat,rdat,ddat,bdat,cdat)
6402 end do
6403end if
6404ddat=dmiss
6405
6406if (associated(this%voldatib)) then
6407 do i=1,size(this%dativar%b)
6408 bdat=this%voldatib(1,1,1,1,i,1)
6409 if (associated(this%dativar%b)) call display(this%dativar%b(i),idat,rdat,ddat,bdat,cdat)
6410 end do
6411end if
6412bdat=ibmiss
6413
6414if (associated(this%voldatic)) then
6415 do i=1,size(this%dativar%c)
6416 cdat=this%voldatic(1,1,1,1,i,1)
6417 if (associated(this%dativar%c)) call display(this%dativar%c(i),idat,rdat,ddat,bdat,cdat)
6418 end do
6419end if
6420cdat=cmiss
6421ENDIF
6422
6423print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
6424
6425END SUBROUTINE vol7d_display
6426
6427
6429SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
6430TYPE(vol7d_var),intent(in) :: this
6432REAL :: rdat
6434DOUBLE PRECISION :: ddat
6436INTEGER :: idat
6438INTEGER(kind=int_b) :: bdat
6440CHARACTER(len=*) :: cdat
6441
6442print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6443
6444end SUBROUTINE dat_display
6445
6447SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
6448
6449TYPE(vol7d_var),intent(in) :: this(:)
6451REAL :: rdat(:)
6453DOUBLE PRECISION :: ddat(:)
6455INTEGER :: idat(:)
6457INTEGER(kind=int_b) :: bdat(:)
6459CHARACTER(len=*):: cdat(:)
6460
6461integer :: i
6462
6463do i =1,size(this)
6464 call display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
6465end do
6466
6467end SUBROUTINE dat_vect_display
6468
6469
6470FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6471#ifdef HAVE_DBALLE
6472USE dballef
6473#endif
6474TYPE(vol7d_var),INTENT(in) :: this
6476REAL :: rdat
6478DOUBLE PRECISION :: ddat
6480INTEGER :: idat
6482INTEGER(kind=int_b) :: bdat
6484CHARACTER(len=*) :: cdat
6485CHARACTER(len=80) :: to_char_dat
6486
6487CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
6488
6489
6490#ifdef HAVE_DBALLE
6491INTEGER :: handle, ier
6492
6493handle = 0
6494to_char_dat="VALUE: "
6495
6496if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
6497if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
6498if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
6499if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
6500
6501if ( c_e(cdat))then
6502 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
6503 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
6504 ier = idba_fatto(handle)
6505 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
6506endif
6507
6508#else
6509
6510to_char_dat="VALUE: "
6511if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
6512if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
6513if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
6514if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
6515if (c_e(cdat)) to_char_dat=trim(to_char_dat)//" ;char> "//trim(cdat)
6516
6517#endif
6518
6519END FUNCTION to_char_dat
6520
6521
6524FUNCTION vol7d_c_e(this) RESULT(c_e)
6525TYPE(vol7d), INTENT(in) :: this
6526
6527LOGICAL :: c_e
6528
6529c_e = ASSOCIATED(this%ana) .OR. ASSOCIATED(this%time) .OR. &
6530 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
6531 ASSOCIATED(this%network) .OR. &
6532 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6533 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6534 ASSOCIATED(this%anavar%c) .OR. &
6535 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
6536 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
6537 ASSOCIATED(this%anaattr%c) .OR. &
6538 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6539 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6540 ASSOCIATED(this%dativar%c) .OR. &
6541 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
6542 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
6543 ASSOCIATED(this%datiattr%c)
6544
6545END FUNCTION vol7d_c_e
6546
6547
6586SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
6587 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6588 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6589 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6590 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6591 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6592 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
6593 ini)
6594TYPE(vol7d),INTENT(inout) :: this
6595INTEGER,INTENT(in),OPTIONAL :: nana
6596INTEGER,INTENT(in),OPTIONAL :: ntime
6597INTEGER,INTENT(in),OPTIONAL :: nlevel
6598INTEGER,INTENT(in),OPTIONAL :: ntimerange
6599INTEGER,INTENT(in),OPTIONAL :: nnetwork
6601INTEGER,INTENT(in),OPTIONAL :: &
6602 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6603 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6604 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6605 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6606 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6607 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
6608LOGICAL,INTENT(in),OPTIONAL :: ini
6609
6610INTEGER :: i
6611LOGICAL :: linit
6612
6613IF (PRESENT(ini)) THEN
6614 linit = ini
6615ELSE
6616 linit = .false.
6617ENDIF
6618
6619! Dimensioni principali
6620IF (PRESENT(nana)) THEN
6621 IF (nana >= 0) THEN
6622 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6623 ALLOCATE(this%ana(nana))
6624 IF (linit) THEN
6625 DO i = 1, nana
6626 CALL init(this%ana(i))
6627 ENDDO
6628 ENDIF
6629 ENDIF
6630ENDIF
6631IF (PRESENT(ntime)) THEN
6632 IF (ntime >= 0) THEN
6633 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6634 ALLOCATE(this%time(ntime))
6635 IF (linit) THEN
6636 DO i = 1, ntime
6637 CALL init(this%time(i))
6638 ENDDO
6639 ENDIF
6640 ENDIF
6641ENDIF
6642IF (PRESENT(nlevel)) THEN
6643 IF (nlevel >= 0) THEN
6644 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6645 ALLOCATE(this%level(nlevel))
6646 IF (linit) THEN
6647 DO i = 1, nlevel
6648 CALL init(this%level(i))
6649 ENDDO
6650 ENDIF
6651 ENDIF
6652ENDIF
6653IF (PRESENT(ntimerange)) THEN
6654 IF (ntimerange >= 0) THEN
6655 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6656 ALLOCATE(this%timerange(ntimerange))
6657 IF (linit) THEN
6658 DO i = 1, ntimerange
6659 CALL init(this%timerange(i))
6660 ENDDO
6661 ENDIF
6662 ENDIF
6663ENDIF
6664IF (PRESENT(nnetwork)) THEN
6665 IF (nnetwork >= 0) THEN
6666 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6667 ALLOCATE(this%network(nnetwork))
6668 IF (linit) THEN
6669 DO i = 1, nnetwork
6670 CALL init(this%network(i))
6671 ENDDO
6672 ENDIF
6673 ENDIF
6674ENDIF
6675! Dimensioni dei tipi delle variabili
6676CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
6677 nanavari, nanavarb, nanavarc, ini)
6678CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
6679 nanaattri, nanaattrb, nanaattrc, ini)
6680CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
6681 nanavarattri, nanavarattrb, nanavarattrc, ini)
6682CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
6683 ndativari, ndativarb, ndativarc, ini)
6684CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
6685 ndatiattri, ndatiattrb, ndatiattrc, ini)
6686CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
6687 ndativarattri, ndativarattrb, ndativarattrc, ini)
6688
6689END SUBROUTINE vol7d_alloc
6690
6691
6692FUNCTION vol7d_check_alloc_ana(this)
6693TYPE(vol7d),INTENT(in) :: this
6694LOGICAL :: vol7d_check_alloc_ana
6695
6696vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
6697
6698END FUNCTION vol7d_check_alloc_ana
6699
6700SUBROUTINE vol7d_force_alloc_ana(this, ini)
6701TYPE(vol7d),INTENT(inout) :: this
6702LOGICAL,INTENT(in),OPTIONAL :: ini
6703
6704! Alloco i descrittori minimi per avere un volume di anagrafica
6705IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
6706IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
6707
6708END SUBROUTINE vol7d_force_alloc_ana
6709
6710
6711FUNCTION vol7d_check_alloc_dati(this)
6712TYPE(vol7d),INTENT(in) :: this
6713LOGICAL :: vol7d_check_alloc_dati
6714
6715vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
6716 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
6717 ASSOCIATED(this%timerange)
6718
6719END FUNCTION vol7d_check_alloc_dati
6720
6721SUBROUTINE vol7d_force_alloc_dati(this, ini)
6722TYPE(vol7d),INTENT(inout) :: this
6723LOGICAL,INTENT(in),OPTIONAL :: ini
6724
6725! Alloco i descrittori minimi per avere un volume di dati
6726CALL vol7d_force_alloc_ana(this, ini)
6727IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
6728IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
6729IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
6730
6731END SUBROUTINE vol7d_force_alloc_dati
6732
6733
6734SUBROUTINE vol7d_force_alloc(this)
6735TYPE(vol7d),INTENT(inout) :: this
6736
6737! If anything really not allocated yet, allocate with size 0
6738IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
6739IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
6740IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
6741IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
6742IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
6743
6744END SUBROUTINE vol7d_force_alloc
6745
6746
6747FUNCTION vol7d_check_vol(this)
6748TYPE(vol7d),INTENT(in) :: this
6749LOGICAL :: vol7d_check_vol
6750
6751vol7d_check_vol = c_e(this)
6752
6753! Anagrafica
6754IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6755 vol7d_check_vol = .false.
6756ENDIF
6757
6758IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6759 vol7d_check_vol = .false.
6760ENDIF
6761
6762IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6763 vol7d_check_vol = .false.
6764ENDIF
6765
6766IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6767 vol7d_check_vol = .false.
6768ENDIF
6769
6770IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6771 vol7d_check_vol = .false.
6772ENDIF
6773IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6774 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6775 ASSOCIATED(this%anavar%c)) THEN
6776 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
6777ENDIF
6778
6779! Attributi dell'anagrafica
6780IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6781 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6782 vol7d_check_vol = .false.
6783ENDIF
6784
6785IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6786 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6787 vol7d_check_vol = .false.
6788ENDIF
6789
6790IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6791 .NOT.ASSOCIATED(this%volanaattri)) THEN
6792 vol7d_check_vol = .false.
6793ENDIF
6794
6795IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6796 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6797 vol7d_check_vol = .false.
6798ENDIF
6799
6800IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6801 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6802 vol7d_check_vol = .false.
6803ENDIF
6804
6805! Dati
6806IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6807 vol7d_check_vol = .false.
6808ENDIF
6809
6810IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6811 vol7d_check_vol = .false.
6812ENDIF
6813
6814IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6815 vol7d_check_vol = .false.
6816ENDIF
6817
6818IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6819 vol7d_check_vol = .false.
6820ENDIF
6821
6822IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6823 vol7d_check_vol = .false.
6824ENDIF
6825
6826! Attributi dei dati
6827IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6828 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6829 vol7d_check_vol = .false.
6830ENDIF
6831
6832IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6833 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6834 vol7d_check_vol = .false.
6835ENDIF
6836
6837IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6838 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6839 vol7d_check_vol = .false.
6840ENDIF
6841
6842IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6843 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6844 vol7d_check_vol = .false.
6845ENDIF
6846
6847IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6848 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6849 vol7d_check_vol = .false.
6850ENDIF
6851IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6852 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6853 ASSOCIATED(this%dativar%c)) THEN
6854 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6855ENDIF
6856
6857END FUNCTION vol7d_check_vol
6858
6859
6874SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6875TYPE(vol7d),INTENT(inout) :: this
6876LOGICAL,INTENT(in),OPTIONAL :: ini
6877LOGICAL,INTENT(in),OPTIONAL :: inivol
6878
6879LOGICAL :: linivol
6880
6881IF (PRESENT(inivol)) THEN
6882 linivol = inivol
6883ELSE
6884 linivol = .true.
6885ENDIF
6886
6887! Anagrafica
6888IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6889 CALL vol7d_force_alloc_ana(this, ini)
6890 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6891 IF (linivol) this%volanar(:,:,:) = rmiss
6892ENDIF
6893
6894IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6895 CALL vol7d_force_alloc_ana(this, ini)
6896 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6897 IF (linivol) this%volanad(:,:,:) = rdmiss
6898ENDIF
6899
6900IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6901 CALL vol7d_force_alloc_ana(this, ini)
6902 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6903 IF (linivol) this%volanai(:,:,:) = imiss
6904ENDIF
6905
6906IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6907 CALL vol7d_force_alloc_ana(this, ini)
6908 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6909 IF (linivol) this%volanab(:,:,:) = ibmiss
6910ENDIF
6911
6912IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6913 CALL vol7d_force_alloc_ana(this, ini)
6914 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6915 IF (linivol) this%volanac(:,:,:) = cmiss
6916ENDIF
6917
6918! Attributi dell'anagrafica
6919IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6920 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6921 CALL vol7d_force_alloc_ana(this, ini)
6922 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6923 SIZE(this%network), SIZE(this%anaattr%r)))
6924 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6925ENDIF
6926
6927IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6928 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6929 CALL vol7d_force_alloc_ana(this, ini)
6930 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6931 SIZE(this%network), SIZE(this%anaattr%d)))
6932 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6933ENDIF
6934
6935IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6936 .NOT.ASSOCIATED(this%volanaattri)) THEN
6937 CALL vol7d_force_alloc_ana(this, ini)
6938 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6939 SIZE(this%network), SIZE(this%anaattr%i)))
6940 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6941ENDIF
6942
6943IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6944 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6945 CALL vol7d_force_alloc_ana(this, ini)
6946 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6947 SIZE(this%network), SIZE(this%anaattr%b)))
6948 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6949ENDIF
6950
6951IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6952 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6953 CALL vol7d_force_alloc_ana(this, ini)
6954 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6955 SIZE(this%network), SIZE(this%anaattr%c)))
6956 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6957ENDIF
6958
6959! Dati
6960IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6961 CALL vol7d_force_alloc_dati(this, ini)
6962 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6963 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6964 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6965ENDIF
6966
6967IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6968 CALL vol7d_force_alloc_dati(this, ini)
6969 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6970 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6971 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6972ENDIF
6973
6974IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6975 CALL vol7d_force_alloc_dati(this, ini)
6976 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6977 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6978 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6979ENDIF
6980
6981IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6982 CALL vol7d_force_alloc_dati(this, ini)
6983 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6984 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6985 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6986ENDIF
6987
6988IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6989 CALL vol7d_force_alloc_dati(this, ini)
6990 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6991 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6992 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6993ENDIF
6994
6995! Attributi dei dati
6996IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6997 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6998 CALL vol7d_force_alloc_dati(this, ini)
6999 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7000 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
7001 SIZE(this%datiattr%r)))
7002 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
7003ENDIF
7004
7005IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
7006 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
7007 CALL vol7d_force_alloc_dati(this, ini)
7008 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7009 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
7010 SIZE(this%datiattr%d)))
7011 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
7012ENDIF
7013
7014IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
7015 .NOT.ASSOCIATED(this%voldatiattri)) THEN
7016 CALL vol7d_force_alloc_dati(this, ini)
7017 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7018 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
7019 SIZE(this%datiattr%i)))
7020 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
7021ENDIF
7022
7023IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
7024 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
7025 CALL vol7d_force_alloc_dati(this, ini)
7026 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7027 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
7028 SIZE(this%datiattr%b)))
7029 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
7030ENDIF
7031
7032IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
7033 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
7034 CALL vol7d_force_alloc_dati(this, ini)
7035 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7036 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
7037 SIZE(this%datiattr%c)))
7038 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
7039ENDIF
7040
7041! Catch-all method
7042CALL vol7d_force_alloc(this)
7043
7044! Creo gli indici var-attr
7045
7046#ifdef DEBUG
7047CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
7048#endif
7049
7050CALL vol7d_set_attr_ind(this)
7051
7052
7053
7054END SUBROUTINE vol7d_alloc_vol
7055
7056
7063SUBROUTINE vol7d_set_attr_ind(this)
7064TYPE(vol7d),INTENT(inout) :: this
7065
7066INTEGER :: i
7067
7068! real
7069IF (ASSOCIATED(this%dativar%r)) THEN
7070 IF (ASSOCIATED(this%dativarattr%r)) THEN
7071 DO i = 1, SIZE(this%dativar%r)
7072 this%dativar%r(i)%r = &
7073 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
7074 ENDDO
7075 ENDIF
7076
7077 IF (ASSOCIATED(this%dativarattr%d)) THEN
7078 DO i = 1, SIZE(this%dativar%r)
7079 this%dativar%r(i)%d = &
7080 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
7081 ENDDO
7082 ENDIF
7083
7084 IF (ASSOCIATED(this%dativarattr%i)) THEN
7085 DO i = 1, SIZE(this%dativar%r)
7086 this%dativar%r(i)%i = &
7087 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
7088 ENDDO
7089 ENDIF
7090
7091 IF (ASSOCIATED(this%dativarattr%b)) THEN
7092 DO i = 1, SIZE(this%dativar%r)
7093 this%dativar%r(i)%b = &
7094 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
7095 ENDDO
7096 ENDIF
7097
7098 IF (ASSOCIATED(this%dativarattr%c)) THEN
7099 DO i = 1, SIZE(this%dativar%r)
7100 this%dativar%r(i)%c = &
7101 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
7102 ENDDO
7103 ENDIF
7104ENDIF
7105! double
7106IF (ASSOCIATED(this%dativar%d)) THEN
7107 IF (ASSOCIATED(this%dativarattr%r)) THEN
7108 DO i = 1, SIZE(this%dativar%d)
7109 this%dativar%d(i)%r = &
7110 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
7111 ENDDO
7112 ENDIF
7113
7114 IF (ASSOCIATED(this%dativarattr%d)) THEN
7115 DO i = 1, SIZE(this%dativar%d)
7116 this%dativar%d(i)%d = &
7117 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
7118 ENDDO
7119 ENDIF
7120
7121 IF (ASSOCIATED(this%dativarattr%i)) THEN
7122 DO i = 1, SIZE(this%dativar%d)
7123 this%dativar%d(i)%i = &
7124 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
7125 ENDDO
7126 ENDIF
7127
7128 IF (ASSOCIATED(this%dativarattr%b)) THEN
7129 DO i = 1, SIZE(this%dativar%d)
7130 this%dativar%d(i)%b = &
7131 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
7132 ENDDO
7133 ENDIF
7134
7135 IF (ASSOCIATED(this%dativarattr%c)) THEN
7136 DO i = 1, SIZE(this%dativar%d)
7137 this%dativar%d(i)%c = &
7138 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
7139 ENDDO
7140 ENDIF
7141ENDIF
7142! integer
7143IF (ASSOCIATED(this%dativar%i)) THEN
7144 IF (ASSOCIATED(this%dativarattr%r)) THEN
7145 DO i = 1, SIZE(this%dativar%i)
7146 this%dativar%i(i)%r = &
7147 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
7148 ENDDO
7149 ENDIF
7150
7151 IF (ASSOCIATED(this%dativarattr%d)) THEN
7152 DO i = 1, SIZE(this%dativar%i)
7153 this%dativar%i(i)%d = &
7154 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
7155 ENDDO
7156 ENDIF
7157
7158 IF (ASSOCIATED(this%dativarattr%i)) THEN
7159 DO i = 1, SIZE(this%dativar%i)
7160 this%dativar%i(i)%i = &
7161 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
7162 ENDDO
7163 ENDIF
7164
7165 IF (ASSOCIATED(this%dativarattr%b)) THEN
7166 DO i = 1, SIZE(this%dativar%i)
7167 this%dativar%i(i)%b = &
7168 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
7169 ENDDO
7170 ENDIF
7171
7172 IF (ASSOCIATED(this%dativarattr%c)) THEN
7173 DO i = 1, SIZE(this%dativar%i)
7174 this%dativar%i(i)%c = &
7175 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
7176 ENDDO
7177 ENDIF
7178ENDIF
7179! byte
7180IF (ASSOCIATED(this%dativar%b)) THEN
7181 IF (ASSOCIATED(this%dativarattr%r)) THEN
7182 DO i = 1, SIZE(this%dativar%b)
7183 this%dativar%b(i)%r = &
7184 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
7185 ENDDO
7186 ENDIF
7187
7188 IF (ASSOCIATED(this%dativarattr%d)) THEN
7189 DO i = 1, SIZE(this%dativar%b)
7190 this%dativar%b(i)%d = &
7191 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
7192 ENDDO
7193 ENDIF
7194
7195 IF (ASSOCIATED(this%dativarattr%i)) THEN
7196 DO i = 1, SIZE(this%dativar%b)
7197 this%dativar%b(i)%i = &
7198 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
7199 ENDDO
7200 ENDIF
7201
7202 IF (ASSOCIATED(this%dativarattr%b)) THEN
7203 DO i = 1, SIZE(this%dativar%b)
7204 this%dativar%b(i)%b = &
7205 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
7206 ENDDO
7207 ENDIF
7208
7209 IF (ASSOCIATED(this%dativarattr%c)) THEN
7210 DO i = 1, SIZE(this%dativar%b)
7211 this%dativar%b(i)%c = &
7212 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
7213 ENDDO
7214 ENDIF
7215ENDIF
7216! character
7217IF (ASSOCIATED(this%dativar%c)) THEN
7218 IF (ASSOCIATED(this%dativarattr%r)) THEN
7219 DO i = 1, SIZE(this%dativar%c)
7220 this%dativar%c(i)%r = &
7221 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
7222 ENDDO
7223 ENDIF
7224
7225 IF (ASSOCIATED(this%dativarattr%d)) THEN
7226 DO i = 1, SIZE(this%dativar%c)
7227 this%dativar%c(i)%d = &
7228 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
7229 ENDDO
7230 ENDIF
7231
7232 IF (ASSOCIATED(this%dativarattr%i)) THEN
7233 DO i = 1, SIZE(this%dativar%c)
7234 this%dativar%c(i)%i = &
7235 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
7236 ENDDO
7237 ENDIF
7238
7239 IF (ASSOCIATED(this%dativarattr%b)) THEN
7240 DO i = 1, SIZE(this%dativar%c)
7241 this%dativar%c(i)%b = &
7242 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
7243 ENDDO
7244 ENDIF
7245
7246 IF (ASSOCIATED(this%dativarattr%c)) THEN
7247 DO i = 1, SIZE(this%dativar%c)
7248 this%dativar%c(i)%c = &
7249 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
7250 ENDDO
7251 ENDIF
7252ENDIF
7253
7254END SUBROUTINE vol7d_set_attr_ind
7255
7256
7261SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
7262 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7263TYPE(vol7d),INTENT(INOUT) :: this
7264TYPE(vol7d),INTENT(INOUT) :: that
7265LOGICAL,INTENT(IN),OPTIONAL :: sort
7266LOGICAL,INTENT(in),OPTIONAL :: bestdata
7267LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
7268
7269TYPE(vol7d) :: v7d_clean
7270
7271
7272IF (.NOT.c_e(this)) THEN ! speedup
7273 this = that
7274 CALL init(v7d_clean)
7275 that = v7d_clean ! destroy that without deallocating
7276ELSE ! Append that to this and destroy that
7277 CALL vol7d_append(this, that, sort, bestdata, &
7278 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7279 CALL delete(that)
7280ENDIF
7281
7282END SUBROUTINE vol7d_merge
7283
7284
7313SUBROUTINE vol7d_append(this, that, sort, bestdata, &
7314 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
7315TYPE(vol7d),INTENT(INOUT) :: this
7316TYPE(vol7d),INTENT(IN) :: that
7317LOGICAL,INTENT(IN),OPTIONAL :: sort
7318! experimental, please do not use outside the library now, they force the use
7319! of a simplified mapping algorithm which is valid only whene the dimension
7320! content is the same in both volumes , or when one of them is empty
7321LOGICAL,INTENT(in),OPTIONAL :: bestdata
7322LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
7323
7324
7325TYPE(vol7d) :: v7dtmp
7326LOGICAL :: lsort, lbestdata
7327INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
7328 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
7329
7330IF (.NOT.c_e(that)) RETURN ! speedup, nothing to do
7331IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
7332IF (.NOT.c_e(this)) THEN ! this case is like a vol7d_copy, more efficient to copy?
7333 CALL vol7d_copy(that, this, sort=sort)
7334 RETURN
7335ENDIF
7336
7337IF (this%time_definition /= that%time_definition) THEN
7338 CALL l4f_log(l4f_fatal, &
7339 'in vol7d_append, cannot append volumes with different &
7340 &time definition')
7341 CALL raise_fatal_error()
7342ENDIF
7343
7344! Completo l'allocazione per avere volumi a norma
7345CALL vol7d_alloc_vol(this)
7346
7347CALL init(v7dtmp, time_definition=this%time_definition)
7348CALL optio(sort, lsort)
7349CALL optio(bestdata, lbestdata)
7350
7351! Calcolo le mappature tra volumi vecchi e volume nuovo
7352! I puntatori remap* vengono tutti o allocati o nullificati
7353IF (optio_log(ltimesimple)) THEN
7354 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
7355 lsort, remapt1, remapt2)
7356ELSE
7357 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
7358 lsort, remapt1, remapt2)
7359ENDIF
7360IF (optio_log(ltimerangesimple)) THEN
7361 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
7362 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7363ELSE
7364 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
7365 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7366ENDIF
7367IF (optio_log(llevelsimple)) THEN
7368 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
7369 lsort, remapl1, remapl2)
7370ELSE
7371 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
7372 lsort, remapl1, remapl2)
7373ENDIF
7374IF (optio_log(lanasimple)) THEN
7375 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7376 .false., remapa1, remapa2)
7377ELSE
7378 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7379 .false., remapa1, remapa2)
7380ENDIF
7381IF (optio_log(lnetworksimple)) THEN
7382 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
7383 .false., remapn1, remapn2)
7384ELSE
7385 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
7386 .false., remapn1, remapn2)
7387ENDIF
7388
7389! Faccio la fusione fisica dei volumi
7390CALL vol7d_merge_finalr(this, that, v7dtmp, &
7391 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7392 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7393CALL vol7d_merge_finald(this, that, v7dtmp, &
7394 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7395 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7396CALL vol7d_merge_finali(this, that, v7dtmp, &
7397 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7398 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7399CALL vol7d_merge_finalb(this, that, v7dtmp, &
7400 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7401 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7402CALL vol7d_merge_finalc(this, that, v7dtmp, &
7403 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7404 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7405
7406! Dealloco i vettori di rimappatura
7407IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
7408IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
7409IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
7410IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
7411IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
7412IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
7413IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
7414IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
7415IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
7416IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
7417
7418! Distruggo il vecchio volume e assegno il nuovo a this
7419CALL delete(this)
7420this = v7dtmp
7421! Ricreo gli indici var-attr
7422CALL vol7d_set_attr_ind(this)
7423
7424END SUBROUTINE vol7d_append
7425
7426
7459SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
7460 lsort_time, lsort_timerange, lsort_level, &
7461 ltime, ltimerange, llevel, lana, lnetwork, &
7462 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7463 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7464 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7465 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7466 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7467 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7468TYPE(vol7d),INTENT(IN) :: this
7469TYPE(vol7d),INTENT(INOUT) :: that
7470LOGICAL,INTENT(IN),OPTIONAL :: sort
7471LOGICAL,INTENT(IN),OPTIONAL :: unique
7472LOGICAL,INTENT(IN),OPTIONAL :: miss
7473LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
7474LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
7475LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
7483LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7485LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
7487LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
7489LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
7491LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
7493LOGICAL,INTENT(in),OPTIONAL :: &
7494 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7495 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7496 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7497 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7498 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7499 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7500
7501LOGICAL :: lsort, lunique, lmiss
7502INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
7503
7504CALL init(that)
7505IF (.NOT.c_e(this)) RETURN ! speedup, nothing to do
7506IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
7507
7508CALL optio(sort, lsort)
7509CALL optio(unique, lunique)
7510CALL optio(miss, lmiss)
7511
7512! Calcolo le mappature tra volume vecchio e volume nuovo
7513! I puntatori remap* vengono tutti o allocati o nullificati
7514CALL vol7d_remap1_datetime(this%time, that%time, &
7515 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
7516CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
7517 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
7518CALL vol7d_remap1_vol7d_level(this%level, that%level, &
7519 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
7520CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
7521 lsort, lunique, lmiss, remapa, lana)
7522CALL vol7d_remap1_vol7d_network(this%network, that%network, &
7523 lsort, lunique, lmiss, remapn, lnetwork)
7524
7525! lanavari, lanavarb, lanavarc, &
7526! lanaattri, lanaattrb, lanaattrc, &
7527! lanavarattri, lanavarattrb, lanavarattrc, &
7528! ldativari, ldativarb, ldativarc, &
7529! ldatiattri, ldatiattrb, ldatiattrc, &
7530! ldativarattri, ldativarattrb, ldativarattrc
7531! Faccio la riforma fisica dei volumi
7532CALL vol7d_reform_finalr(this, that, &
7533 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7534 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
7535CALL vol7d_reform_finald(this, that, &
7536 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7537 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
7538CALL vol7d_reform_finali(this, that, &
7539 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7540 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
7541CALL vol7d_reform_finalb(this, that, &
7542 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7543 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
7544CALL vol7d_reform_finalc(this, that, &
7545 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7546 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
7547
7548! Dealloco i vettori di rimappatura
7549IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
7550IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
7551IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
7552IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
7553IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
7554
7555! Ricreo gli indici var-attr
7556CALL vol7d_set_attr_ind(that)
7557that%time_definition = this%time_definition
7558
7559END SUBROUTINE vol7d_copy
7560
7561
7572SUBROUTINE vol7d_reform(this, sort, unique, miss, &
7573 lsort_time, lsort_timerange, lsort_level, &
7574 ltime, ltimerange, llevel, lana, lnetwork, &
7575 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7576 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7577 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7578 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7579 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7580 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
7581 ,purgeana)
7582TYPE(vol7d),INTENT(INOUT) :: this
7583LOGICAL,INTENT(IN),OPTIONAL :: sort
7584LOGICAL,INTENT(IN),OPTIONAL :: unique
7585LOGICAL,INTENT(IN),OPTIONAL :: miss
7586LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
7587LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
7588LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
7596LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7597LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
7598LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
7599LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
7600LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
7602LOGICAL,INTENT(in),OPTIONAL :: &
7603 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7604 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7605 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7606 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7607 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7608 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7609LOGICAL,INTENT(IN),OPTIONAL :: purgeana
7610
7611TYPE(vol7d) :: v7dtmp
7612logical,allocatable :: llana(:)
7613integer :: i
7614
7615CALL vol7d_copy(this, v7dtmp, sort, unique, miss, &
7616 lsort_time, lsort_timerange, lsort_level, &
7617 ltime, ltimerange, llevel, lana, lnetwork, &
7618 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7619 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7620 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7621 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7622 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7623 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7624
7625! destroy old volume
7626CALL delete(this)
7627
7628if (optio_log(purgeana)) then
7629 allocate(llana(size(v7dtmp%ana)))
7630 llana =.false.
7631 do i =1,size(v7dtmp%ana)
7632 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
7633 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
7634 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
7635 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
7636 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
7637 end do
7638 CALL vol7d_copy(v7dtmp, this,lana=llana)
7639 CALL delete(v7dtmp)
7640 deallocate(llana)
7641else
7642 this=v7dtmp
7643end if
7644
7645END SUBROUTINE vol7d_reform
7646
7647
7655SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
7656TYPE(vol7d),INTENT(INOUT) :: this
7657LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
7658LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
7659LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
7660
7661INTEGER :: i
7662LOGICAL :: to_be_sorted
7663
7664to_be_sorted = .false.
7665CALL vol7d_alloc_vol(this) ! usual safety check
7666
7667IF (optio_log(lsort_time)) THEN
7668 DO i = 2, SIZE(this%time)
7669 IF (this%time(i) < this%time(i-1)) THEN
7670 to_be_sorted = .true.
7671 EXIT
7672 ENDIF
7673 ENDDO
7674ENDIF
7675IF (optio_log(lsort_timerange)) THEN
7676 DO i = 2, SIZE(this%timerange)
7677 IF (this%timerange(i) < this%timerange(i-1)) THEN
7678 to_be_sorted = .true.
7679 EXIT
7680 ENDIF
7681 ENDDO
7682ENDIF
7683IF (optio_log(lsort_level)) THEN
7684 DO i = 2, SIZE(this%level)
7685 IF (this%level(i) < this%level(i-1)) THEN
7686 to_be_sorted = .true.
7687 EXIT
7688 ENDIF
7689 ENDDO
7690ENDIF
7691
7692IF (to_be_sorted) CALL vol7d_reform(this, &
7693 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
7694
7695END SUBROUTINE vol7d_smart_sort
7696
7704SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
7705TYPE(vol7d),INTENT(inout) :: this
7706CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
7707CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
7708TYPE(vol7d_network),OPTIONAL :: nl(:)
7709TYPE(datetime),INTENT(in),OPTIONAL :: s_d
7710TYPE(datetime),INTENT(in),OPTIONAL :: e_d
7711
7712INTEGER :: i
7713
7714IF (PRESENT(avl)) THEN
7715 IF (SIZE(avl) > 0) THEN
7716
7717 IF (ASSOCIATED(this%anavar%r)) THEN
7718 DO i = 1, SIZE(this%anavar%r)
7719 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
7720 ENDDO
7721 ENDIF
7722
7723 IF (ASSOCIATED(this%anavar%i)) THEN
7724 DO i = 1, SIZE(this%anavar%i)
7725 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
7726 ENDDO
7727 ENDIF
7728
7729 IF (ASSOCIATED(this%anavar%b)) THEN
7730 DO i = 1, SIZE(this%anavar%b)
7731 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
7732 ENDDO
7733 ENDIF
7734
7735 IF (ASSOCIATED(this%anavar%d)) THEN
7736 DO i = 1, SIZE(this%anavar%d)
7737 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
7738 ENDDO
7739 ENDIF
7740
7741 IF (ASSOCIATED(this%anavar%c)) THEN
7742 DO i = 1, SIZE(this%anavar%c)
7743 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
7744 ENDDO
7745 ENDIF
7746
7747 ENDIF
7748ENDIF
7749
7750
7751IF (PRESENT(vl)) THEN
7752 IF (size(vl) > 0) THEN
7753 IF (ASSOCIATED(this%dativar%r)) THEN
7754 DO i = 1, SIZE(this%dativar%r)
7755 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
7756 ENDDO
7757 ENDIF
7758
7759 IF (ASSOCIATED(this%dativar%i)) THEN
7760 DO i = 1, SIZE(this%dativar%i)
7761 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
7762 ENDDO
7763 ENDIF
7764
7765 IF (ASSOCIATED(this%dativar%b)) THEN
7766 DO i = 1, SIZE(this%dativar%b)
7767 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
7768 ENDDO
7769 ENDIF
7770
7771 IF (ASSOCIATED(this%dativar%d)) THEN
7772 DO i = 1, SIZE(this%dativar%d)
7773 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
7774 ENDDO
7775 ENDIF
7776
7777 IF (ASSOCIATED(this%dativar%c)) THEN
7778 DO i = 1, SIZE(this%dativar%c)
7779 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7780 ENDDO
7781 ENDIF
7782
7783 IF (ASSOCIATED(this%dativar%c)) THEN
7784 DO i = 1, SIZE(this%dativar%c)
7785 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7786 ENDDO
7787 ENDIF
7788
7789 ENDIF
7790ENDIF
7791
7792IF (PRESENT(nl)) THEN
7793 IF (SIZE(nl) > 0) THEN
7794 DO i = 1, SIZE(this%network)
7795 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
7796 ENDDO
7797 ENDIF
7798ENDIF
7799
7800IF (PRESENT(s_d)) THEN
7801 IF (c_e(s_d)) THEN
7802 WHERE (this%time < s_d)
7803 this%time = datetime_miss
7804 END WHERE
7805 ENDIF
7806ENDIF
7807
7808IF (PRESENT(e_d)) THEN
7809 IF (c_e(e_d)) THEN
7810 WHERE (this%time > e_d)
7811 this%time = datetime_miss
7812 END WHERE
7813 ENDIF
7814ENDIF
7815
7816CALL vol7d_reform(this, miss=.true.)
7817
7818END SUBROUTINE vol7d_filter
7819
7820
7827SUBROUTINE vol7d_convr(this, that, anaconv)
7828TYPE(vol7d),INTENT(IN) :: this
7829TYPE(vol7d),INTENT(INOUT) :: that
7830LOGICAL,OPTIONAL,INTENT(in) :: anaconv
7831INTEGER :: i
7832LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
7833TYPE(vol7d) :: v7d_tmp
7834
7835IF (optio_log(anaconv)) THEN
7836 acp=fv
7837 acn=tv
7838ELSE
7839 acp=tv
7840 acn=fv
7841ENDIF
7842
7843! Volume con solo i dati reali e tutti gli attributi
7844! l'anagrafica e` copiata interamente se necessario
7845CALL vol7d_copy(this, that, &
7846 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7847 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7848
7849! Volume solo di dati double
7850CALL vol7d_copy(this, v7d_tmp, &
7851 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7852 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7853 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7854 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7855 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7856 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7857
7858! converto a dati reali
7859IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7860
7861 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7862! alloco i dati reali e vi trasferisco i double
7863 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7864 SIZE(v7d_tmp%volanad, 3)))
7865 DO i = 1, SIZE(v7d_tmp%anavar%d)
7866 v7d_tmp%volanar(:,i,:) = &
7867 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7868 ENDDO
7869 DEALLOCATE(v7d_tmp%volanad)
7870! trasferisco le variabili
7871 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7872 NULLIFY(v7d_tmp%anavar%d)
7873 ENDIF
7874
7875 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7876! alloco i dati reali e vi trasferisco i double
7877 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7878 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7879 SIZE(v7d_tmp%voldatid, 6)))
7880 DO i = 1, SIZE(v7d_tmp%dativar%d)
7881 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7882 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7883 ENDDO
7884 DEALLOCATE(v7d_tmp%voldatid)
7885! trasferisco le variabili
7886 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7887 NULLIFY(v7d_tmp%dativar%d)
7888 ENDIF
7889
7890! fondo con il volume definitivo
7891 CALL vol7d_merge(that, v7d_tmp)
7892ELSE
7893 CALL delete(v7d_tmp)
7894ENDIF
7895
7896
7897! Volume solo di dati interi
7898CALL vol7d_copy(this, v7d_tmp, &
7899 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7900 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7901 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7902 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7903 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7904 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7905
7906! converto a dati reali
7907IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7908
7909 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7910! alloco i dati reali e vi trasferisco gli interi
7911 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7912 SIZE(v7d_tmp%volanai, 3)))
7913 DO i = 1, SIZE(v7d_tmp%anavar%i)
7914 v7d_tmp%volanar(:,i,:) = &
7915 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7916 ENDDO
7917 DEALLOCATE(v7d_tmp%volanai)
7918! trasferisco le variabili
7919 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7920 NULLIFY(v7d_tmp%anavar%i)
7921 ENDIF
7922
7923 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7924! alloco i dati reali e vi trasferisco gli interi
7925 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7926 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7927 SIZE(v7d_tmp%voldatii, 6)))
7928 DO i = 1, SIZE(v7d_tmp%dativar%i)
7929 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7930 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7931 ENDDO
7932 DEALLOCATE(v7d_tmp%voldatii)
7933! trasferisco le variabili
7934 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7935 NULLIFY(v7d_tmp%dativar%i)
7936 ENDIF
7937
7938! fondo con il volume definitivo
7939 CALL vol7d_merge(that, v7d_tmp)
7940ELSE
7941 CALL delete(v7d_tmp)
7942ENDIF
7943
7944
7945! Volume solo di dati byte
7946CALL vol7d_copy(this, v7d_tmp, &
7947 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7948 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7949 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7950 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7951 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7952 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7953
7954! converto a dati reali
7955IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7956
7957 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7958! alloco i dati reali e vi trasferisco i byte
7959 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7960 SIZE(v7d_tmp%volanab, 3)))
7961 DO i = 1, SIZE(v7d_tmp%anavar%b)
7962 v7d_tmp%volanar(:,i,:) = &
7963 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7964 ENDDO
7965 DEALLOCATE(v7d_tmp%volanab)
7966! trasferisco le variabili
7967 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7968 NULLIFY(v7d_tmp%anavar%b)
7969 ENDIF
7970
7971 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7972! alloco i dati reali e vi trasferisco i byte
7973 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7974 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7975 SIZE(v7d_tmp%voldatib, 6)))
7976 DO i = 1, SIZE(v7d_tmp%dativar%b)
7977 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7978 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7979 ENDDO
7980 DEALLOCATE(v7d_tmp%voldatib)
7981! trasferisco le variabili
7982 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7983 NULLIFY(v7d_tmp%dativar%b)
7984 ENDIF
7985
7986! fondo con il volume definitivo
7987 CALL vol7d_merge(that, v7d_tmp)
7988ELSE
7989 CALL delete(v7d_tmp)
7990ENDIF
7991
7992
7993! Volume solo di dati character
7994CALL vol7d_copy(this, v7d_tmp, &
7995 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7996 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7997 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7998 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7999 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8000 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8001
8002! converto a dati reali
8003IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
8004
8005 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
8006! alloco i dati reali e vi trasferisco i character
8007 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
8008 SIZE(v7d_tmp%volanac, 3)))
8009 DO i = 1, SIZE(v7d_tmp%anavar%c)
8010 v7d_tmp%volanar(:,i,:) = &
8011 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
8012 ENDDO
8013 DEALLOCATE(v7d_tmp%volanac)
8014! trasferisco le variabili
8015 v7d_tmp%anavar%r => v7d_tmp%anavar%c
8016 NULLIFY(v7d_tmp%anavar%c)
8017 ENDIF
8018
8019 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
8020! alloco i dati reali e vi trasferisco i character
8021 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
8022 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
8023 SIZE(v7d_tmp%voldatic, 6)))
8024 DO i = 1, SIZE(v7d_tmp%dativar%c)
8025 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8026 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
8027 ENDDO
8028 DEALLOCATE(v7d_tmp%voldatic)
8029! trasferisco le variabili
8030 v7d_tmp%dativar%r => v7d_tmp%dativar%c
8031 NULLIFY(v7d_tmp%dativar%c)
8032 ENDIF
8033
8034! fondo con il volume definitivo
8035 CALL vol7d_merge(that, v7d_tmp)
8036ELSE
8037 CALL delete(v7d_tmp)
8038ENDIF
8039
8040END SUBROUTINE vol7d_convr
8041
8042
8046SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
8047TYPE(vol7d),INTENT(IN) :: this
8048TYPE(vol7d),INTENT(OUT) :: that
8049logical , optional, intent(in) :: data_only
8050logical , optional, intent(in) :: ana
8051logical :: ldata_only,lana
8052
8053IF (PRESENT(data_only)) THEN
8054 ldata_only = data_only
8055ELSE
8056 ldata_only = .false.
8057ENDIF
8058
8059IF (PRESENT(ana)) THEN
8060 lana = ana
8061ELSE
8062 lana = .false.
8063ENDIF
8064
8065
8066#undef VOL7D_POLY_ARRAY
8067#define VOL7D_POLY_ARRAY voldati
8068#include "vol7d_class_diff.F90"
8069#undef VOL7D_POLY_ARRAY
8070#define VOL7D_POLY_ARRAY voldatiattr
8071#include "vol7d_class_diff.F90"
8072#undef VOL7D_POLY_ARRAY
8073
8074if ( .not. ldata_only) then
8075
8076#define VOL7D_POLY_ARRAY volana
8077#include "vol7d_class_diff.F90"
8078#undef VOL7D_POLY_ARRAY
8079#define VOL7D_POLY_ARRAY volanaattr
8080#include "vol7d_class_diff.F90"
8081#undef VOL7D_POLY_ARRAY
8082
8083 if(lana)then
8084 where ( this%ana == that%ana )
8085 that%ana = vol7d_ana_miss
8086 end where
8087 end if
8088
8089end if
8090
8091
8092
8093END SUBROUTINE vol7d_diff_only
8094
8095
8096
8097! Creo le routine da ripetere per i vari tipi di dati di v7d
8098! tramite un template e il preprocessore
8099#undef VOL7D_POLY_TYPE
8100#undef VOL7D_POLY_TYPES
8101#define VOL7D_POLY_TYPE REAL
8102#define VOL7D_POLY_TYPES r
8103#include "vol7d_class_type_templ.F90"
8104#undef VOL7D_POLY_TYPE
8105#undef VOL7D_POLY_TYPES
8106#define VOL7D_POLY_TYPE DOUBLE PRECISION
8107#define VOL7D_POLY_TYPES d
8108#include "vol7d_class_type_templ.F90"
8109#undef VOL7D_POLY_TYPE
8110#undef VOL7D_POLY_TYPES
8111#define VOL7D_POLY_TYPE INTEGER
8112#define VOL7D_POLY_TYPES i
8113#include "vol7d_class_type_templ.F90"
8114#undef VOL7D_POLY_TYPE
8115#undef VOL7D_POLY_TYPES
8116#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
8117#define VOL7D_POLY_TYPES b
8118#include "vol7d_class_type_templ.F90"
8119#undef VOL7D_POLY_TYPE
8120#undef VOL7D_POLY_TYPES
8121#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
8122#define VOL7D_POLY_TYPES c
8123#include "vol7d_class_type_templ.F90"
8124
8125! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
8126! tramite un template e il preprocessore
8127#define VOL7D_SORT
8128#undef VOL7D_NO_ZERO_ALLOC
8129#undef VOL7D_POLY_TYPE
8130#define VOL7D_POLY_TYPE datetime
8131#include "vol7d_class_desc_templ.F90"
8132#undef VOL7D_POLY_TYPE
8133#define VOL7D_POLY_TYPE vol7d_timerange
8134#include "vol7d_class_desc_templ.F90"
8135#undef VOL7D_POLY_TYPE
8136#define VOL7D_POLY_TYPE vol7d_level
8137#include "vol7d_class_desc_templ.F90"
8138#undef VOL7D_SORT
8139#undef VOL7D_POLY_TYPE
8140#define VOL7D_POLY_TYPE vol7d_network
8141#include "vol7d_class_desc_templ.F90"
8142#undef VOL7D_POLY_TYPE
8143#define VOL7D_POLY_TYPE vol7d_ana
8144#include "vol7d_class_desc_templ.F90"
8145#define VOL7D_NO_ZERO_ALLOC
8146#undef VOL7D_POLY_TYPE
8147#define VOL7D_POLY_TYPE vol7d_var
8148#include "vol7d_class_desc_templ.F90"
8149
8159subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
8160
8161TYPE(vol7d),INTENT(IN) :: this
8162integer,optional,intent(inout) :: unit
8163character(len=*),intent(in),optional :: filename
8164character(len=*),intent(out),optional :: filename_auto
8165character(len=*),INTENT(IN),optional :: description
8166
8167integer :: lunit
8168character(len=254) :: ldescription,arg,lfilename
8169integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8170 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8171 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8172 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8173 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8174 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8175 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8176!integer :: im,id,iy
8177integer :: tarray(8)
8178logical :: opened,exist
8179
8180 nana=0
8181 ntime=0
8182 ntimerange=0
8183 nlevel=0
8184 nnetwork=0
8185 ndativarr=0
8186 ndativari=0
8187 ndativarb=0
8188 ndativard=0
8189 ndativarc=0
8190 ndatiattrr=0
8191 ndatiattri=0
8192 ndatiattrb=0
8193 ndatiattrd=0
8194 ndatiattrc=0
8195 ndativarattrr=0
8196 ndativarattri=0
8197 ndativarattrb=0
8198 ndativarattrd=0
8199 ndativarattrc=0
8200 nanavarr=0
8201 nanavari=0
8202 nanavarb=0
8203 nanavard=0
8204 nanavarc=0
8205 nanaattrr=0
8206 nanaattri=0
8207 nanaattrb=0
8208 nanaattrd=0
8209 nanaattrc=0
8210 nanavarattrr=0
8211 nanavarattri=0
8212 nanavarattrb=0
8213 nanavarattrd=0
8214 nanavarattrc=0
8215
8216
8217!call idate(im,id,iy)
8218call date_and_time(values=tarray)
8219call getarg(0,arg)
8220
8221if (present(description))then
8222 ldescription=description
8223else
8224 ldescription="Vol7d generated by: "//trim(arg)
8225end if
8226
8227if (.not. present(unit))then
8228 lunit=getunit()
8229else
8230 if (unit==0)then
8231 lunit=getunit()
8232 unit=lunit
8233 else
8234 lunit=unit
8235 end if
8236end if
8237
8238lfilename=trim(arg)//".v7d"
8239if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
8240
8241if (present(filename))then
8242 if (filename /= "")then
8243 lfilename=filename
8244 end if
8245end if
8246
8247if (present(filename_auto))filename_auto=lfilename
8248
8249
8250inquire(unit=lunit,opened=opened)
8251if (.not. opened) then
8252! inquire(file=lfilename, EXIST=exist)
8253! IF (exist) THEN
8254! CALL l4f_log(L4F_FATAL, &
8255! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
8256! CALL raise_fatal_error()
8257! ENDIF
8258 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
8259 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8260end if
8261
8262if (associated(this%ana)) nana=size(this%ana)
8263if (associated(this%time)) ntime=size(this%time)
8264if (associated(this%timerange)) ntimerange=size(this%timerange)
8265if (associated(this%level)) nlevel=size(this%level)
8266if (associated(this%network)) nnetwork=size(this%network)
8267
8268if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
8269if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
8270if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
8271if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
8272if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
8273
8274if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
8275if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
8276if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
8277if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
8278if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
8279
8280if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
8281if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
8282if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
8283if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
8284if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
8285
8286if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
8287if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
8288if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
8289if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
8290if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
8291
8292if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
8293if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
8294if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
8295if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
8296if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
8297
8298if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
8299if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
8300if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
8301if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
8302if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
8303
8304write(unit=lunit)ldescription
8305write(unit=lunit)tarray
8306
8307write(unit=lunit)&
8308 nana, ntime, ntimerange, nlevel, nnetwork, &
8309 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8310 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8311 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8312 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8313 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8314 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8315 this%time_definition
8316
8317
8318!write(unit=lunit)this
8319
8320
8321!! prime 5 dimensioni
8322if (associated(this%ana)) call write_unit(this%ana, lunit)
8323if (associated(this%time)) call write_unit(this%time, lunit)
8324if (associated(this%level)) write(unit=lunit)this%level
8325if (associated(this%timerange)) write(unit=lunit)this%timerange
8326if (associated(this%network)) write(unit=lunit)this%network
8327
8328 !! 6a dimensione: variabile dell'anagrafica e dei dati
8329 !! con relativi attributi e in 5 tipi diversi
8330
8331if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
8332if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
8333if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
8334if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
8335if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
8336
8337if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
8338if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
8339if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
8340if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
8341if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
8342
8343if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
8344if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
8345if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
8346if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
8347if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
8348
8349if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
8350if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
8351if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
8352if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
8353if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
8354
8355if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
8356if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
8357if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
8358if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
8359if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
8360
8361if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
8362if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
8363if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
8364if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
8365if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
8366
8367!! Volumi di valori e attributi per anagrafica e dati
8368
8369if (associated(this%volanar)) write(unit=lunit)this%volanar
8370if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
8371if (associated(this%voldatir)) write(unit=lunit)this%voldatir
8372if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
8373
8374if (associated(this%volanai)) write(unit=lunit)this%volanai
8375if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
8376if (associated(this%voldatii)) write(unit=lunit)this%voldatii
8377if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
8378
8379if (associated(this%volanab)) write(unit=lunit)this%volanab
8380if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
8381if (associated(this%voldatib)) write(unit=lunit)this%voldatib
8382if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
8383
8384if (associated(this%volanad)) write(unit=lunit)this%volanad
8385if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
8386if (associated(this%voldatid)) write(unit=lunit)this%voldatid
8387if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
8388
8389if (associated(this%volanac)) write(unit=lunit)this%volanac
8390if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
8391if (associated(this%voldatic)) write(unit=lunit)this%voldatic
8392if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
8393
8394if (.not. present(unit)) close(unit=lunit)
8395
8396end subroutine vol7d_write_on_file
8397
8398
8405
8406
8407subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
8408
8409TYPE(vol7d),INTENT(OUT) :: this
8410integer,intent(inout),optional :: unit
8411character(len=*),INTENT(in),optional :: filename
8412character(len=*),intent(out),optional :: filename_auto
8413character(len=*),INTENT(out),optional :: description
8414integer,intent(out),optional :: tarray(8)
8415
8416
8417integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8418 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8419 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8420 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8421 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8422 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8423 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8424
8425character(len=254) :: ldescription,lfilename,arg
8426integer :: ltarray(8),lunit,ios
8427logical :: opened,exist
8428
8429
8430call getarg(0,arg)
8431
8432if (.not. present(unit))then
8433 lunit=getunit()
8434else
8435 if (unit==0)then
8436 lunit=getunit()
8437 unit=lunit
8438 else
8439 lunit=unit
8440 end if
8441end if
8442
8443lfilename=trim(arg)//".v7d"
8444if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
8445
8446if (present(filename))then
8447 if (filename /= "")then
8448 lfilename=filename
8449 end if
8450end if
8451
8452if (present(filename_auto))filename_auto=lfilename
8453
8454
8455inquire(unit=lunit,opened=opened)
8456IF (.NOT. opened) THEN
8457 inquire(file=lfilename,exist=exist)
8458 IF (.NOT.exist) THEN
8459 CALL l4f_log(l4f_fatal, &
8460 'in vol7d_read_from_file, file does not exists, cannot open')
8461 CALL raise_fatal_error()
8462 ENDIF
8463 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
8464 status='OLD', action='READ')
8465 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8466end if
8467
8468
8469call init(this)
8470read(unit=lunit,iostat=ios)ldescription
8471
8472if (ios < 0) then ! A negative value indicates that the End of File or End of Record
8473 call vol7d_alloc (this)
8474 call vol7d_alloc_vol (this)
8475 if (present(description))description=ldescription
8476 if (present(tarray))tarray=ltarray
8477 if (.not. present(unit)) close(unit=lunit)
8478end if
8479
8480read(unit=lunit)ltarray
8481
8482CALL l4f_log(l4f_info, 'Reading vol7d from file')
8483CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
8484CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
8485 trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
8486
8487if (present(description))description=ldescription
8488if (present(tarray))tarray=ltarray
8489
8490read(unit=lunit)&
8491 nana, ntime, ntimerange, nlevel, nnetwork, &
8492 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8493 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8494 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8495 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8496 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8497 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8498 this%time_definition
8499
8500call vol7d_alloc (this, &
8501 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
8502 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
8503 ndativard=ndativard, ndativarc=ndativarc,&
8504 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
8505 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
8506 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
8507 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
8508 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
8509 nanavard=nanavard, nanavarc=nanavarc,&
8510 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
8511 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
8512 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
8513 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
8514
8515
8516if (associated(this%ana)) call read_unit(this%ana, lunit)
8517if (associated(this%time)) call read_unit(this%time, lunit)
8518if (associated(this%level)) read(unit=lunit)this%level
8519if (associated(this%timerange)) read(unit=lunit)this%timerange
8520if (associated(this%network)) read(unit=lunit)this%network
8521
8522if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
8523if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
8524if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
8525if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
8526if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
8527
8528if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
8529if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
8530if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
8531if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
8532if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
8533
8534if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
8535if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
8536if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
8537if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
8538if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
8539
8540if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
8541if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
8542if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
8543if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
8544if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
8545
8546if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
8547if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
8548if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
8549if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
8550if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
8551
8552if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
8553if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
8554if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
8555if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
8556if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
8557
8558call vol7d_alloc_vol (this)
8559
8560!! Volumi di valori e attributi per anagrafica e dati
8561
8562if (associated(this%volanar)) read(unit=lunit)this%volanar
8563if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
8564if (associated(this%voldatir)) read(unit=lunit)this%voldatir
8565if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
8566
8567if (associated(this%volanai)) read(unit=lunit)this%volanai
8568if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
8569if (associated(this%voldatii)) read(unit=lunit)this%voldatii
8570if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
8571
8572if (associated(this%volanab)) read(unit=lunit)this%volanab
8573if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
8574if (associated(this%voldatib)) read(unit=lunit)this%voldatib
8575if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
8576
8577if (associated(this%volanad)) read(unit=lunit)this%volanad
8578if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
8579if (associated(this%voldatid)) read(unit=lunit)this%voldatid
8580if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
8581
8582if (associated(this%volanac)) read(unit=lunit)this%volanac
8583if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
8584if (associated(this%voldatic)) read(unit=lunit)this%voldatic
8585if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
8586
8587if (.not. present(unit)) close(unit=lunit)
8588
8589end subroutine vol7d_read_from_file
8590
8591
8592! to double precision
8593elemental doubleprecision function doubledatd(voldat,var)
8594doubleprecision,intent(in) :: voldat
8595type(vol7d_var),intent(in) :: var
8596
8597doubledatd=voldat
8598
8599end function doubledatd
8600
8601
8602elemental doubleprecision function doubledatr(voldat,var)
8603real,intent(in) :: voldat
8604type(vol7d_var),intent(in) :: var
8605
8606if (c_e(voldat))then
8607 doubledatr=dble(voldat)
8608else
8609 doubledatr=dmiss
8610end if
8611
8612end function doubledatr
8613
8614
8615elemental doubleprecision function doubledati(voldat,var)
8616integer,intent(in) :: voldat
8617type(vol7d_var),intent(in) :: var
8618
8619if (c_e(voldat)) then
8620 if (c_e(var%scalefactor))then
8621 doubledati=dble(voldat)/10.d0**var%scalefactor
8622 else
8623 doubledati=dble(voldat)
8624 endif
8625else
8626 doubledati=dmiss
8627end if
8628
8629end function doubledati
8630
8631
8632elemental doubleprecision function doubledatb(voldat,var)
8633integer(kind=int_b),intent(in) :: voldat
8634type(vol7d_var),intent(in) :: var
8635
8636if (c_e(voldat)) then
8637 if (c_e(var%scalefactor))then
8638 doubledatb=dble(voldat)/10.d0**var%scalefactor
8639 else
8640 doubledatb=dble(voldat)
8641 endif
8642else
8643 doubledatb=dmiss
8644end if
8645
8646end function doubledatb
8647
8648
8649elemental doubleprecision function doubledatc(voldat,var)
8650CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8651type(vol7d_var),intent(in) :: var
8652
8653doubledatc = c2d(voldat)
8654if (c_e(doubledatc) .and. c_e(var%scalefactor))then
8655 doubledatc=doubledatc/10.d0**var%scalefactor
8656end if
8657
8658end function doubledatc
8659
8660
8661! to integer
8662elemental integer function integerdatd(voldat,var)
8663doubleprecision,intent(in) :: voldat
8664type(vol7d_var),intent(in) :: var
8665
8666if (c_e(voldat))then
8667 if (c_e(var%scalefactor)) then
8668 integerdatd=nint(voldat*10d0**var%scalefactor)
8669 else
8670 integerdatd=nint(voldat)
8671 endif
8672else
8673 integerdatd=imiss
8674end if
8675
8676end function integerdatd
8677
8678
8679elemental integer function integerdatr(voldat,var)
8680real,intent(in) :: voldat
8681type(vol7d_var),intent(in) :: var
8682
8683if (c_e(voldat))then
8684 if (c_e(var%scalefactor)) then
8685 integerdatr=nint(voldat*10d0**var%scalefactor)
8686 else
8687 integerdatr=nint(voldat)
8688 endif
8689else
8690 integerdatr=imiss
8691end if
8692
8693end function integerdatr
8694
8695
8696elemental integer function integerdati(voldat,var)
8697integer,intent(in) :: voldat
8698type(vol7d_var),intent(in) :: var
8699
8700integerdati=voldat
8701
8702end function integerdati
8703
8704
8705elemental integer function integerdatb(voldat,var)
8706integer(kind=int_b),intent(in) :: voldat
8707type(vol7d_var),intent(in) :: var
8708
8709if (c_e(voldat))then
8710 integerdatb=voldat
8711else
8712 integerdatb=imiss
8713end if
8714
8715end function integerdatb
8716
8717
8718elemental integer function integerdatc(voldat,var)
8719CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8720type(vol7d_var),intent(in) :: var
8721
8722integerdatc=c2i(voldat)
8723
8724end function integerdatc
8725
8726
8727! to real
8728elemental real function realdatd(voldat,var)
8729doubleprecision,intent(in) :: voldat
8730type(vol7d_var),intent(in) :: var
8731
8732if (c_e(voldat))then
8733 realdatd=real(voldat)
8734else
8735 realdatd=rmiss
8736end if
8737
8738end function realdatd
8739
8740
8741elemental real function realdatr(voldat,var)
8742real,intent(in) :: voldat
8743type(vol7d_var),intent(in) :: var
8744
8745realdatr=voldat
8746
8747end function realdatr
8748
8749
8750elemental real function realdati(voldat,var)
8751integer,intent(in) :: voldat
8752type(vol7d_var),intent(in) :: var
8753
8754if (c_e(voldat)) then
8755 if (c_e(var%scalefactor))then
8756 realdati=float(voldat)/10.**var%scalefactor
8757 else
8758 realdati=float(voldat)
8759 endif
8760else
8761 realdati=rmiss
8762end if
8763
8764end function realdati
8765
8766
8767elemental real function realdatb(voldat,var)
8768integer(kind=int_b),intent(in) :: voldat
8769type(vol7d_var),intent(in) :: var
8770
8771if (c_e(voldat)) then
8772 if (c_e(var%scalefactor))then
8773 realdatb=float(voldat)/10**var%scalefactor
8774 else
8775 realdatb=float(voldat)
8776 endif
8777else
8778 realdatb=rmiss
8779end if
8780
8781end function realdatb
8782
8783
8784elemental real function realdatc(voldat,var)
8785CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8786type(vol7d_var),intent(in) :: var
8787
8788realdatc=c2r(voldat)
8789if (c_e(realdatc) .and. c_e(var%scalefactor))then
8790 realdatc=realdatc/10.**var%scalefactor
8791end if
8792
8793end function realdatc
8794
8795
8801FUNCTION realanavol(this, var) RESULT(vol)
8802TYPE(vol7d),INTENT(in) :: this
8803TYPE(vol7d_var),INTENT(in) :: var
8804REAL :: vol(SIZE(this%ana),size(this%network))
8805
8806CHARACTER(len=1) :: dtype
8807INTEGER :: indvar
8808
8809dtype = cmiss
8810indvar = index(this%anavar, var, type=dtype)
8811
8812IF (indvar > 0) THEN
8813 SELECT CASE (dtype)
8814 CASE("d")
8815 vol = realdat(this%volanad(:,indvar,:), var)
8816 CASE("r")
8817 vol = this%volanar(:,indvar,:)
8818 CASE("i")
8819 vol = realdat(this%volanai(:,indvar,:), var)
8820 CASE("b")
8821 vol = realdat(this%volanab(:,indvar,:), var)
8822 CASE("c")
8823 vol = realdat(this%volanac(:,indvar,:), var)
8824 CASE default
8825 vol = rmiss
8826 END SELECT
8827ELSE
8828 vol = rmiss
8829ENDIF
8830
8831END FUNCTION realanavol
8832
8833
8839FUNCTION integeranavol(this, var) RESULT(vol)
8840TYPE(vol7d),INTENT(in) :: this
8841TYPE(vol7d_var),INTENT(in) :: var
8842INTEGER :: vol(SIZE(this%ana),size(this%network))
8843
8844CHARACTER(len=1) :: dtype
8845INTEGER :: indvar
8846
8847dtype = cmiss
8848indvar = index(this%anavar, var, type=dtype)
8849
8850IF (indvar > 0) THEN
8851 SELECT CASE (dtype)
8852 CASE("d")
8853 vol = integerdat(this%volanad(:,indvar,:), var)
8854 CASE("r")
8855 vol = integerdat(this%volanar(:,indvar,:), var)
8856 CASE("i")
8857 vol = this%volanai(:,indvar,:)
8858 CASE("b")
8859 vol = integerdat(this%volanab(:,indvar,:), var)
8860 CASE("c")
8861 vol = integerdat(this%volanac(:,indvar,:), var)
8862 CASE default
8863 vol = imiss
8864 END SELECT
8865ELSE
8866 vol = imiss
8867ENDIF
8868
8869END FUNCTION integeranavol
8870
8871
8877subroutine move_datac (v7d,&
8878 indana,indtime,indlevel,indtimerange,indnetwork,&
8879 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8880
8881TYPE(vol7d),intent(inout) :: v7d
8882
8883integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8884integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8885integer :: inddativar,inddativarattr
8886
8887
8888do inddativar=1,size(v7d%dativar%c)
8889
8890 if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
8891 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8892 ) then
8893
8894 ! dati
8895 v7d%voldatic &
8896 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8897 v7d%voldatic &
8898 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8899
8900
8901 ! attributi
8902 if (associated (v7d%dativarattr%i)) then
8903 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8904 if (inddativarattr > 0 ) then
8905 v7d%voldatiattri &
8906 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8907 v7d%voldatiattri &
8908 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8909 end if
8910 end if
8911
8912 if (associated (v7d%dativarattr%r)) then
8913 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8914 if (inddativarattr > 0 ) then
8915 v7d%voldatiattrr &
8916 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8917 v7d%voldatiattrr &
8918 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8919 end if
8920 end if
8921
8922 if (associated (v7d%dativarattr%d)) then
8923 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8924 if (inddativarattr > 0 ) then
8925 v7d%voldatiattrd &
8926 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8927 v7d%voldatiattrd &
8928 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8929 end if
8930 end if
8931
8932 if (associated (v7d%dativarattr%b)) then
8933 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8934 if (inddativarattr > 0 ) then
8935 v7d%voldatiattrb &
8936 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8937 v7d%voldatiattrb &
8938 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8939 end if
8940 end if
8941
8942 if (associated (v7d%dativarattr%c)) then
8943 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8944 if (inddativarattr > 0 ) then
8945 v7d%voldatiattrc &
8946 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8947 v7d%voldatiattrc &
8948 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8949 end if
8950 end if
8951
8952 end if
8953
8954end do
8955
8956end subroutine move_datac
8957
8963subroutine move_datar (v7d,&
8964 indana,indtime,indlevel,indtimerange,indnetwork,&
8965 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8966
8967TYPE(vol7d),intent(inout) :: v7d
8968
8969integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8970integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8971integer :: inddativar,inddativarattr
8972
8973
8974do inddativar=1,size(v7d%dativar%r)
8975
8976 if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
8977 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8978 ) then
8979
8980 ! dati
8981 v7d%voldatir &
8982 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8983 v7d%voldatir &
8984 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8985
8986
8987 ! attributi
8988 if (associated (v7d%dativarattr%i)) then
8989 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8990 if (inddativarattr > 0 ) then
8991 v7d%voldatiattri &
8992 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8993 v7d%voldatiattri &
8994 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8995 end if
8996 end if
8997
8998 if (associated (v7d%dativarattr%r)) then
8999 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
9000 if (inddativarattr > 0 ) then
9001 v7d%voldatiattrr &
9002 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9003 v7d%voldatiattrr &
9004 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9005 end if
9006 end if
9007
9008 if (associated (v7d%dativarattr%d)) then
9009 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
9010 if (inddativarattr > 0 ) then
9011 v7d%voldatiattrd &
9012 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9013 v7d%voldatiattrd &
9014 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9015 end if
9016 end if
9017
9018 if (associated (v7d%dativarattr%b)) then
9019 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
9020 if (inddativarattr > 0 ) then
9021 v7d%voldatiattrb &
9022 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9023 v7d%voldatiattrb &
9024 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9025 end if
9026 end if
9027
9028 if (associated (v7d%dativarattr%c)) then
9029 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
9030 if (inddativarattr > 0 ) then
9031 v7d%voldatiattrc &
9032 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9033 v7d%voldatiattrc &
9034 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9035 end if
9036 end if
9037
9038 end if
9039
9040end do
9041
9042end subroutine move_datar
9043
9044
9058subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
9059type(vol7d),intent(inout) :: v7din
9060type(vol7d),intent(out) :: v7dout
9061type(vol7d_level),intent(in),optional :: level(:)
9062type(vol7d_timerange),intent(in),optional :: timerange(:)
9063!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
9064!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
9065logical,intent(in),optional :: nostatproc
9066
9067integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
9068integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
9069type(vol7d_level) :: roundlevel(size(v7din%level))
9070type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
9071type(vol7d) :: v7d_tmp
9072
9073
9074nbin=0
9075
9076if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
9077if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
9078if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
9079if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
9080
9081call init(v7d_tmp)
9082
9083roundlevel=v7din%level
9084
9085if (present(level))then
9086 do ilevel = 1, size(v7din%level)
9087 if ((any(v7din%level(ilevel) .almosteq. level))) then
9088 roundlevel(ilevel)=level(1)
9089 end if
9090 end do
9091end if
9092
9093roundtimerange=v7din%timerange
9094
9095if (present(timerange))then
9096 do itimerange = 1, size(v7din%timerange)
9097 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
9098 roundtimerange(itimerange)=timerange(1)
9099 end if
9100 end do
9101end if
9102
9103!set istantaneous values everywere
9104!preserve p1 for forecast time
9105if (optio_log(nostatproc)) then
9106 roundtimerange(:)%timerange=254
9107 roundtimerange(:)%p2=0
9108end if
9109
9110
9111nana=size(v7din%ana)
9112nlevel=count_distinct(roundlevel,back=.true.)
9113ntime=size(v7din%time)
9114ntimerange=count_distinct(roundtimerange,back=.true.)
9115nnetwork=size(v7din%network)
9116
9117call init(v7d_tmp)
9118
9119if (nbin == 0) then
9120 call copy(v7din,v7d_tmp)
9121else
9122 call vol7d_convr(v7din,v7d_tmp)
9123end if
9124
9125v7d_tmp%level=roundlevel
9126v7d_tmp%timerange=roundtimerange
9127
9128do ilevel=1, size(v7d_tmp%level)
9129 indl=index(v7d_tmp%level,roundlevel(ilevel))
9130 do itimerange=1,size(v7d_tmp%timerange)
9131 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
9132
9133 if (indl /= ilevel .or. indt /= itimerange) then
9134
9135 do iana=1, nana
9136 do itime=1,ntime
9137 do inetwork=1,nnetwork
9138
9139 if (nbin > 0) then
9140 call move_datar (v7d_tmp,&
9141 iana,itime,ilevel,itimerange,inetwork,&
9142 iana,itime,indl,indt,inetwork)
9143 else
9144 call move_datac (v7d_tmp,&
9145 iana,itime,ilevel,itimerange,inetwork,&
9146 iana,itime,indl,indt,inetwork)
9147 end if
9148
9149 end do
9150 end do
9151 end do
9152
9153 end if
9154
9155 end do
9156end do
9157
9158! set to missing level and time > nlevel
9159do ilevel=nlevel+1,size(v7d_tmp%level)
9160 call init (v7d_tmp%level(ilevel))
9161end do
9162
9163do itimerange=ntimerange+1,size(v7d_tmp%timerange)
9164 call init (v7d_tmp%timerange(itimerange))
9165end do
9166
9167!copy with remove
9168CALL copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
9169CALL delete(v7d_tmp)
9170
9171!call display(v7dout)
9172
9173end subroutine v7d_rounding
9174
9175
9176END MODULE vol7d_class
9177
9183
9184
Set of functions that return a trimmed CHARACTER representation of the input variable.
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Index method.
Generic subroutine for checking OPTIONAL parameters.
Test for a missing volume.
Check for problems return 0 if all check passed print diagnostics with log4f.
Distruttore per la classe vol7d.
doubleprecision data conversion
Scrittura su file.
Costruttore per la classe vol7d.
integer data conversion
real data conversion
Reduce some dimensions (level and timerage) for semplification (rounding).
Represent data in a pretty string.
This module defines usefull general purpose function and subroutine.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Gestione degli errori.
Definition of constants related to I/O units.
Definition: io_units.F90:231
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
classe per la gestione del logging
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Classe per la gestione dell'anagrafica di stazioni meteo e affini.
Classe per la gestione di un volume completo di dati osservati.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Classe per la gestione delle reti di stazioni per osservazioni meteo e affini.
Classe per la gestione degli intervalli temporali di osservazioni meteo e affini.
Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...

Generated with Doxygen.