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