libsim Versione 7.2.0

◆ vol7d_get_volanaattrb()

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

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
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d

Definizione alla linea 5620 del file vol7d_class.F90.

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

Generated with Doxygen.