libsim Versione 7.1.11

◆ vol7d_get_volanab()

subroutine vol7d_get_volanab ( 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 
)

Crea una vista a dimensione ridotta di un volume 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_volanab(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

Definizione alla linea 5574 del file vol7d_class.F90.

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

Generated with Doxygen.