libsim Versione 7.1.11
|
◆ vol7d_get_volanaattrb()
Crea una vista a dimensione ridotta di un volume di attributi di anagrafica di tipo INTEGER(kind=int_b). È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio: INTEGER(kind=int_b), POINTER :: vol1d(:)
...
CALL vol7d_get_volanaattrb(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 5626 del file vol7d_class.F90. 5628! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
5629! authors:
5630! Davide Cesari <dcesari@arpa.emr.it>
5631! Paolo Patruno <ppatruno@arpa.emr.it>
5632
5633! This program is free software; you can redistribute it and/or
5634! modify it under the terms of the GNU General Public License as
5635! published by the Free Software Foundation; either version 2 of
5636! the License, or (at your option) any later version.
5637
5638! This program is distributed in the hope that it will be useful,
5639! but WITHOUT ANY WARRANTY; without even the implied warranty of
5640! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5641! GNU General Public License for more details.
5642
5643! You should have received a copy of the GNU General Public License
5644! along with this program. If not, see <http://www.gnu.org/licenses/>.
5645#include "config.h"
5646
5658
5726IMPLICIT NONE
5727
5728
5729INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
5730 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
5731
5732INTEGER, PARAMETER :: vol7d_ana_a=1
5733INTEGER, PARAMETER :: vol7d_var_a=2
5734INTEGER, PARAMETER :: vol7d_network_a=3
5735INTEGER, PARAMETER :: vol7d_attr_a=4
5736INTEGER, PARAMETER :: vol7d_ana_d=1
5737INTEGER, PARAMETER :: vol7d_time_d=2
5738INTEGER, PARAMETER :: vol7d_level_d=3
5739INTEGER, PARAMETER :: vol7d_timerange_d=4
5740INTEGER, PARAMETER :: vol7d_var_d=5
5741INTEGER, PARAMETER :: vol7d_network_d=6
5742INTEGER, PARAMETER :: vol7d_attr_d=7
5743INTEGER, PARAMETER :: vol7d_cdatalen=32
5744
5745TYPE vol7d_varmap
5746 INTEGER :: r, d, i, b, c
5747END TYPE vol7d_varmap
5748
5753 TYPE(vol7d_ana),POINTER :: ana(:)
5755 TYPE(datetime),POINTER :: time(:)
5757 TYPE(vol7d_level),POINTER :: level(:)
5759 TYPE(vol7d_timerange),POINTER :: timerange(:)
5761 TYPE(vol7d_network),POINTER :: network(:)
5763 TYPE(vol7d_varvect) :: anavar
5765 TYPE(vol7d_varvect) :: anaattr
5767 TYPE(vol7d_varvect) :: anavarattr
5769 TYPE(vol7d_varvect) :: dativar
5771 TYPE(vol7d_varvect) :: datiattr
5773 TYPE(vol7d_varvect) :: dativarattr
5774
5776 REAL,POINTER :: volanar(:,:,:)
5778 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5780 INTEGER,POINTER :: volanai(:,:,:)
5782 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5784 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5785
5787 REAL,POINTER :: volanaattrr(:,:,:,:)
5789 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5791 INTEGER,POINTER :: volanaattri(:,:,:,:)
5793 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5795 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5796
5798 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5800 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5802 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5804 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5806 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5807
5809 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5811 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5813 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5815 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5817 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5818
5820 integer :: time_definition
5821
5823
5828 MODULE PROCEDURE vol7d_init
5829END INTERFACE
5830
5833 MODULE PROCEDURE vol7d_delete
5834END INTERFACE
5835
5838 MODULE PROCEDURE vol7d_write_on_file
5839END INTERFACE
5840
5842INTERFACE import
5843 MODULE PROCEDURE vol7d_read_from_file
5844END INTERFACE
5845
5848 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5849END INTERFACE
5850
5853 MODULE PROCEDURE to_char_dat
5854END INTERFACE
5855
5858 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5859END INTERFACE
5860
5863 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5864END INTERFACE
5865
5868 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5869END INTERFACE
5870
5873 MODULE PROCEDURE vol7d_copy
5874END INTERFACE
5875
5878 MODULE PROCEDURE vol7d_c_e
5879END INTERFACE
5880
5885 MODULE PROCEDURE vol7d_check
5886END INTERFACE
5887
5902 MODULE PROCEDURE v7d_rounding
5903END INTERFACE
5904
5905!!$INTERFACE get_volana
5906!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
5907!!$ vol7d_get_volanab, vol7d_get_volanac
5908!!$END INTERFACE
5909!!$
5910!!$INTERFACE get_voldati
5911!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
5912!!$ vol7d_get_voldatib, vol7d_get_voldatic
5913!!$END INTERFACE
5914!!$
5915!!$INTERFACE get_volanaattr
5916!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
5917!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
5918!!$END INTERFACE
5919!!$
5920!!$INTERFACE get_voldatiattr
5921!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
5922!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
5923!!$END INTERFACE
5924
5925PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
5926 vol7d_get_volc, &
5927 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
5928 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
5929 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
5930 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
5931 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
5932 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
5933 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
5934 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
5935 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
5936 vol7d_display, dat_display, dat_vect_display, &
5937 to_char_dat, vol7d_check
5938
5939PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5940
5941PRIVATE vol7d_c_e
5942
5943CONTAINS
5944
5945
5950SUBROUTINE vol7d_init(this,time_definition)
5951TYPE(vol7d),intent(out) :: this
5952integer,INTENT(IN),OPTIONAL :: time_definition
5953
5960CALL vol7d_var_features_init() ! initialise var features table once
5961
5962NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
5963
5964NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
5965NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
5966NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
5967NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
5968NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
5969
5970if(present(time_definition)) then
5971 this%time_definition=time_definition
5972else
5973 this%time_definition=1 !default to validity time
5974end if
5975
5976END SUBROUTINE vol7d_init
5977
5978
5982ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
5983TYPE(vol7d),intent(inout) :: this
5984LOGICAL, INTENT(in), OPTIONAL :: dataonly
5985
5986
5987IF (.NOT. optio_log(dataonly)) THEN
5988 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
5989 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
5990 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
5991 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
5992 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
5993 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
5994 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
5995 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
5996 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
5997 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
5998ENDIF
5999IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
6000IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
6001IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
6002IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
6003IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
6004IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
6005IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
6006IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
6007IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
6008IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
6009
6010IF (.NOT. optio_log(dataonly)) THEN
6011 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6012 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6013ENDIF
6014IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6015IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6016IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6017
6018IF (.NOT. optio_log(dataonly)) THEN
6022ENDIF
6026
6027END SUBROUTINE vol7d_delete
6028
6029
6030
6031integer function vol7d_check(this)
6032TYPE(vol7d),intent(in) :: this
6033integer :: i,j,k,l,m,n
6034
6035vol7d_check=0
6036
6037if (associated(this%voldatii)) then
6038do i = 1,size(this%voldatii,1)
6039 do j = 1,size(this%voldatii,2)
6040 do k = 1,size(this%voldatii,3)
6041 do l = 1,size(this%voldatii,4)
6042 do m = 1,size(this%voldatii,5)
6043 do n = 1,size(this%voldatii,6)
6044 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
6045 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
6047 vol7d_check=1
6048 end if
6049 end do
6050 end do
6051 end do
6052 end do
6053 end do
6054end do
6055end if
6056
6057
6058if (associated(this%voldatir)) then
6059do i = 1,size(this%voldatir,1)
6060 do j = 1,size(this%voldatir,2)
6061 do k = 1,size(this%voldatir,3)
6062 do l = 1,size(this%voldatir,4)
6063 do m = 1,size(this%voldatir,5)
6064 do n = 1,size(this%voldatir,6)
6065 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
6066 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
6068 vol7d_check=2
6069 end if
6070 end do
6071 end do
6072 end do
6073 end do
6074 end do
6075end do
6076end if
6077
6078if (associated(this%voldatid)) then
6079do i = 1,size(this%voldatid,1)
6080 do j = 1,size(this%voldatid,2)
6081 do k = 1,size(this%voldatid,3)
6082 do l = 1,size(this%voldatid,4)
6083 do m = 1,size(this%voldatid,5)
6084 do n = 1,size(this%voldatid,6)
6085 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
6086 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
6088 vol7d_check=3
6089 end if
6090 end do
6091 end do
6092 end do
6093 end do
6094 end do
6095end do
6096end if
6097
6098if (associated(this%voldatib)) then
6099do i = 1,size(this%voldatib,1)
6100 do j = 1,size(this%voldatib,2)
6101 do k = 1,size(this%voldatib,3)
6102 do l = 1,size(this%voldatib,4)
6103 do m = 1,size(this%voldatib,5)
6104 do n = 1,size(this%voldatib,6)
6105 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
6106 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
6108 vol7d_check=4
6109 end if
6110 end do
6111 end do
6112 end do
6113 end do
6114 end do
6115end do
6116end if
6117
6118end function vol7d_check
6119
6120
6121
6122!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
6124SUBROUTINE vol7d_display(this)
6125TYPE(vol7d),intent(in) :: this
6126integer :: i
6127
6128REAL :: rdat
6129DOUBLE PRECISION :: ddat
6130INTEGER :: idat
6131INTEGER(kind=int_b) :: bdat
6132CHARACTER(len=vol7d_cdatalen) :: cdat
6133
6134
6135print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
6136if (this%time_definition == 0) then
6137 print*,"TIME DEFINITION: time is reference time"
6138else if (this%time_definition == 1) then
6139 print*,"TIME DEFINITION: time is validity time"
6140else
6141 print*,"Time definition have a wrong walue:", this%time_definition
6142end if
6143
6144IF (ASSOCIATED(this%network))then
6145 print*,"---- network vector ----"
6146 print*,"elements=",size(this%network)
6147 do i=1, size(this%network)
6149 end do
6150end IF
6151
6152IF (ASSOCIATED(this%ana))then
6153 print*,"---- ana vector ----"
6154 print*,"elements=",size(this%ana)
6155 do i=1, size(this%ana)
6157 end do
6158end IF
6159
6160IF (ASSOCIATED(this%time))then
6161 print*,"---- time vector ----"
6162 print*,"elements=",size(this%time)
6163 do i=1, size(this%time)
6165 end do
6166end if
6167
6168IF (ASSOCIATED(this%level)) then
6169 print*,"---- level vector ----"
6170 print*,"elements=",size(this%level)
6171 do i =1,size(this%level)
6173 end do
6174end if
6175
6176IF (ASSOCIATED(this%timerange))then
6177 print*,"---- timerange vector ----"
6178 print*,"elements=",size(this%timerange)
6179 do i =1,size(this%timerange)
6181 end do
6182end if
6183
6184
6185print*,"---- ana vector ----"
6186print*,""
6187print*,"->>>>>>>>> anavar -"
6189print*,""
6190print*,"->>>>>>>>> anaattr -"
6192print*,""
6193print*,"->>>>>>>>> anavarattr -"
6195
6196print*,"-- ana data section (first point) --"
6197
6198idat=imiss
6199rdat=rmiss
6200ddat=dmiss
6201bdat=ibmiss
6202cdat=cmiss
6203
6204!ntime = MIN(SIZE(this%time),nprint)
6205!ntimerange = MIN(SIZE(this%timerange),nprint)
6206!nlevel = MIN(SIZE(this%level),nprint)
6207!nnetwork = MIN(SIZE(this%network),nprint)
6208!nana = MIN(SIZE(this%ana),nprint)
6209
6210IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
6211if (associated(this%volanai)) then
6212 do i=1,size(this%anavar%i)
6213 idat=this%volanai(1,i,1)
6215 end do
6216end if
6217idat=imiss
6218
6219if (associated(this%volanar)) then
6220 do i=1,size(this%anavar%r)
6221 rdat=this%volanar(1,i,1)
6223 end do
6224end if
6225rdat=rmiss
6226
6227if (associated(this%volanad)) then
6228 do i=1,size(this%anavar%d)
6229 ddat=this%volanad(1,i,1)
6231 end do
6232end if
6233ddat=dmiss
6234
6235if (associated(this%volanab)) then
6236 do i=1,size(this%anavar%b)
6237 bdat=this%volanab(1,i,1)
6239 end do
6240end if
6241bdat=ibmiss
6242
6243if (associated(this%volanac)) then
6244 do i=1,size(this%anavar%c)
6245 cdat=this%volanac(1,i,1)
6247 end do
6248end if
6249cdat=cmiss
6250ENDIF
6251
6252print*,"---- data vector ----"
6253print*,""
6254print*,"->>>>>>>>> dativar -"
6256print*,""
6257print*,"->>>>>>>>> datiattr -"
6259print*,""
6260print*,"->>>>>>>>> dativarattr -"
6262
6263print*,"-- data data section (first point) --"
6264
6265idat=imiss
6266rdat=rmiss
6267ddat=dmiss
6268bdat=ibmiss
6269cdat=cmiss
6270
6271IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
6272 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
6273if (associated(this%voldatii)) then
6274 do i=1,size(this%dativar%i)
6275 idat=this%voldatii(1,1,1,1,i,1)
6277 end do
6278end if
6279idat=imiss
6280
6281if (associated(this%voldatir)) then
6282 do i=1,size(this%dativar%r)
6283 rdat=this%voldatir(1,1,1,1,i,1)
6285 end do
6286end if
6287rdat=rmiss
6288
6289if (associated(this%voldatid)) then
6290 do i=1,size(this%dativar%d)
6291 ddat=this%voldatid(1,1,1,1,i,1)
6293 end do
6294end if
6295ddat=dmiss
6296
6297if (associated(this%voldatib)) then
6298 do i=1,size(this%dativar%b)
6299 bdat=this%voldatib(1,1,1,1,i,1)
6301 end do
6302end if
6303bdat=ibmiss
6304
6305if (associated(this%voldatic)) then
6306 do i=1,size(this%dativar%c)
6307 cdat=this%voldatic(1,1,1,1,i,1)
6309 end do
6310end if
6311cdat=cmiss
6312ENDIF
6313
6314print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
6315
6316END SUBROUTINE vol7d_display
6317
6318
6320SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
6321TYPE(vol7d_var),intent(in) :: this
6323REAL :: rdat
6325DOUBLE PRECISION :: ddat
6327INTEGER :: idat
6329INTEGER(kind=int_b) :: bdat
6331CHARACTER(len=*) :: cdat
6332
6333print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6334
6335end SUBROUTINE dat_display
6336
6338SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
6339
6340TYPE(vol7d_var),intent(in) :: this(:)
6342REAL :: rdat(:)
6344DOUBLE PRECISION :: ddat(:)
6346INTEGER :: idat(:)
6348INTEGER(kind=int_b) :: bdat(:)
6350CHARACTER(len=*):: cdat(:)
6351
6352integer :: i
6353
6354do i =1,size(this)
6356end do
6357
6358end SUBROUTINE dat_vect_display
6359
6360
6361FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6362#ifdef HAVE_DBALLE
6363USE dballef
6364#endif
6365TYPE(vol7d_var),INTENT(in) :: this
6367REAL :: rdat
6369DOUBLE PRECISION :: ddat
6371INTEGER :: idat
6373INTEGER(kind=int_b) :: bdat
6375CHARACTER(len=*) :: cdat
6376CHARACTER(len=80) :: to_char_dat
6377
6378CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
6379
6380
6381#ifdef HAVE_DBALLE
6382INTEGER :: handle, ier
6383
6384handle = 0
6385to_char_dat="VALUE: "
6386
6391
6393 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
6394 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
6395 ier = idba_fatto(handle)
6396 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
6397endif
6398
6399#else
6400
6401to_char_dat="VALUE: "
6407
6408#endif
6409
6410END FUNCTION to_char_dat
6411
6412
6415FUNCTION vol7d_c_e(this) RESULT(c_e)
6416TYPE(vol7d), INTENT(in) :: this
6417
6418LOGICAL :: c_e
6419
6421 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
6422 ASSOCIATED(this%network) .OR. &
6423 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6424 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6425 ASSOCIATED(this%anavar%c) .OR. &
6426 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
6427 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
6428 ASSOCIATED(this%anaattr%c) .OR. &
6429 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6430 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6431 ASSOCIATED(this%dativar%c) .OR. &
6432 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
6433 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
6434 ASSOCIATED(this%datiattr%c)
6435
6436END FUNCTION vol7d_c_e
6437
6438
6477SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
6478 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6479 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6480 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6481 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6482 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6483 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
6484 ini)
6485TYPE(vol7d),INTENT(inout) :: this
6486INTEGER,INTENT(in),OPTIONAL :: nana
6487INTEGER,INTENT(in),OPTIONAL :: ntime
6488INTEGER,INTENT(in),OPTIONAL :: nlevel
6489INTEGER,INTENT(in),OPTIONAL :: ntimerange
6490INTEGER,INTENT(in),OPTIONAL :: nnetwork
6492INTEGER,INTENT(in),OPTIONAL :: &
6493 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
6494 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
6495 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
6496 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
6497 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
6498 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
6499LOGICAL,INTENT(in),OPTIONAL :: ini
6500
6501INTEGER :: i
6502LOGICAL :: linit
6503
6504IF (PRESENT(ini)) THEN
6505 linit = ini
6506ELSE
6507 linit = .false.
6508ENDIF
6509
6510! Dimensioni principali
6511IF (PRESENT(nana)) THEN
6512 IF (nana >= 0) THEN
6513 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6514 ALLOCATE(this%ana(nana))
6515 IF (linit) THEN
6516 DO i = 1, nana
6518 ENDDO
6519 ENDIF
6520 ENDIF
6521ENDIF
6522IF (PRESENT(ntime)) THEN
6523 IF (ntime >= 0) THEN
6524 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6525 ALLOCATE(this%time(ntime))
6526 IF (linit) THEN
6527 DO i = 1, ntime
6529 ENDDO
6530 ENDIF
6531 ENDIF
6532ENDIF
6533IF (PRESENT(nlevel)) THEN
6534 IF (nlevel >= 0) THEN
6535 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6536 ALLOCATE(this%level(nlevel))
6537 IF (linit) THEN
6538 DO i = 1, nlevel
6540 ENDDO
6541 ENDIF
6542 ENDIF
6543ENDIF
6544IF (PRESENT(ntimerange)) THEN
6545 IF (ntimerange >= 0) THEN
6546 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6547 ALLOCATE(this%timerange(ntimerange))
6548 IF (linit) THEN
6549 DO i = 1, ntimerange
6551 ENDDO
6552 ENDIF
6553 ENDIF
6554ENDIF
6555IF (PRESENT(nnetwork)) THEN
6556 IF (nnetwork >= 0) THEN
6557 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6558 ALLOCATE(this%network(nnetwork))
6559 IF (linit) THEN
6560 DO i = 1, nnetwork
6562 ENDDO
6563 ENDIF
6564 ENDIF
6565ENDIF
6566! Dimensioni dei tipi delle variabili
6567CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
6568 nanavari, nanavarb, nanavarc, ini)
6569CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
6570 nanaattri, nanaattrb, nanaattrc, ini)
6571CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
6572 nanavarattri, nanavarattrb, nanavarattrc, ini)
6573CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
6574 ndativari, ndativarb, ndativarc, ini)
6575CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
6576 ndatiattri, ndatiattrb, ndatiattrc, ini)
6577CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
6578 ndativarattri, ndativarattrb, ndativarattrc, ini)
6579
6580END SUBROUTINE vol7d_alloc
6581
6582
6583FUNCTION vol7d_check_alloc_ana(this)
6584TYPE(vol7d),INTENT(in) :: this
6585LOGICAL :: vol7d_check_alloc_ana
6586
6587vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
6588
6589END FUNCTION vol7d_check_alloc_ana
6590
6591SUBROUTINE vol7d_force_alloc_ana(this, ini)
6592TYPE(vol7d),INTENT(inout) :: this
6593LOGICAL,INTENT(in),OPTIONAL :: ini
6594
6595! Alloco i descrittori minimi per avere un volume di anagrafica
6596IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
6597IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
6598
6599END SUBROUTINE vol7d_force_alloc_ana
6600
6601
6602FUNCTION vol7d_check_alloc_dati(this)
6603TYPE(vol7d),INTENT(in) :: this
6604LOGICAL :: vol7d_check_alloc_dati
6605
6606vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
6607 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
6608 ASSOCIATED(this%timerange)
6609
6610END FUNCTION vol7d_check_alloc_dati
6611
6612SUBROUTINE vol7d_force_alloc_dati(this, ini)
6613TYPE(vol7d),INTENT(inout) :: this
6614LOGICAL,INTENT(in),OPTIONAL :: ini
6615
6616! Alloco i descrittori minimi per avere un volume di dati
6617CALL vol7d_force_alloc_ana(this, ini)
6618IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
6619IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
6620IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
6621
6622END SUBROUTINE vol7d_force_alloc_dati
6623
6624
6625SUBROUTINE vol7d_force_alloc(this)
6626TYPE(vol7d),INTENT(inout) :: this
6627
6628! If anything really not allocated yet, allocate with size 0
6629IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
6630IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
6631IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
6632IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
6633IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
6634
6635END SUBROUTINE vol7d_force_alloc
6636
6637
6638FUNCTION vol7d_check_vol(this)
6639TYPE(vol7d),INTENT(in) :: this
6640LOGICAL :: vol7d_check_vol
6641
6642vol7d_check_vol = c_e(this)
6643
6644! Anagrafica
6645IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6646 vol7d_check_vol = .false.
6647ENDIF
6648
6649IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6650 vol7d_check_vol = .false.
6651ENDIF
6652
6653IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6654 vol7d_check_vol = .false.
6655ENDIF
6656
6657IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6658 vol7d_check_vol = .false.
6659ENDIF
6660
6661IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6662 vol7d_check_vol = .false.
6663ENDIF
6664IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6665 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6666 ASSOCIATED(this%anavar%c)) THEN
6667 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
6668ENDIF
6669
6670! Attributi dell'anagrafica
6671IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6672 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6673 vol7d_check_vol = .false.
6674ENDIF
6675
6676IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6677 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6678 vol7d_check_vol = .false.
6679ENDIF
6680
6681IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6682 .NOT.ASSOCIATED(this%volanaattri)) THEN
6683 vol7d_check_vol = .false.
6684ENDIF
6685
6686IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6687 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6688 vol7d_check_vol = .false.
6689ENDIF
6690
6691IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6692 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6693 vol7d_check_vol = .false.
6694ENDIF
6695
6696! Dati
6697IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6698 vol7d_check_vol = .false.
6699ENDIF
6700
6701IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6702 vol7d_check_vol = .false.
6703ENDIF
6704
6705IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6706 vol7d_check_vol = .false.
6707ENDIF
6708
6709IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6710 vol7d_check_vol = .false.
6711ENDIF
6712
6713IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6714 vol7d_check_vol = .false.
6715ENDIF
6716
6717! Attributi dei dati
6718IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6719 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6720 vol7d_check_vol = .false.
6721ENDIF
6722
6723IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6724 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6725 vol7d_check_vol = .false.
6726ENDIF
6727
6728IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6729 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6730 vol7d_check_vol = .false.
6731ENDIF
6732
6733IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6734 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6735 vol7d_check_vol = .false.
6736ENDIF
6737
6738IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6739 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6740 vol7d_check_vol = .false.
6741ENDIF
6742IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6743 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6744 ASSOCIATED(this%dativar%c)) THEN
6745 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6746ENDIF
6747
6748END FUNCTION vol7d_check_vol
6749
6750
6765SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6766TYPE(vol7d),INTENT(inout) :: this
6767LOGICAL,INTENT(in),OPTIONAL :: ini
6768LOGICAL,INTENT(in),OPTIONAL :: inivol
6769
6770LOGICAL :: linivol
6771
6772IF (PRESENT(inivol)) THEN
6773 linivol = inivol
6774ELSE
6775 linivol = .true.
6776ENDIF
6777
6778! Anagrafica
6779IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6780 CALL vol7d_force_alloc_ana(this, ini)
6781 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6782 IF (linivol) this%volanar(:,:,:) = rmiss
6783ENDIF
6784
6785IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6786 CALL vol7d_force_alloc_ana(this, ini)
6787 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6788 IF (linivol) this%volanad(:,:,:) = rdmiss
6789ENDIF
6790
6791IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6792 CALL vol7d_force_alloc_ana(this, ini)
6793 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6794 IF (linivol) this%volanai(:,:,:) = imiss
6795ENDIF
6796
6797IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6798 CALL vol7d_force_alloc_ana(this, ini)
6799 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6800 IF (linivol) this%volanab(:,:,:) = ibmiss
6801ENDIF
6802
6803IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6804 CALL vol7d_force_alloc_ana(this, ini)
6805 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6806 IF (linivol) this%volanac(:,:,:) = cmiss
6807ENDIF
6808
6809! Attributi dell'anagrafica
6810IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6811 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6812 CALL vol7d_force_alloc_ana(this, ini)
6813 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6814 SIZE(this%network), SIZE(this%anaattr%r)))
6815 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6816ENDIF
6817
6818IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6819 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6820 CALL vol7d_force_alloc_ana(this, ini)
6821 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6822 SIZE(this%network), SIZE(this%anaattr%d)))
6823 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6824ENDIF
6825
6826IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6827 .NOT.ASSOCIATED(this%volanaattri)) THEN
6828 CALL vol7d_force_alloc_ana(this, ini)
6829 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6830 SIZE(this%network), SIZE(this%anaattr%i)))
6831 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6832ENDIF
6833
6834IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6835 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6836 CALL vol7d_force_alloc_ana(this, ini)
6837 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6838 SIZE(this%network), SIZE(this%anaattr%b)))
6839 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6840ENDIF
6841
6842IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6843 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6844 CALL vol7d_force_alloc_ana(this, ini)
6845 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6846 SIZE(this%network), SIZE(this%anaattr%c)))
6847 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6848ENDIF
6849
6850! Dati
6851IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6852 CALL vol7d_force_alloc_dati(this, ini)
6853 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6854 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6855 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6856ENDIF
6857
6858IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6859 CALL vol7d_force_alloc_dati(this, ini)
6860 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6861 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6862 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6863ENDIF
6864
6865IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6866 CALL vol7d_force_alloc_dati(this, ini)
6867 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6868 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6869 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6870ENDIF
6871
6872IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6873 CALL vol7d_force_alloc_dati(this, ini)
6874 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6875 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6876 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6877ENDIF
6878
6879IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6880 CALL vol7d_force_alloc_dati(this, ini)
6881 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6882 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6883 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6884ENDIF
6885
6886! Attributi dei dati
6887IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6888 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6889 CALL vol7d_force_alloc_dati(this, ini)
6890 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6891 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
6892 SIZE(this%datiattr%r)))
6893 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
6894ENDIF
6895
6896IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6897 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6898 CALL vol7d_force_alloc_dati(this, ini)
6899 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6900 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
6901 SIZE(this%datiattr%d)))
6902 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
6903ENDIF
6904
6905IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6906 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6907 CALL vol7d_force_alloc_dati(this, ini)
6908 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6909 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
6910 SIZE(this%datiattr%i)))
6911 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
6912ENDIF
6913
6914IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6915 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6916 CALL vol7d_force_alloc_dati(this, ini)
6917 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6918 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
6919 SIZE(this%datiattr%b)))
6920 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
6921ENDIF
6922
6923IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6924 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6925 CALL vol7d_force_alloc_dati(this, ini)
6926 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6927 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
6928 SIZE(this%datiattr%c)))
6929 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
6930ENDIF
6931
6932! Catch-all method
6933CALL vol7d_force_alloc(this)
6934
6935! Creo gli indici var-attr
6936
6937#ifdef DEBUG
6938CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
6939#endif
6940
6941CALL vol7d_set_attr_ind(this)
6942
6943
6944
6945END SUBROUTINE vol7d_alloc_vol
6946
6947
6954SUBROUTINE vol7d_set_attr_ind(this)
6955TYPE(vol7d),INTENT(inout) :: this
6956
6957INTEGER :: i
6958
6959! real
6960IF (ASSOCIATED(this%dativar%r)) THEN
6961 IF (ASSOCIATED(this%dativarattr%r)) THEN
6962 DO i = 1, SIZE(this%dativar%r)
6963 this%dativar%r(i)%r = &
6964 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
6965 ENDDO
6966 ENDIF
6967
6968 IF (ASSOCIATED(this%dativarattr%d)) THEN
6969 DO i = 1, SIZE(this%dativar%r)
6970 this%dativar%r(i)%d = &
6971 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
6972 ENDDO
6973 ENDIF
6974
6975 IF (ASSOCIATED(this%dativarattr%i)) THEN
6976 DO i = 1, SIZE(this%dativar%r)
6977 this%dativar%r(i)%i = &
6978 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
6979 ENDDO
6980 ENDIF
6981
6982 IF (ASSOCIATED(this%dativarattr%b)) THEN
6983 DO i = 1, SIZE(this%dativar%r)
6984 this%dativar%r(i)%b = &
6985 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
6986 ENDDO
6987 ENDIF
6988
6989 IF (ASSOCIATED(this%dativarattr%c)) THEN
6990 DO i = 1, SIZE(this%dativar%r)
6991 this%dativar%r(i)%c = &
6992 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
6993 ENDDO
6994 ENDIF
6995ENDIF
6996! double
6997IF (ASSOCIATED(this%dativar%d)) THEN
6998 IF (ASSOCIATED(this%dativarattr%r)) THEN
6999 DO i = 1, SIZE(this%dativar%d)
7000 this%dativar%d(i)%r = &
7001 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
7002 ENDDO
7003 ENDIF
7004
7005 IF (ASSOCIATED(this%dativarattr%d)) THEN
7006 DO i = 1, SIZE(this%dativar%d)
7007 this%dativar%d(i)%d = &
7008 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
7009 ENDDO
7010 ENDIF
7011
7012 IF (ASSOCIATED(this%dativarattr%i)) THEN
7013 DO i = 1, SIZE(this%dativar%d)
7014 this%dativar%d(i)%i = &
7015 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
7016 ENDDO
7017 ENDIF
7018
7019 IF (ASSOCIATED(this%dativarattr%b)) THEN
7020 DO i = 1, SIZE(this%dativar%d)
7021 this%dativar%d(i)%b = &
7022 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
7023 ENDDO
7024 ENDIF
7025
7026 IF (ASSOCIATED(this%dativarattr%c)) THEN
7027 DO i = 1, SIZE(this%dativar%d)
7028 this%dativar%d(i)%c = &
7029 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
7030 ENDDO
7031 ENDIF
7032ENDIF
7033! integer
7034IF (ASSOCIATED(this%dativar%i)) THEN
7035 IF (ASSOCIATED(this%dativarattr%r)) THEN
7036 DO i = 1, SIZE(this%dativar%i)
7037 this%dativar%i(i)%r = &
7038 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
7039 ENDDO
7040 ENDIF
7041
7042 IF (ASSOCIATED(this%dativarattr%d)) THEN
7043 DO i = 1, SIZE(this%dativar%i)
7044 this%dativar%i(i)%d = &
7045 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
7046 ENDDO
7047 ENDIF
7048
7049 IF (ASSOCIATED(this%dativarattr%i)) THEN
7050 DO i = 1, SIZE(this%dativar%i)
7051 this%dativar%i(i)%i = &
7052 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
7053 ENDDO
7054 ENDIF
7055
7056 IF (ASSOCIATED(this%dativarattr%b)) THEN
7057 DO i = 1, SIZE(this%dativar%i)
7058 this%dativar%i(i)%b = &
7059 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
7060 ENDDO
7061 ENDIF
7062
7063 IF (ASSOCIATED(this%dativarattr%c)) THEN
7064 DO i = 1, SIZE(this%dativar%i)
7065 this%dativar%i(i)%c = &
7066 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
7067 ENDDO
7068 ENDIF
7069ENDIF
7070! byte
7071IF (ASSOCIATED(this%dativar%b)) THEN
7072 IF (ASSOCIATED(this%dativarattr%r)) THEN
7073 DO i = 1, SIZE(this%dativar%b)
7074 this%dativar%b(i)%r = &
7075 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
7076 ENDDO
7077 ENDIF
7078
7079 IF (ASSOCIATED(this%dativarattr%d)) THEN
7080 DO i = 1, SIZE(this%dativar%b)
7081 this%dativar%b(i)%d = &
7082 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
7083 ENDDO
7084 ENDIF
7085
7086 IF (ASSOCIATED(this%dativarattr%i)) THEN
7087 DO i = 1, SIZE(this%dativar%b)
7088 this%dativar%b(i)%i = &
7089 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
7090 ENDDO
7091 ENDIF
7092
7093 IF (ASSOCIATED(this%dativarattr%b)) THEN
7094 DO i = 1, SIZE(this%dativar%b)
7095 this%dativar%b(i)%b = &
7096 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
7097 ENDDO
7098 ENDIF
7099
7100 IF (ASSOCIATED(this%dativarattr%c)) THEN
7101 DO i = 1, SIZE(this%dativar%b)
7102 this%dativar%b(i)%c = &
7103 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
7104 ENDDO
7105 ENDIF
7106ENDIF
7107! character
7108IF (ASSOCIATED(this%dativar%c)) THEN
7109 IF (ASSOCIATED(this%dativarattr%r)) THEN
7110 DO i = 1, SIZE(this%dativar%c)
7111 this%dativar%c(i)%r = &
7112 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
7113 ENDDO
7114 ENDIF
7115
7116 IF (ASSOCIATED(this%dativarattr%d)) THEN
7117 DO i = 1, SIZE(this%dativar%c)
7118 this%dativar%c(i)%d = &
7119 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
7120 ENDDO
7121 ENDIF
7122
7123 IF (ASSOCIATED(this%dativarattr%i)) THEN
7124 DO i = 1, SIZE(this%dativar%c)
7125 this%dativar%c(i)%i = &
7126 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
7127 ENDDO
7128 ENDIF
7129
7130 IF (ASSOCIATED(this%dativarattr%b)) THEN
7131 DO i = 1, SIZE(this%dativar%c)
7132 this%dativar%c(i)%b = &
7133 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
7134 ENDDO
7135 ENDIF
7136
7137 IF (ASSOCIATED(this%dativarattr%c)) THEN
7138 DO i = 1, SIZE(this%dativar%c)
7139 this%dativar%c(i)%c = &
7140 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
7141 ENDDO
7142 ENDIF
7143ENDIF
7144
7145END SUBROUTINE vol7d_set_attr_ind
7146
7147
7152SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
7153 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7154TYPE(vol7d),INTENT(INOUT) :: this
7155TYPE(vol7d),INTENT(INOUT) :: that
7156LOGICAL,INTENT(IN),OPTIONAL :: sort
7157LOGICAL,INTENT(in),OPTIONAL :: bestdata
7158LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
7159
7160TYPE(vol7d) :: v7d_clean
7161
7162
7164 this = that
7166 that = v7d_clean ! destroy that without deallocating
7167ELSE ! Append that to this and destroy that
7169 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7171ENDIF
7172
7173END SUBROUTINE vol7d_merge
7174
7175
7204SUBROUTINE vol7d_append(this, that, sort, bestdata, &
7205 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
7206TYPE(vol7d),INTENT(INOUT) :: this
7207TYPE(vol7d),INTENT(IN) :: that
7208LOGICAL,INTENT(IN),OPTIONAL :: sort
7209! experimental, please do not use outside the library now, they force the use
7210! of a simplified mapping algorithm which is valid only whene the dimension
7211! content is the same in both volumes , or when one of them is empty
7212LOGICAL,INTENT(in),OPTIONAL :: bestdata
7213LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
7214
7215
7216TYPE(vol7d) :: v7dtmp
7217LOGICAL :: lsort, lbestdata
7218INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
7219 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
7220
7222IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
7225 RETURN
7226ENDIF
7227
7228IF (this%time_definition /= that%time_definition) THEN
7229 CALL l4f_log(l4f_fatal, &
7230 'in vol7d_append, cannot append volumes with different &
7231 &time definition')
7232 CALL raise_fatal_error()
7233ENDIF
7234
7235! Completo l'allocazione per avere volumi a norma
7236CALL vol7d_alloc_vol(this)
7237
7241
7242! Calcolo le mappature tra volumi vecchi e volume nuovo
7243! I puntatori remap* vengono tutti o allocati o nullificati
7244IF (optio_log(ltimesimple)) THEN
7245 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
7246 lsort, remapt1, remapt2)
7247ELSE
7248 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
7249 lsort, remapt1, remapt2)
7250ENDIF
7251IF (optio_log(ltimerangesimple)) THEN
7252 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
7253 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7254ELSE
7255 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
7256 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7257ENDIF
7258IF (optio_log(llevelsimple)) THEN
7259 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
7260 lsort, remapl1, remapl2)
7261ELSE
7262 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
7263 lsort, remapl1, remapl2)
7264ENDIF
7265IF (optio_log(lanasimple)) THEN
7266 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7267 .false., remapa1, remapa2)
7268ELSE
7269 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7270 .false., remapa1, remapa2)
7271ENDIF
7272IF (optio_log(lnetworksimple)) THEN
7273 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
7274 .false., remapn1, remapn2)
7275ELSE
7276 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
7277 .false., remapn1, remapn2)
7278ENDIF
7279
7280! Faccio la fusione fisica dei volumi
7281CALL vol7d_merge_finalr(this, that, v7dtmp, &
7282 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7283 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7284CALL vol7d_merge_finald(this, that, v7dtmp, &
7285 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7286 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7287CALL vol7d_merge_finali(this, that, v7dtmp, &
7288 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7289 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7290CALL vol7d_merge_finalb(this, that, v7dtmp, &
7291 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7292 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7293CALL vol7d_merge_finalc(this, that, v7dtmp, &
7294 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7295 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7296
7297! Dealloco i vettori di rimappatura
7298IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
7299IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
7300IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
7301IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
7302IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
7303IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
7304IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
7305IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
7306IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
7307IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
7308
7309! Distruggo il vecchio volume e assegno il nuovo a this
7311this = v7dtmp
7312! Ricreo gli indici var-attr
7313CALL vol7d_set_attr_ind(this)
7314
7315END SUBROUTINE vol7d_append
7316
7317
7350SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
7351 lsort_time, lsort_timerange, lsort_level, &
7352 ltime, ltimerange, llevel, lana, lnetwork, &
7353 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7354 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7355 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7356 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7357 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7358 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7359TYPE(vol7d),INTENT(IN) :: this
7360TYPE(vol7d),INTENT(INOUT) :: that
7361LOGICAL,INTENT(IN),OPTIONAL :: sort
7362LOGICAL,INTENT(IN),OPTIONAL :: unique
7363LOGICAL,INTENT(IN),OPTIONAL :: miss
7364LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
7365LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
7366LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
7374LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7376LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
7378LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
7380LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
7382LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
7384LOGICAL,INTENT(in),OPTIONAL :: &
7385 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7386 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7387 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7388 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7389 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7390 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7391
7392LOGICAL :: lsort, lunique, lmiss
7393INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
7394
7397IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
7398
7402
7403! Calcolo le mappature tra volume vecchio e volume nuovo
7404! I puntatori remap* vengono tutti o allocati o nullificati
7405CALL vol7d_remap1_datetime(this%time, that%time, &
7406 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
7407CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
7408 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
7409CALL vol7d_remap1_vol7d_level(this%level, that%level, &
7410 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
7411CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
7412 lsort, lunique, lmiss, remapa, lana)
7413CALL vol7d_remap1_vol7d_network(this%network, that%network, &
7414 lsort, lunique, lmiss, remapn, lnetwork)
7415
7416! lanavari, lanavarb, lanavarc, &
7417! lanaattri, lanaattrb, lanaattrc, &
7418! lanavarattri, lanavarattrb, lanavarattrc, &
7419! ldativari, ldativarb, ldativarc, &
7420! ldatiattri, ldatiattrb, ldatiattrc, &
7421! ldativarattri, ldativarattrb, ldativarattrc
7422! Faccio la riforma fisica dei volumi
7423CALL vol7d_reform_finalr(this, that, &
7424 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7425 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
7426CALL vol7d_reform_finald(this, that, &
7427 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7428 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
7429CALL vol7d_reform_finali(this, that, &
7430 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7431 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
7432CALL vol7d_reform_finalb(this, that, &
7433 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7434 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
7435CALL vol7d_reform_finalc(this, that, &
7436 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
7437 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
7438
7439! Dealloco i vettori di rimappatura
7440IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
7441IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
7442IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
7443IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
7444IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
7445
7446! Ricreo gli indici var-attr
7447CALL vol7d_set_attr_ind(that)
7448that%time_definition = this%time_definition
7449
7450END SUBROUTINE vol7d_copy
7451
7452
7463SUBROUTINE vol7d_reform(this, sort, unique, miss, &
7464 lsort_time, lsort_timerange, lsort_level, &
7465 ltime, ltimerange, llevel, lana, lnetwork, &
7466 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7467 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7468 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7469 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7470 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7471 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
7472 ,purgeana)
7473TYPE(vol7d),INTENT(INOUT) :: this
7474LOGICAL,INTENT(IN),OPTIONAL :: sort
7475LOGICAL,INTENT(IN),OPTIONAL :: unique
7476LOGICAL,INTENT(IN),OPTIONAL :: miss
7477LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
7478LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
7479LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
7487LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
7488LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
7489LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
7490LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
7491LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
7493LOGICAL,INTENT(in),OPTIONAL :: &
7494 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
7495 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
7496 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
7497 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
7498 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
7499 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
7500LOGICAL,INTENT(IN),OPTIONAL :: purgeana
7501
7502TYPE(vol7d) :: v7dtmp
7503logical,allocatable :: llana(:)
7504integer :: i
7505
7507 lsort_time, lsort_timerange, lsort_level, &
7508 ltime, ltimerange, llevel, lana, lnetwork, &
7509 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7510 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7511 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7512 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7513 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7514 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7515
7516! destroy old volume
7518
7519if (optio_log(purgeana)) then
7520 allocate(llana(size(v7dtmp%ana)))
7521 llana =.false.
7522 do i =1,size(v7dtmp%ana)
7523 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
7524 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
7525 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
7526 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
7527 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
7528 end do
7529 CALL vol7d_copy(v7dtmp, this,lana=llana)
7531 deallocate(llana)
7532else
7533 this=v7dtmp
7534end if
7535
7536END SUBROUTINE vol7d_reform
7537
7538
7546SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
7547TYPE(vol7d),INTENT(INOUT) :: this
7548LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
7549LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
7550LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
7551
7552INTEGER :: i
7553LOGICAL :: to_be_sorted
7554
7555to_be_sorted = .false.
7556CALL vol7d_alloc_vol(this) ! usual safety check
7557
7558IF (optio_log(lsort_time)) THEN
7559 DO i = 2, SIZE(this%time)
7560 IF (this%time(i) < this%time(i-1)) THEN
7561 to_be_sorted = .true.
7562 EXIT
7563 ENDIF
7564 ENDDO
7565ENDIF
7566IF (optio_log(lsort_timerange)) THEN
7567 DO i = 2, SIZE(this%timerange)
7568 IF (this%timerange(i) < this%timerange(i-1)) THEN
7569 to_be_sorted = .true.
7570 EXIT
7571 ENDIF
7572 ENDDO
7573ENDIF
7574IF (optio_log(lsort_level)) THEN
7575 DO i = 2, SIZE(this%level)
7576 IF (this%level(i) < this%level(i-1)) THEN
7577 to_be_sorted = .true.
7578 EXIT
7579 ENDIF
7580 ENDDO
7581ENDIF
7582
7583IF (to_be_sorted) CALL vol7d_reform(this, &
7584 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
7585
7586END SUBROUTINE vol7d_smart_sort
7587
7595SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
7596TYPE(vol7d),INTENT(inout) :: this
7597CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
7598CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
7599TYPE(vol7d_network),OPTIONAL :: nl(:)
7600TYPE(datetime),INTENT(in),OPTIONAL :: s_d
7601TYPE(datetime),INTENT(in),OPTIONAL :: e_d
7602
7603INTEGER :: i
7604
7605IF (PRESENT(avl)) THEN
7606 IF (SIZE(avl) > 0) THEN
7607
7608 IF (ASSOCIATED(this%anavar%r)) THEN
7609 DO i = 1, SIZE(this%anavar%r)
7610 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
7611 ENDDO
7612 ENDIF
7613
7614 IF (ASSOCIATED(this%anavar%i)) THEN
7615 DO i = 1, SIZE(this%anavar%i)
7616 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
7617 ENDDO
7618 ENDIF
7619
7620 IF (ASSOCIATED(this%anavar%b)) THEN
7621 DO i = 1, SIZE(this%anavar%b)
7622 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
7623 ENDDO
7624 ENDIF
7625
7626 IF (ASSOCIATED(this%anavar%d)) THEN
7627 DO i = 1, SIZE(this%anavar%d)
7628 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
7629 ENDDO
7630 ENDIF
7631
7632 IF (ASSOCIATED(this%anavar%c)) THEN
7633 DO i = 1, SIZE(this%anavar%c)
7634 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
7635 ENDDO
7636 ENDIF
7637
7638 ENDIF
7639ENDIF
7640
7641
7642IF (PRESENT(vl)) THEN
7643 IF (size(vl) > 0) THEN
7644 IF (ASSOCIATED(this%dativar%r)) THEN
7645 DO i = 1, SIZE(this%dativar%r)
7646 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
7647 ENDDO
7648 ENDIF
7649
7650 IF (ASSOCIATED(this%dativar%i)) THEN
7651 DO i = 1, SIZE(this%dativar%i)
7652 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
7653 ENDDO
7654 ENDIF
7655
7656 IF (ASSOCIATED(this%dativar%b)) THEN
7657 DO i = 1, SIZE(this%dativar%b)
7658 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
7659 ENDDO
7660 ENDIF
7661
7662 IF (ASSOCIATED(this%dativar%d)) THEN
7663 DO i = 1, SIZE(this%dativar%d)
7664 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
7665 ENDDO
7666 ENDIF
7667
7668 IF (ASSOCIATED(this%dativar%c)) THEN
7669 DO i = 1, SIZE(this%dativar%c)
7670 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7671 ENDDO
7672 ENDIF
7673
7674 IF (ASSOCIATED(this%dativar%c)) THEN
7675 DO i = 1, SIZE(this%dativar%c)
7676 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7677 ENDDO
7678 ENDIF
7679
7680 ENDIF
7681ENDIF
7682
7683IF (PRESENT(nl)) THEN
7684 IF (SIZE(nl) > 0) THEN
7685 DO i = 1, SIZE(this%network)
7686 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
7687 ENDDO
7688 ENDIF
7689ENDIF
7690
7691IF (PRESENT(s_d)) THEN
7693 WHERE (this%time < s_d)
7694 this%time = datetime_miss
7695 END WHERE
7696 ENDIF
7697ENDIF
7698
7699IF (PRESENT(e_d)) THEN
7701 WHERE (this%time > e_d)
7702 this%time = datetime_miss
7703 END WHERE
7704 ENDIF
7705ENDIF
7706
7707CALL vol7d_reform(this, miss=.true.)
7708
7709END SUBROUTINE vol7d_filter
7710
7711
7718SUBROUTINE vol7d_convr(this, that, anaconv)
7719TYPE(vol7d),INTENT(IN) :: this
7720TYPE(vol7d),INTENT(INOUT) :: that
7721LOGICAL,OPTIONAL,INTENT(in) :: anaconv
7722INTEGER :: i
7723LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
7724TYPE(vol7d) :: v7d_tmp
7725
7726IF (optio_log(anaconv)) THEN
7727 acp=fv
7728 acn=tv
7729ELSE
7730 acp=tv
7731 acn=fv
7732ENDIF
7733
7734! Volume con solo i dati reali e tutti gli attributi
7735! l'anagrafica e` copiata interamente se necessario
7736CALL vol7d_copy(this, that, &
7737 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7738 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7739
7740! Volume solo di dati double
7741CALL vol7d_copy(this, v7d_tmp, &
7742 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7743 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7744 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7745 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7746 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7747 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7748
7749! converto a dati reali
7750IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7751
7752 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7753! alloco i dati reali e vi trasferisco i double
7754 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7755 SIZE(v7d_tmp%volanad, 3)))
7756 DO i = 1, SIZE(v7d_tmp%anavar%d)
7757 v7d_tmp%volanar(:,i,:) = &
7758 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7759 ENDDO
7760 DEALLOCATE(v7d_tmp%volanad)
7761! trasferisco le variabili
7762 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7763 NULLIFY(v7d_tmp%anavar%d)
7764 ENDIF
7765
7766 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7767! alloco i dati reali e vi trasferisco i double
7768 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7769 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7770 SIZE(v7d_tmp%voldatid, 6)))
7771 DO i = 1, SIZE(v7d_tmp%dativar%d)
7772 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7773 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7774 ENDDO
7775 DEALLOCATE(v7d_tmp%voldatid)
7776! trasferisco le variabili
7777 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7778 NULLIFY(v7d_tmp%dativar%d)
7779 ENDIF
7780
7781! fondo con il volume definitivo
7782 CALL vol7d_merge(that, v7d_tmp)
7783ELSE
7785ENDIF
7786
7787
7788! Volume solo di dati interi
7789CALL vol7d_copy(this, v7d_tmp, &
7790 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7791 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7792 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7793 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7794 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7795 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7796
7797! converto a dati reali
7798IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7799
7800 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7801! alloco i dati reali e vi trasferisco gli interi
7802 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7803 SIZE(v7d_tmp%volanai, 3)))
7804 DO i = 1, SIZE(v7d_tmp%anavar%i)
7805 v7d_tmp%volanar(:,i,:) = &
7806 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7807 ENDDO
7808 DEALLOCATE(v7d_tmp%volanai)
7809! trasferisco le variabili
7810 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7811 NULLIFY(v7d_tmp%anavar%i)
7812 ENDIF
7813
7814 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7815! alloco i dati reali e vi trasferisco gli interi
7816 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7817 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7818 SIZE(v7d_tmp%voldatii, 6)))
7819 DO i = 1, SIZE(v7d_tmp%dativar%i)
7820 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7821 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7822 ENDDO
7823 DEALLOCATE(v7d_tmp%voldatii)
7824! trasferisco le variabili
7825 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7826 NULLIFY(v7d_tmp%dativar%i)
7827 ENDIF
7828
7829! fondo con il volume definitivo
7830 CALL vol7d_merge(that, v7d_tmp)
7831ELSE
7833ENDIF
7834
7835
7836! Volume solo di dati byte
7837CALL vol7d_copy(this, v7d_tmp, &
7838 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7839 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7840 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7841 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7842 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7843 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7844
7845! converto a dati reali
7846IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7847
7848 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7849! alloco i dati reali e vi trasferisco i byte
7850 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7851 SIZE(v7d_tmp%volanab, 3)))
7852 DO i = 1, SIZE(v7d_tmp%anavar%b)
7853 v7d_tmp%volanar(:,i,:) = &
7854 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7855 ENDDO
7856 DEALLOCATE(v7d_tmp%volanab)
7857! trasferisco le variabili
7858 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7859 NULLIFY(v7d_tmp%anavar%b)
7860 ENDIF
7861
7862 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7863! alloco i dati reali e vi trasferisco i byte
7864 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7865 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7866 SIZE(v7d_tmp%voldatib, 6)))
7867 DO i = 1, SIZE(v7d_tmp%dativar%b)
7868 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7869 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7870 ENDDO
7871 DEALLOCATE(v7d_tmp%voldatib)
7872! trasferisco le variabili
7873 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7874 NULLIFY(v7d_tmp%dativar%b)
7875 ENDIF
7876
7877! fondo con il volume definitivo
7878 CALL vol7d_merge(that, v7d_tmp)
7879ELSE
7881ENDIF
7882
7883
7884! Volume solo di dati character
7885CALL vol7d_copy(this, v7d_tmp, &
7886 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7887 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7888 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7889 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7890 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7891 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7892
7893! converto a dati reali
7894IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
7895
7896 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
7897! alloco i dati reali e vi trasferisco i character
7898 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
7899 SIZE(v7d_tmp%volanac, 3)))
7900 DO i = 1, SIZE(v7d_tmp%anavar%c)
7901 v7d_tmp%volanar(:,i,:) = &
7902 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
7903 ENDDO
7904 DEALLOCATE(v7d_tmp%volanac)
7905! trasferisco le variabili
7906 v7d_tmp%anavar%r => v7d_tmp%anavar%c
7907 NULLIFY(v7d_tmp%anavar%c)
7908 ENDIF
7909
7910 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
7911! alloco i dati reali e vi trasferisco i character
7912 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
7913 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
7914 SIZE(v7d_tmp%voldatic, 6)))
7915 DO i = 1, SIZE(v7d_tmp%dativar%c)
7916 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7917 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
7918 ENDDO
7919 DEALLOCATE(v7d_tmp%voldatic)
7920! trasferisco le variabili
7921 v7d_tmp%dativar%r => v7d_tmp%dativar%c
7922 NULLIFY(v7d_tmp%dativar%c)
7923 ENDIF
7924
7925! fondo con il volume definitivo
7926 CALL vol7d_merge(that, v7d_tmp)
7927ELSE
7929ENDIF
7930
7931END SUBROUTINE vol7d_convr
7932
7933
7937SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
7938TYPE(vol7d),INTENT(IN) :: this
7939TYPE(vol7d),INTENT(OUT) :: that
7940logical , optional, intent(in) :: data_only
7941logical , optional, intent(in) :: ana
7942logical :: ldata_only,lana
7943
7944IF (PRESENT(data_only)) THEN
7945 ldata_only = data_only
7946ELSE
7947 ldata_only = .false.
7948ENDIF
7949
7950IF (PRESENT(ana)) THEN
7951 lana = ana
7952ELSE
7953 lana = .false.
7954ENDIF
7955
7956
7957#undef VOL7D_POLY_ARRAY
7958#define VOL7D_POLY_ARRAY voldati
7959#include "vol7d_class_diff.F90"
7960#undef VOL7D_POLY_ARRAY
7961#define VOL7D_POLY_ARRAY voldatiattr
7962#include "vol7d_class_diff.F90"
7963#undef VOL7D_POLY_ARRAY
7964
7965if ( .not. ldata_only) then
7966
7967#define VOL7D_POLY_ARRAY volana
7968#include "vol7d_class_diff.F90"
7969#undef VOL7D_POLY_ARRAY
7970#define VOL7D_POLY_ARRAY volanaattr
7971#include "vol7d_class_diff.F90"
7972#undef VOL7D_POLY_ARRAY
7973
7974 if(lana)then
7975 where ( this%ana == that%ana )
7976 that%ana = vol7d_ana_miss
7977 end where
7978 end if
7979
7980end if
7981
7982
7983
7984END SUBROUTINE vol7d_diff_only
7985
7986
7987
7988! Creo le routine da ripetere per i vari tipi di dati di v7d
7989! tramite un template e il preprocessore
7990#undef VOL7D_POLY_TYPE
7991#undef VOL7D_POLY_TYPES
7992#define VOL7D_POLY_TYPE REAL
7993#define VOL7D_POLY_TYPES r
7994#include "vol7d_class_type_templ.F90"
7995#undef VOL7D_POLY_TYPE
7996#undef VOL7D_POLY_TYPES
7997#define VOL7D_POLY_TYPE DOUBLE PRECISION
7998#define VOL7D_POLY_TYPES d
7999#include "vol7d_class_type_templ.F90"
8000#undef VOL7D_POLY_TYPE
8001#undef VOL7D_POLY_TYPES
8002#define VOL7D_POLY_TYPE INTEGER
8003#define VOL7D_POLY_TYPES i
8004#include "vol7d_class_type_templ.F90"
8005#undef VOL7D_POLY_TYPE
8006#undef VOL7D_POLY_TYPES
8007#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
8008#define VOL7D_POLY_TYPES b
8009#include "vol7d_class_type_templ.F90"
8010#undef VOL7D_POLY_TYPE
8011#undef VOL7D_POLY_TYPES
8012#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
8013#define VOL7D_POLY_TYPES c
8014#include "vol7d_class_type_templ.F90"
8015
8016! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
8017! tramite un template e il preprocessore
8018#define VOL7D_SORT
8019#undef VOL7D_NO_ZERO_ALLOC
8020#undef VOL7D_POLY_TYPE
8021#define VOL7D_POLY_TYPE datetime
8022#include "vol7d_class_desc_templ.F90"
8023#undef VOL7D_POLY_TYPE
8024#define VOL7D_POLY_TYPE vol7d_timerange
8025#include "vol7d_class_desc_templ.F90"
8026#undef VOL7D_POLY_TYPE
8027#define VOL7D_POLY_TYPE vol7d_level
8028#include "vol7d_class_desc_templ.F90"
8029#undef VOL7D_SORT
8030#undef VOL7D_POLY_TYPE
8031#define VOL7D_POLY_TYPE vol7d_network
8032#include "vol7d_class_desc_templ.F90"
8033#undef VOL7D_POLY_TYPE
8034#define VOL7D_POLY_TYPE vol7d_ana
8035#include "vol7d_class_desc_templ.F90"
8036#define VOL7D_NO_ZERO_ALLOC
8037#undef VOL7D_POLY_TYPE
8038#define VOL7D_POLY_TYPE vol7d_var
8039#include "vol7d_class_desc_templ.F90"
8040
8050subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
8051
8052TYPE(vol7d),INTENT(IN) :: this
8053integer,optional,intent(inout) :: unit
8054character(len=*),intent(in),optional :: filename
8055character(len=*),intent(out),optional :: filename_auto
8056character(len=*),INTENT(IN),optional :: description
8057
8058integer :: lunit
8059character(len=254) :: ldescription,arg,lfilename
8060integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8061 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8062 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8063 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8064 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8065 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8066 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8067!integer :: im,id,iy
8068integer :: tarray(8)
8069logical :: opened,exist
8070
8071 nana=0
8072 ntime=0
8073 ntimerange=0
8074 nlevel=0
8075 nnetwork=0
8076 ndativarr=0
8077 ndativari=0
8078 ndativarb=0
8079 ndativard=0
8080 ndativarc=0
8081 ndatiattrr=0
8082 ndatiattri=0
8083 ndatiattrb=0
8084 ndatiattrd=0
8085 ndatiattrc=0
8086 ndativarattrr=0
8087 ndativarattri=0
8088 ndativarattrb=0
8089 ndativarattrd=0
8090 ndativarattrc=0
8091 nanavarr=0
8092 nanavari=0
8093 nanavarb=0
8094 nanavard=0
8095 nanavarc=0
8096 nanaattrr=0
8097 nanaattri=0
8098 nanaattrb=0
8099 nanaattrd=0
8100 nanaattrc=0
8101 nanavarattrr=0
8102 nanavarattri=0
8103 nanavarattrb=0
8104 nanavarattrd=0
8105 nanavarattrc=0
8106
8107
8108!call idate(im,id,iy)
8109call date_and_time(values=tarray)
8110call getarg(0,arg)
8111
8112if (present(description))then
8113 ldescription=description
8114else
8115 ldescription="Vol7d generated by: "//trim(arg)
8116end if
8117
8118if (.not. present(unit))then
8119 lunit=getunit()
8120else
8121 if (unit==0)then
8122 lunit=getunit()
8123 unit=lunit
8124 else
8125 lunit=unit
8126 end if
8127end if
8128
8129lfilename=trim(arg)//".v7d"
8131
8132if (present(filename))then
8133 if (filename /= "")then
8134 lfilename=filename
8135 end if
8136end if
8137
8138if (present(filename_auto))filename_auto=lfilename
8139
8140
8141inquire(unit=lunit,opened=opened)
8142if (.not. opened) then
8143! inquire(file=lfilename, EXIST=exist)
8144! IF (exist) THEN
8145! CALL l4f_log(L4F_FATAL, &
8146! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
8147! CALL raise_fatal_error()
8148! ENDIF
8149 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
8150 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8151end if
8152
8153if (associated(this%ana)) nana=size(this%ana)
8154if (associated(this%time)) ntime=size(this%time)
8155if (associated(this%timerange)) ntimerange=size(this%timerange)
8156if (associated(this%level)) nlevel=size(this%level)
8157if (associated(this%network)) nnetwork=size(this%network)
8158
8159if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
8160if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
8161if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
8162if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
8163if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
8164
8165if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
8166if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
8167if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
8168if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
8169if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
8170
8171if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
8172if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
8173if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
8174if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
8175if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
8176
8177if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
8178if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
8179if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
8180if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
8181if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
8182
8183if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
8184if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
8185if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
8186if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
8187if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
8188
8189if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
8190if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
8191if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
8192if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
8193if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
8194
8195write(unit=lunit)ldescription
8196write(unit=lunit)tarray
8197
8198write(unit=lunit)&
8199 nana, ntime, ntimerange, nlevel, nnetwork, &
8200 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8201 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8202 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8203 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8204 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8205 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8206 this%time_definition
8207
8208
8209!write(unit=lunit)this
8210
8211
8212!! prime 5 dimensioni
8215if (associated(this%level)) write(unit=lunit)this%level
8216if (associated(this%timerange)) write(unit=lunit)this%timerange
8217if (associated(this%network)) write(unit=lunit)this%network
8218
8219 !! 6a dimensione: variabile dell'anagrafica e dei dati
8220 !! con relativi attributi e in 5 tipi diversi
8221
8222if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
8223if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
8224if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
8225if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
8226if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
8227
8228if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
8229if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
8230if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
8231if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
8232if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
8233
8234if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
8235if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
8236if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
8237if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
8238if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
8239
8240if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
8241if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
8242if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
8243if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
8244if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
8245
8246if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
8247if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
8248if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
8249if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
8250if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
8251
8252if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
8253if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
8254if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
8255if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
8256if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
8257
8258!! Volumi di valori e attributi per anagrafica e dati
8259
8260if (associated(this%volanar)) write(unit=lunit)this%volanar
8261if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
8262if (associated(this%voldatir)) write(unit=lunit)this%voldatir
8263if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
8264
8265if (associated(this%volanai)) write(unit=lunit)this%volanai
8266if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
8267if (associated(this%voldatii)) write(unit=lunit)this%voldatii
8268if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
8269
8270if (associated(this%volanab)) write(unit=lunit)this%volanab
8271if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
8272if (associated(this%voldatib)) write(unit=lunit)this%voldatib
8273if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
8274
8275if (associated(this%volanad)) write(unit=lunit)this%volanad
8276if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
8277if (associated(this%voldatid)) write(unit=lunit)this%voldatid
8278if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
8279
8280if (associated(this%volanac)) write(unit=lunit)this%volanac
8281if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
8282if (associated(this%voldatic)) write(unit=lunit)this%voldatic
8283if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
8284
8285if (.not. present(unit)) close(unit=lunit)
8286
8287end subroutine vol7d_write_on_file
8288
8289
8296
8297
8298subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
8299
8300TYPE(vol7d),INTENT(OUT) :: this
8301integer,intent(inout),optional :: unit
8302character(len=*),INTENT(in),optional :: filename
8303character(len=*),intent(out),optional :: filename_auto
8304character(len=*),INTENT(out),optional :: description
8305integer,intent(out),optional :: tarray(8)
8306
8307
8308integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8309 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8310 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8311 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8312 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8313 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8314 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8315
8316character(len=254) :: ldescription,lfilename,arg
8317integer :: ltarray(8),lunit,ios
8318logical :: opened,exist
8319
8320
8321call getarg(0,arg)
8322
8323if (.not. present(unit))then
8324 lunit=getunit()
8325else
8326 if (unit==0)then
8327 lunit=getunit()
8328 unit=lunit
8329 else
8330 lunit=unit
8331 end if
8332end if
8333
8334lfilename=trim(arg)//".v7d"
8336
8337if (present(filename))then
8338 if (filename /= "")then
8339 lfilename=filename
8340 end if
8341end if
8342
8343if (present(filename_auto))filename_auto=lfilename
8344
8345
8346inquire(unit=lunit,opened=opened)
8347IF (.NOT. opened) THEN
8348 inquire(file=lfilename,exist=exist)
8349 IF (.NOT.exist) THEN
8350 CALL l4f_log(l4f_fatal, &
8351 'in vol7d_read_from_file, file does not exists, cannot open')
8352 CALL raise_fatal_error()
8353 ENDIF
8354 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
8355 status='OLD', action='READ')
8356 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8357end if
8358
8359
8361read(unit=lunit,iostat=ios)ldescription
8362
8363if (ios < 0) then ! A negative value indicates that the End of File or End of Record
8364 call vol7d_alloc (this)
8365 call vol7d_alloc_vol (this)
8366 if (present(description))description=ldescription
8367 if (present(tarray))tarray=ltarray
8368 if (.not. present(unit)) close(unit=lunit)
8369end if
8370
8371read(unit=lunit)ltarray
8372
8373CALL l4f_log(l4f_info, 'Reading vol7d from file')
8374CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
8377
8378if (present(description))description=ldescription
8379if (present(tarray))tarray=ltarray
8380
8381read(unit=lunit)&
8382 nana, ntime, ntimerange, nlevel, nnetwork, &
8383 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8384 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8385 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8386 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8387 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8388 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8389 this%time_definition
8390
8391call vol7d_alloc (this, &
8392 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
8393 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
8394 ndativard=ndativard, ndativarc=ndativarc,&
8395 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
8396 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
8397 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
8398 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
8399 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
8400 nanavard=nanavard, nanavarc=nanavarc,&
8401 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
8402 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
8403 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
8404 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
8405
8406
8409if (associated(this%level)) read(unit=lunit)this%level
8410if (associated(this%timerange)) read(unit=lunit)this%timerange
8411if (associated(this%network)) read(unit=lunit)this%network
8412
8413if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
8414if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
8415if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
8416if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
8417if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
8418
8419if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
8420if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
8421if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
8422if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
8423if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
8424
8425if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
8426if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
8427if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
8428if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
8429if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
8430
8431if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
8432if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
8433if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
8434if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
8435if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
8436
8437if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
8438if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
8439if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
8440if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
8441if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
8442
8443if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
8444if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
8445if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
8446if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
8447if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
8448
8449call vol7d_alloc_vol (this)
8450
8451!! Volumi di valori e attributi per anagrafica e dati
8452
8453if (associated(this%volanar)) read(unit=lunit)this%volanar
8454if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
8455if (associated(this%voldatir)) read(unit=lunit)this%voldatir
8456if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
8457
8458if (associated(this%volanai)) read(unit=lunit)this%volanai
8459if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
8460if (associated(this%voldatii)) read(unit=lunit)this%voldatii
8461if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
8462
8463if (associated(this%volanab)) read(unit=lunit)this%volanab
8464if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
8465if (associated(this%voldatib)) read(unit=lunit)this%voldatib
8466if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
8467
8468if (associated(this%volanad)) read(unit=lunit)this%volanad
8469if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
8470if (associated(this%voldatid)) read(unit=lunit)this%voldatid
8471if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
8472
8473if (associated(this%volanac)) read(unit=lunit)this%volanac
8474if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
8475if (associated(this%voldatic)) read(unit=lunit)this%voldatic
8476if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
8477
8478if (.not. present(unit)) close(unit=lunit)
8479
8480end subroutine vol7d_read_from_file
8481
8482
8483! to double precision
8484elemental doubleprecision function doubledatd(voldat,var)
8485doubleprecision,intent(in) :: voldat
8486type(vol7d_var),intent(in) :: var
8487
8488doubledatd=voldat
8489
8490end function doubledatd
8491
8492
8493elemental doubleprecision function doubledatr(voldat,var)
8494real,intent(in) :: voldat
8495type(vol7d_var),intent(in) :: var
8496
8498 doubledatr=dble(voldat)
8499else
8500 doubledatr=dmiss
8501end if
8502
8503end function doubledatr
8504
8505
8506elemental doubleprecision function doubledati(voldat,var)
8507integer,intent(in) :: voldat
8508type(vol7d_var),intent(in) :: var
8509
8512 doubledati=dble(voldat)/10.d0**var%scalefactor
8513 else
8514 doubledati=dble(voldat)
8515 endif
8516else
8517 doubledati=dmiss
8518end if
8519
8520end function doubledati
8521
8522
8523elemental doubleprecision function doubledatb(voldat,var)
8524integer(kind=int_b),intent(in) :: voldat
8525type(vol7d_var),intent(in) :: var
8526
8529 doubledatb=dble(voldat)/10.d0**var%scalefactor
8530 else
8531 doubledatb=dble(voldat)
8532 endif
8533else
8534 doubledatb=dmiss
8535end if
8536
8537end function doubledatb
8538
8539
8540elemental doubleprecision function doubledatc(voldat,var)
8541CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8542type(vol7d_var),intent(in) :: var
8543
8544doubledatc = c2d(voldat)
8546 doubledatc=doubledatc/10.d0**var%scalefactor
8547end if
8548
8549end function doubledatc
8550
8551
8552! to integer
8553elemental integer function integerdatd(voldat,var)
8554doubleprecision,intent(in) :: voldat
8555type(vol7d_var),intent(in) :: var
8556
8559 integerdatd=nint(voldat*10d0**var%scalefactor)
8560 else
8561 integerdatd=nint(voldat)
8562 endif
8563else
8564 integerdatd=imiss
8565end if
8566
8567end function integerdatd
8568
8569
8570elemental integer function integerdatr(voldat,var)
8571real,intent(in) :: voldat
8572type(vol7d_var),intent(in) :: var
8573
8576 integerdatr=nint(voldat*10d0**var%scalefactor)
8577 else
8578 integerdatr=nint(voldat)
8579 endif
8580else
8581 integerdatr=imiss
8582end if
8583
8584end function integerdatr
8585
8586
8587elemental integer function integerdati(voldat,var)
8588integer,intent(in) :: voldat
8589type(vol7d_var),intent(in) :: var
8590
8591integerdati=voldat
8592
8593end function integerdati
8594
8595
8596elemental integer function integerdatb(voldat,var)
8597integer(kind=int_b),intent(in) :: voldat
8598type(vol7d_var),intent(in) :: var
8599
8601 integerdatb=voldat
8602else
8603 integerdatb=imiss
8604end if
8605
8606end function integerdatb
8607
8608
8609elemental integer function integerdatc(voldat,var)
8610CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8611type(vol7d_var),intent(in) :: var
8612
8613integerdatc=c2i(voldat)
8614
8615end function integerdatc
8616
8617
8618! to real
8619elemental real function realdatd(voldat,var)
8620doubleprecision,intent(in) :: voldat
8621type(vol7d_var),intent(in) :: var
8622
8624 realdatd=real(voldat)
8625else
8626 realdatd=rmiss
8627end if
8628
8629end function realdatd
8630
8631
8632elemental real function realdatr(voldat,var)
8633real,intent(in) :: voldat
8634type(vol7d_var),intent(in) :: var
8635
8636realdatr=voldat
8637
8638end function realdatr
8639
8640
8641elemental real function realdati(voldat,var)
8642integer,intent(in) :: voldat
8643type(vol7d_var),intent(in) :: var
8644
8647 realdati=float(voldat)/10.**var%scalefactor
8648 else
8649 realdati=float(voldat)
8650 endif
8651else
8652 realdati=rmiss
8653end if
8654
8655end function realdati
8656
8657
8658elemental real function realdatb(voldat,var)
8659integer(kind=int_b),intent(in) :: voldat
8660type(vol7d_var),intent(in) :: var
8661
8664 realdatb=float(voldat)/10**var%scalefactor
8665 else
8666 realdatb=float(voldat)
8667 endif
8668else
8669 realdatb=rmiss
8670end if
8671
8672end function realdatb
8673
8674
8675elemental real function realdatc(voldat,var)
8676CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8677type(vol7d_var),intent(in) :: var
8678
8679realdatc=c2r(voldat)
8681 realdatc=realdatc/10.**var%scalefactor
8682end if
8683
8684end function realdatc
8685
8686
8692FUNCTION realanavol(this, var) RESULT(vol)
8693TYPE(vol7d),INTENT(in) :: this
8694TYPE(vol7d_var),INTENT(in) :: var
8695REAL :: vol(SIZE(this%ana),size(this%network))
8696
8697CHARACTER(len=1) :: dtype
8698INTEGER :: indvar
8699
8700dtype = cmiss
8701indvar = index(this%anavar, var, type=dtype)
8702
8703IF (indvar > 0) THEN
8704 SELECT CASE (dtype)
8705 CASE("d")
8706 vol = realdat(this%volanad(:,indvar,:), var)
8707 CASE("r")
8708 vol = this%volanar(:,indvar,:)
8709 CASE("i")
8710 vol = realdat(this%volanai(:,indvar,:), var)
8711 CASE("b")
8712 vol = realdat(this%volanab(:,indvar,:), var)
8713 CASE("c")
8714 vol = realdat(this%volanac(:,indvar,:), var)
8715 CASE default
8716 vol = rmiss
8717 END SELECT
8718ELSE
8719 vol = rmiss
8720ENDIF
8721
8722END FUNCTION realanavol
8723
8724
8730FUNCTION integeranavol(this, var) RESULT(vol)
8731TYPE(vol7d),INTENT(in) :: this
8732TYPE(vol7d_var),INTENT(in) :: var
8733INTEGER :: vol(SIZE(this%ana),size(this%network))
8734
8735CHARACTER(len=1) :: dtype
8736INTEGER :: indvar
8737
8738dtype = cmiss
8739indvar = index(this%anavar, var, type=dtype)
8740
8741IF (indvar > 0) THEN
8742 SELECT CASE (dtype)
8743 CASE("d")
8744 vol = integerdat(this%volanad(:,indvar,:), var)
8745 CASE("r")
8746 vol = integerdat(this%volanar(:,indvar,:), var)
8747 CASE("i")
8748 vol = this%volanai(:,indvar,:)
8749 CASE("b")
8750 vol = integerdat(this%volanab(:,indvar,:), var)
8751 CASE("c")
8752 vol = integerdat(this%volanac(:,indvar,:), var)
8753 CASE default
8754 vol = imiss
8755 END SELECT
8756ELSE
8757 vol = imiss
8758ENDIF
8759
8760END FUNCTION integeranavol
8761
8762
8768subroutine move_datac (v7d,&
8769 indana,indtime,indlevel,indtimerange,indnetwork,&
8770 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8771
8772TYPE(vol7d),intent(inout) :: v7d
8773
8774integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8775integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8776integer :: inddativar,inddativarattr
8777
8778
8779do inddativar=1,size(v7d%dativar%c)
8780
8782 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8783 ) then
8784
8785 ! dati
8786 v7d%voldatic &
8787 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8788 v7d%voldatic &
8789 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8790
8791
8792 ! attributi
8793 if (associated (v7d%dativarattr%i)) then
8794 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8795 if (inddativarattr > 0 ) then
8796 v7d%voldatiattri &
8797 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8798 v7d%voldatiattri &
8799 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8800 end if
8801 end if
8802
8803 if (associated (v7d%dativarattr%r)) then
8804 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8805 if (inddativarattr > 0 ) then
8806 v7d%voldatiattrr &
8807 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8808 v7d%voldatiattrr &
8809 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8810 end if
8811 end if
8812
8813 if (associated (v7d%dativarattr%d)) then
8814 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8815 if (inddativarattr > 0 ) then
8816 v7d%voldatiattrd &
8817 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8818 v7d%voldatiattrd &
8819 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8820 end if
8821 end if
8822
8823 if (associated (v7d%dativarattr%b)) then
8824 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8825 if (inddativarattr > 0 ) then
8826 v7d%voldatiattrb &
8827 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8828 v7d%voldatiattrb &
8829 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8830 end if
8831 end if
8832
8833 if (associated (v7d%dativarattr%c)) then
8834 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8835 if (inddativarattr > 0 ) then
8836 v7d%voldatiattrc &
8837 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8838 v7d%voldatiattrc &
8839 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8840 end if
8841 end if
8842
8843 end if
8844
8845end do
8846
8847end subroutine move_datac
8848
8854subroutine move_datar (v7d,&
8855 indana,indtime,indlevel,indtimerange,indnetwork,&
8856 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8857
8858TYPE(vol7d),intent(inout) :: v7d
8859
8860integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8861integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8862integer :: inddativar,inddativarattr
8863
8864
8865do inddativar=1,size(v7d%dativar%r)
8866
8868 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8869 ) then
8870
8871 ! dati
8872 v7d%voldatir &
8873 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8874 v7d%voldatir &
8875 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8876
8877
8878 ! attributi
8879 if (associated (v7d%dativarattr%i)) then
8880 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8881 if (inddativarattr > 0 ) then
8882 v7d%voldatiattri &
8883 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8884 v7d%voldatiattri &
8885 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8886 end if
8887 end if
8888
8889 if (associated (v7d%dativarattr%r)) then
8890 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
8891 if (inddativarattr > 0 ) then
8892 v7d%voldatiattrr &
8893 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8894 v7d%voldatiattrr &
8895 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8896 end if
8897 end if
8898
8899 if (associated (v7d%dativarattr%d)) then
8900 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
8901 if (inddativarattr > 0 ) then
8902 v7d%voldatiattrd &
8903 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8904 v7d%voldatiattrd &
8905 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8906 end if
8907 end if
8908
8909 if (associated (v7d%dativarattr%b)) then
8910 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
8911 if (inddativarattr > 0 ) then
8912 v7d%voldatiattrb &
8913 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8914 v7d%voldatiattrb &
8915 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8916 end if
8917 end if
8918
8919 if (associated (v7d%dativarattr%c)) then
8920 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
8921 if (inddativarattr > 0 ) then
8922 v7d%voldatiattrc &
8923 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8924 v7d%voldatiattrc &
8925 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8926 end if
8927 end if
8928
8929 end if
8930
8931end do
8932
8933end subroutine move_datar
8934
8935
8949subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
8950type(vol7d),intent(inout) :: v7din
8951type(vol7d),intent(out) :: v7dout
8952type(vol7d_level),intent(in),optional :: level(:)
8953type(vol7d_timerange),intent(in),optional :: timerange(:)
8954!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
8955!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
8956logical,intent(in),optional :: nostatproc
8957
8958integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
8959integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
8960type(vol7d_level) :: roundlevel(size(v7din%level))
8961type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
8962type(vol7d) :: v7d_tmp
8963
8964
8965nbin=0
8966
8967if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
8968if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
8969if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
8970if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
8971
8973
8974roundlevel=v7din%level
8975
8976if (present(level))then
8977 do ilevel = 1, size(v7din%level)
8978 if ((any(v7din%level(ilevel) .almosteq. level))) then
8979 roundlevel(ilevel)=level(1)
8980 end if
8981 end do
8982end if
8983
8984roundtimerange=v7din%timerange
8985
8986if (present(timerange))then
8987 do itimerange = 1, size(v7din%timerange)
8988 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
8989 roundtimerange(itimerange)=timerange(1)
8990 end if
8991 end do
8992end if
8993
8994!set istantaneous values everywere
8995!preserve p1 for forecast time
8996if (optio_log(nostatproc)) then
8997 roundtimerange(:)%timerange=254
8998 roundtimerange(:)%p2=0
8999end if
9000
9001
9002nana=size(v7din%ana)
9003nlevel=count_distinct(roundlevel,back=.true.)
9004ntime=size(v7din%time)
9005ntimerange=count_distinct(roundtimerange,back=.true.)
9006nnetwork=size(v7din%network)
9007
9009
9010if (nbin == 0) then
9012else
9013 call vol7d_convr(v7din,v7d_tmp)
9014end if
9015
9016v7d_tmp%level=roundlevel
9017v7d_tmp%timerange=roundtimerange
9018
9019do ilevel=1, size(v7d_tmp%level)
9020 indl=index(v7d_tmp%level,roundlevel(ilevel))
9021 do itimerange=1,size(v7d_tmp%timerange)
9022 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
9023
9024 if (indl /= ilevel .or. indt /= itimerange) then
9025
9026 do iana=1, nana
9027 do itime=1,ntime
9028 do inetwork=1,nnetwork
9029
9030 if (nbin > 0) then
9031 call move_datar (v7d_tmp,&
9032 iana,itime,ilevel,itimerange,inetwork,&
9033 iana,itime,indl,indt,inetwork)
9034 else
9035 call move_datac (v7d_tmp,&
9036 iana,itime,ilevel,itimerange,inetwork,&
9037 iana,itime,indl,indt,inetwork)
9038 end if
9039
9040 end do
9041 end do
9042 end do
9043
9044 end if
9045
9046 end do
9047end do
9048
9049! set to missing level and time > nlevel
9050do ilevel=nlevel+1,size(v7d_tmp%level)
9052end do
9053
9054do itimerange=ntimerange+1,size(v7d_tmp%timerange)
9056end do
9057
9058!copy with remove
9061
9062!call display(v7dout)
9063
9064end subroutine v7d_rounding
9065
9066
9068
9074
9075
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 |