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