libsim Versione 7.1.11
|
◆ vol7d_get_voldatiattrc()
Crea una vista a dimensione ridotta di un volume di attributi di dati di tipo CHARACTER(len=vol7d_cdatalen). È 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: CHARACTER(len=vol7d_cdatalen), POINTER :: vol2d(:,:)
...
CALL vol7d_get_voldatiattrc(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
ENDIF
return
Definizione alla linea 6411 del file vol7d_class.F90. 6413! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
6414! authors:
6415! Davide Cesari <dcesari@arpa.emr.it>
6416! Paolo Patruno <ppatruno@arpa.emr.it>
6417
6418! This program is free software; you can redistribute it and/or
6419! modify it under the terms of the GNU General Public License as
6420! published by the Free Software Foundation; either version 2 of
6421! the License, or (at your option) any later version.
6422
6423! This program is distributed in the hope that it will be useful,
6424! but WITHOUT ANY WARRANTY; without even the implied warranty of
6425! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
6426! GNU General Public License for more details.
6427
6428! You should have received a copy of the GNU General Public License
6429! along with this program. If not, see <http://www.gnu.org/licenses/>.
6430#include "config.h"
6431
6443
6511IMPLICIT NONE
6512
6513
6514INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
6515 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
6516
6517INTEGER, PARAMETER :: vol7d_ana_a=1
6518INTEGER, PARAMETER :: vol7d_var_a=2
6519INTEGER, PARAMETER :: vol7d_network_a=3
6520INTEGER, PARAMETER :: vol7d_attr_a=4
6521INTEGER, PARAMETER :: vol7d_ana_d=1
6522INTEGER, PARAMETER :: vol7d_time_d=2
6523INTEGER, PARAMETER :: vol7d_level_d=3
6524INTEGER, PARAMETER :: vol7d_timerange_d=4
6525INTEGER, PARAMETER :: vol7d_var_d=5
6526INTEGER, PARAMETER :: vol7d_network_d=6
6527INTEGER, PARAMETER :: vol7d_attr_d=7
6528INTEGER, PARAMETER :: vol7d_cdatalen=32
6529
6530TYPE vol7d_varmap
6531 INTEGER :: r, d, i, b, c
6532END TYPE vol7d_varmap
6533
6538 TYPE(vol7d_ana),POINTER :: ana(:)
6540 TYPE(datetime),POINTER :: time(:)
6542 TYPE(vol7d_level),POINTER :: level(:)
6544 TYPE(vol7d_timerange),POINTER :: timerange(:)
6546 TYPE(vol7d_network),POINTER :: network(:)
6548 TYPE(vol7d_varvect) :: anavar
6550 TYPE(vol7d_varvect) :: anaattr
6552 TYPE(vol7d_varvect) :: anavarattr
6554 TYPE(vol7d_varvect) :: dativar
6556 TYPE(vol7d_varvect) :: datiattr
6558 TYPE(vol7d_varvect) :: dativarattr
6559
6561 REAL,POINTER :: volanar(:,:,:)
6563 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
6565 INTEGER,POINTER :: volanai(:,:,:)
6567 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
6569 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
6570
6572 REAL,POINTER :: volanaattrr(:,:,:,:)
6574 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
6576 INTEGER,POINTER :: volanaattri(:,:,:,:)
6578 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
6580 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
6581
6583 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
6585 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
6587 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
6589 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
6591 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
6592
6594 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
6596 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
6598 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
6600 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
6602 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
6603
6605 integer :: time_definition
6606
6608
6613 MODULE PROCEDURE vol7d_init
6614END INTERFACE
6615
6618 MODULE PROCEDURE vol7d_delete
6619END INTERFACE
6620
6623 MODULE PROCEDURE vol7d_write_on_file
6624END INTERFACE
6625
6627INTERFACE import
6628 MODULE PROCEDURE vol7d_read_from_file
6629END INTERFACE
6630
6633 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
6634END INTERFACE
6635
6638 MODULE PROCEDURE to_char_dat
6639END INTERFACE
6640
6643 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
6644END INTERFACE
6645
6648 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
6649END INTERFACE
6650
6653 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
6654END INTERFACE
6655
6658 MODULE PROCEDURE vol7d_copy
6659END INTERFACE
6660
6663 MODULE PROCEDURE vol7d_c_e
6664END INTERFACE
6665
6670 MODULE PROCEDURE vol7d_check
6671END INTERFACE
6672
6687 MODULE PROCEDURE v7d_rounding
6688END INTERFACE
6689
6690!!$INTERFACE get_volana
6691!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
6692!!$ vol7d_get_volanab, vol7d_get_volanac
6693!!$END INTERFACE
6694!!$
6695!!$INTERFACE get_voldati
6696!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
6697!!$ vol7d_get_voldatib, vol7d_get_voldatic
6698!!$END INTERFACE
6699!!$
6700!!$INTERFACE get_volanaattr
6701!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
6702!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
6703!!$END INTERFACE
6704!!$
6705!!$INTERFACE get_voldatiattr
6706!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
6707!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
6708!!$END INTERFACE
6709
6710PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
6711 vol7d_get_volc, &
6712 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
6713 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
6714 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
6715 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
6716 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
6717 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
6718 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
6719 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
6720 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
6721 vol7d_display, dat_display, dat_vect_display, &
6722 to_char_dat, vol7d_check
6723
6724PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
6725
6726PRIVATE vol7d_c_e
6727
6728CONTAINS
6729
6730
6735SUBROUTINE vol7d_init(this,time_definition)
6736TYPE(vol7d),intent(out) :: this
6737integer,INTENT(IN),OPTIONAL :: time_definition
6738
6745CALL vol7d_var_features_init() ! initialise var features table once
6746
6747NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
6748
6749NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
6750NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
6751NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
6752NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
6753NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
6754
6755if(present(time_definition)) then
6756 this%time_definition=time_definition
6757else
6758 this%time_definition=1 !default to validity time
6759end if
6760
6761END SUBROUTINE vol7d_init
6762
6763
6767ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
6768TYPE(vol7d),intent(inout) :: this
6769LOGICAL, INTENT(in), OPTIONAL :: dataonly
6770
6771
6772IF (.NOT. optio_log(dataonly)) THEN
6773 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
6774 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
6775 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
6776 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
6777 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
6778 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
6779 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
6780 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
6781 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
6782 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
6783ENDIF
6784IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
6785IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
6786IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
6787IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
6788IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
6789IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
6790IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
6791IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
6792IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
6793IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
6794
6795IF (.NOT. optio_log(dataonly)) THEN
6796 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6797 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6798ENDIF
6799IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6800IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6801IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6802
6803IF (.NOT. optio_log(dataonly)) THEN
6807ENDIF
6811
6812END SUBROUTINE vol7d_delete
6813
6814
6815
6816integer function vol7d_check(this)
6817TYPE(vol7d),intent(in) :: this
6818integer :: i,j,k,l,m,n
6819
6820vol7d_check=0
6821
6822if (associated(this%voldatii)) then
6823do i = 1,size(this%voldatii,1)
6824 do j = 1,size(this%voldatii,2)
6825 do k = 1,size(this%voldatii,3)
6826 do l = 1,size(this%voldatii,4)
6827 do m = 1,size(this%voldatii,5)
6828 do n = 1,size(this%voldatii,6)
6829 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
6830 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
6832 vol7d_check=1
6833 end if
6834 end do
6835 end do
6836 end do
6837 end do
6838 end do
6839end do
6840end if
6841
6842
6843if (associated(this%voldatir)) then
6844do i = 1,size(this%voldatir,1)
6845 do j = 1,size(this%voldatir,2)
6846 do k = 1,size(this%voldatir,3)
6847 do l = 1,size(this%voldatir,4)
6848 do m = 1,size(this%voldatir,5)
6849 do n = 1,size(this%voldatir,6)
6850 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
6851 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
6853 vol7d_check=2
6854 end if
6855 end do
6856 end do
6857 end do
6858 end do
6859 end do
6860end do
6861end if
6862
6863if (associated(this%voldatid)) then
6864do i = 1,size(this%voldatid,1)
6865 do j = 1,size(this%voldatid,2)
6866 do k = 1,size(this%voldatid,3)
6867 do l = 1,size(this%voldatid,4)
6868 do m = 1,size(this%voldatid,5)
6869 do n = 1,size(this%voldatid,6)
6870 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
6871 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
6873 vol7d_check=3
6874 end if
6875 end do
6876 end do
6877 end do
6878 end do
6879 end do
6880end do
6881end if
6882
6883if (associated(this%voldatib)) then
6884do i = 1,size(this%voldatib,1)
6885 do j = 1,size(this%voldatib,2)
6886 do k = 1,size(this%voldatib,3)
6887 do l = 1,size(this%voldatib,4)
6888 do m = 1,size(this%voldatib,5)
6889 do n = 1,size(this%voldatib,6)
6890 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
6891 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
6893 vol7d_check=4
6894 end if
6895 end do
6896 end do
6897 end do
6898 end do
6899 end do
6900end do
6901end if
6902
6903end function vol7d_check
6904
6905
6906
6907!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
6909SUBROUTINE vol7d_display(this)
6910TYPE(vol7d),intent(in) :: this
6911integer :: i
6912
6913REAL :: rdat
6914DOUBLE PRECISION :: ddat
6915INTEGER :: idat
6916INTEGER(kind=int_b) :: bdat
6917CHARACTER(len=vol7d_cdatalen) :: cdat
6918
6919
6920print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
6921if (this%time_definition == 0) then
6922 print*,"TIME DEFINITION: time is reference time"
6923else if (this%time_definition == 1) then
6924 print*,"TIME DEFINITION: time is validity time"
6925else
6926 print*,"Time definition have a wrong walue:", this%time_definition
6927end if
6928
6929IF (ASSOCIATED(this%network))then
6930 print*,"---- network vector ----"
6931 print*,"elements=",size(this%network)
6932 do i=1, size(this%network)
6934 end do
6935end IF
6936
6937IF (ASSOCIATED(this%ana))then
6938 print*,"---- ana vector ----"
6939 print*,"elements=",size(this%ana)
6940 do i=1, size(this%ana)
6942 end do
6943end IF
6944
6945IF (ASSOCIATED(this%time))then
6946 print*,"---- time vector ----"
6947 print*,"elements=",size(this%time)
6948 do i=1, size(this%time)
6950 end do
6951end if
6952
6953IF (ASSOCIATED(this%level)) then
6954 print*,"---- level vector ----"
6955 print*,"elements=",size(this%level)
6956 do i =1,size(this%level)
6958 end do
6959end if
6960
6961IF (ASSOCIATED(this%timerange))then
6962 print*,"---- timerange vector ----"
6963 print*,"elements=",size(this%timerange)
6964 do i =1,size(this%timerange)
6966 end do
6967end if
6968
6969
6970print*,"---- ana vector ----"
6971print*,""
6972print*,"->>>>>>>>> anavar -"
6974print*,""
6975print*,"->>>>>>>>> anaattr -"
6977print*,""
6978print*,"->>>>>>>>> anavarattr -"
6980
6981print*,"-- ana data section (first point) --"
6982
6983idat=imiss
6984rdat=rmiss
6985ddat=dmiss
6986bdat=ibmiss
6987cdat=cmiss
6988
6989!ntime = MIN(SIZE(this%time),nprint)
6990!ntimerange = MIN(SIZE(this%timerange),nprint)
6991!nlevel = MIN(SIZE(this%level),nprint)
6992!nnetwork = MIN(SIZE(this%network),nprint)
6993!nana = MIN(SIZE(this%ana),nprint)
6994
6995IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
6996if (associated(this%volanai)) then
6997 do i=1,size(this%anavar%i)
6998 idat=this%volanai(1,i,1)
7000 end do
7001end if
7002idat=imiss
7003
7004if (associated(this%volanar)) then
7005 do i=1,size(this%anavar%r)
7006 rdat=this%volanar(1,i,1)
7008 end do
7009end if
7010rdat=rmiss
7011
7012if (associated(this%volanad)) then
7013 do i=1,size(this%anavar%d)
7014 ddat=this%volanad(1,i,1)
7016 end do
7017end if
7018ddat=dmiss
7019
7020if (associated(this%volanab)) then
7021 do i=1,size(this%anavar%b)
7022 bdat=this%volanab(1,i,1)
7024 end do
7025end if
7026bdat=ibmiss
7027
7028if (associated(this%volanac)) then
7029 do i=1,size(this%anavar%c)
7030 cdat=this%volanac(1,i,1)
7032 end do
7033end if
7034cdat=cmiss
7035ENDIF
7036
7037print*,"---- data vector ----"
7038print*,""
7039print*,"->>>>>>>>> dativar -"
7041print*,""
7042print*,"->>>>>>>>> datiattr -"
7044print*,""
7045print*,"->>>>>>>>> dativarattr -"
7047
7048print*,"-- data data section (first point) --"
7049
7050idat=imiss
7051rdat=rmiss
7052ddat=dmiss
7053bdat=ibmiss
7054cdat=cmiss
7055
7056IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
7057 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
7058if (associated(this%voldatii)) then
7059 do i=1,size(this%dativar%i)
7060 idat=this%voldatii(1,1,1,1,i,1)
7062 end do
7063end if
7064idat=imiss
7065
7066if (associated(this%voldatir)) then
7067 do i=1,size(this%dativar%r)
7068 rdat=this%voldatir(1,1,1,1,i,1)
7070 end do
7071end if
7072rdat=rmiss
7073
7074if (associated(this%voldatid)) then
7075 do i=1,size(this%dativar%d)
7076 ddat=this%voldatid(1,1,1,1,i,1)
7078 end do
7079end if
7080ddat=dmiss
7081
7082if (associated(this%voldatib)) then
7083 do i=1,size(this%dativar%b)
7084 bdat=this%voldatib(1,1,1,1,i,1)
7086 end do
7087end if
7088bdat=ibmiss
7089
7090if (associated(this%voldatic)) then
7091 do i=1,size(this%dativar%c)
7092 cdat=this%voldatic(1,1,1,1,i,1)
7094 end do
7095end if
7096cdat=cmiss
7097ENDIF
7098
7099print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
7100
7101END SUBROUTINE vol7d_display
7102
7103
7105SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
7106TYPE(vol7d_var),intent(in) :: this
7108REAL :: rdat
7110DOUBLE PRECISION :: ddat
7112INTEGER :: idat
7114INTEGER(kind=int_b) :: bdat
7116CHARACTER(len=*) :: cdat
7117
7118print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
7119
7120end SUBROUTINE dat_display
7121
7123SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
7124
7125TYPE(vol7d_var),intent(in) :: this(:)
7127REAL :: rdat(:)
7129DOUBLE PRECISION :: ddat(:)
7131INTEGER :: idat(:)
7133INTEGER(kind=int_b) :: bdat(:)
7135CHARACTER(len=*):: cdat(:)
7136
7137integer :: i
7138
7139do i =1,size(this)
7141end do
7142
7143end SUBROUTINE dat_vect_display
7144
7145
7146FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
7147#ifdef HAVE_DBALLE
7148USE dballef
7149#endif
7150TYPE(vol7d_var),INTENT(in) :: this
7152REAL :: rdat
7154DOUBLE PRECISION :: ddat
7156INTEGER :: idat
7158INTEGER(kind=int_b) :: bdat
7160CHARACTER(len=*) :: cdat
7161CHARACTER(len=80) :: to_char_dat
7162
7163CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
7164
7165
7166#ifdef HAVE_DBALLE
7167INTEGER :: handle, ier
7168
7169handle = 0
7170to_char_dat="VALUE: "
7171
7176
7178 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
7179 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
7180 ier = idba_fatto(handle)
7181 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
7182endif
7183
7184#else
7185
7186to_char_dat="VALUE: "
7192
7193#endif
7194
7195END FUNCTION to_char_dat
7196
7197
7200FUNCTION vol7d_c_e(this) RESULT(c_e)
7201TYPE(vol7d), INTENT(in) :: this
7202
7203LOGICAL :: c_e
7204
7206 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
7207 ASSOCIATED(this%network) .OR. &
7208 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
7209 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
7210 ASSOCIATED(this%anavar%c) .OR. &
7211 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
7212 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
7213 ASSOCIATED(this%anaattr%c) .OR. &
7214 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
7215 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
7216 ASSOCIATED(this%dativar%c) .OR. &
7217 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
7218 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
7219 ASSOCIATED(this%datiattr%c)
7220
7221END FUNCTION vol7d_c_e
7222
7223
7262SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
7263 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
7264 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
7265 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
7266 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
7267 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
7268 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
7269 ini)
7270TYPE(vol7d),INTENT(inout) :: this
7271INTEGER,INTENT(in),OPTIONAL :: nana
7272INTEGER,INTENT(in),OPTIONAL :: ntime
7273INTEGER,INTENT(in),OPTIONAL :: nlevel
7274INTEGER,INTENT(in),OPTIONAL :: ntimerange
7275INTEGER,INTENT(in),OPTIONAL :: nnetwork
7277INTEGER,INTENT(in),OPTIONAL :: &
7278 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
7279 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
7280 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
7281 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
7282 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
7283 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
7284LOGICAL,INTENT(in),OPTIONAL :: ini
7285
7286INTEGER :: i
7287LOGICAL :: linit
7288
7289IF (PRESENT(ini)) THEN
7290 linit = ini
7291ELSE
7292 linit = .false.
7293ENDIF
7294
7295! Dimensioni principali
7296IF (PRESENT(nana)) THEN
7297 IF (nana >= 0) THEN
7298 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
7299 ALLOCATE(this%ana(nana))
7300 IF (linit) THEN
7301 DO i = 1, nana
7303 ENDDO
7304 ENDIF
7305 ENDIF
7306ENDIF
7307IF (PRESENT(ntime)) THEN
7308 IF (ntime >= 0) THEN
7309 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
7310 ALLOCATE(this%time(ntime))
7311 IF (linit) THEN
7312 DO i = 1, ntime
7314 ENDDO
7315 ENDIF
7316 ENDIF
7317ENDIF
7318IF (PRESENT(nlevel)) THEN
7319 IF (nlevel >= 0) THEN
7320 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
7321 ALLOCATE(this%level(nlevel))
7322 IF (linit) THEN
7323 DO i = 1, nlevel
7325 ENDDO
7326 ENDIF
7327 ENDIF
7328ENDIF
7329IF (PRESENT(ntimerange)) THEN
7330 IF (ntimerange >= 0) THEN
7331 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
7332 ALLOCATE(this%timerange(ntimerange))
7333 IF (linit) THEN
7334 DO i = 1, ntimerange
7336 ENDDO
7337 ENDIF
7338 ENDIF
7339ENDIF
7340IF (PRESENT(nnetwork)) THEN
7341 IF (nnetwork >= 0) THEN
7342 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
7343 ALLOCATE(this%network(nnetwork))
7344 IF (linit) THEN
7345 DO i = 1, nnetwork
7347 ENDDO
7348 ENDIF
7349 ENDIF
7350ENDIF
7351! Dimensioni dei tipi delle variabili
7352CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
7353 nanavari, nanavarb, nanavarc, ini)
7354CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
7355 nanaattri, nanaattrb, nanaattrc, ini)
7356CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
7357 nanavarattri, nanavarattrb, nanavarattrc, ini)
7358CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
7359 ndativari, ndativarb, ndativarc, ini)
7360CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
7361 ndatiattri, ndatiattrb, ndatiattrc, ini)
7362CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
7363 ndativarattri, ndativarattrb, ndativarattrc, ini)
7364
7365END SUBROUTINE vol7d_alloc
7366
7367
7368FUNCTION vol7d_check_alloc_ana(this)
7369TYPE(vol7d),INTENT(in) :: this
7370LOGICAL :: vol7d_check_alloc_ana
7371
7372vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
7373
7374END FUNCTION vol7d_check_alloc_ana
7375
7376SUBROUTINE vol7d_force_alloc_ana(this, ini)
7377TYPE(vol7d),INTENT(inout) :: this
7378LOGICAL,INTENT(in),OPTIONAL :: ini
7379
7380! Alloco i descrittori minimi per avere un volume di anagrafica
7381IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
7382IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
7383
7384END SUBROUTINE vol7d_force_alloc_ana
7385
7386
7387FUNCTION vol7d_check_alloc_dati(this)
7388TYPE(vol7d),INTENT(in) :: this
7389LOGICAL :: vol7d_check_alloc_dati
7390
7391vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
7392 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
7393 ASSOCIATED(this%timerange)
7394
7395END FUNCTION vol7d_check_alloc_dati
7396
7397SUBROUTINE vol7d_force_alloc_dati(this, ini)
7398TYPE(vol7d),INTENT(inout) :: this
7399LOGICAL,INTENT(in),OPTIONAL :: ini
7400
7401! Alloco i descrittori minimi per avere un volume di dati
7402CALL vol7d_force_alloc_ana(this, ini)
7403IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
7404IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
7405IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
7406
7407END SUBROUTINE vol7d_force_alloc_dati
7408
7409
7410SUBROUTINE vol7d_force_alloc(this)
7411TYPE(vol7d),INTENT(inout) :: this
7412
7413! If anything really not allocated yet, allocate with size 0
7414IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
7415IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
7416IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
7417IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
7418IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
7419
7420END SUBROUTINE vol7d_force_alloc
7421
7422
7423FUNCTION vol7d_check_vol(this)
7424TYPE(vol7d),INTENT(in) :: this
7425LOGICAL :: vol7d_check_vol
7426
7427vol7d_check_vol = c_e(this)
7428
7429! Anagrafica
7430IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
7431 vol7d_check_vol = .false.
7432ENDIF
7433
7434IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
7435 vol7d_check_vol = .false.
7436ENDIF
7437
7438IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
7439 vol7d_check_vol = .false.
7440ENDIF
7441
7442IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
7443 vol7d_check_vol = .false.
7444ENDIF
7445
7446IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
7447 vol7d_check_vol = .false.
7448ENDIF
7449IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
7450 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
7451 ASSOCIATED(this%anavar%c)) THEN
7452 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
7453ENDIF
7454
7455! Attributi dell'anagrafica
7456IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
7457 .NOT.ASSOCIATED(this%volanaattrr)) THEN
7458 vol7d_check_vol = .false.
7459ENDIF
7460
7461IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
7462 .NOT.ASSOCIATED(this%volanaattrd)) THEN
7463 vol7d_check_vol = .false.
7464ENDIF
7465
7466IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
7467 .NOT.ASSOCIATED(this%volanaattri)) THEN
7468 vol7d_check_vol = .false.
7469ENDIF
7470
7471IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
7472 .NOT.ASSOCIATED(this%volanaattrb)) THEN
7473 vol7d_check_vol = .false.
7474ENDIF
7475
7476IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
7477 .NOT.ASSOCIATED(this%volanaattrc)) THEN
7478 vol7d_check_vol = .false.
7479ENDIF
7480
7481! Dati
7482IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
7483 vol7d_check_vol = .false.
7484ENDIF
7485
7486IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
7487 vol7d_check_vol = .false.
7488ENDIF
7489
7490IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
7491 vol7d_check_vol = .false.
7492ENDIF
7493
7494IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
7495 vol7d_check_vol = .false.
7496ENDIF
7497
7498IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
7499 vol7d_check_vol = .false.
7500ENDIF
7501
7502! Attributi dei dati
7503IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
7504 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
7505 vol7d_check_vol = .false.
7506ENDIF
7507
7508IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
7509 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
7510 vol7d_check_vol = .false.
7511ENDIF
7512
7513IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
7514 .NOT.ASSOCIATED(this%voldatiattri)) THEN
7515 vol7d_check_vol = .false.
7516ENDIF
7517
7518IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
7519 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
7520 vol7d_check_vol = .false.
7521ENDIF
7522
7523IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
7524 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
7525 vol7d_check_vol = .false.
7526ENDIF
7527IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
7528 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
7529 ASSOCIATED(this%dativar%c)) THEN
7530 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
7531ENDIF
7532
7533END FUNCTION vol7d_check_vol
7534
7535
7550SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
7551TYPE(vol7d),INTENT(inout) :: this
7552LOGICAL,INTENT(in),OPTIONAL :: ini
7553LOGICAL,INTENT(in),OPTIONAL :: inivol
7554
7555LOGICAL :: linivol
7556
7557IF (PRESENT(inivol)) THEN
7558 linivol = inivol
7559ELSE
7560 linivol = .true.
7561ENDIF
7562
7563! Anagrafica
7564IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
7565 CALL vol7d_force_alloc_ana(this, ini)
7566 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
7567 IF (linivol) this%volanar(:,:,:) = rmiss
7568ENDIF
7569
7570IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
7571 CALL vol7d_force_alloc_ana(this, ini)
7572 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
7573 IF (linivol) this%volanad(:,:,:) = rdmiss
7574ENDIF
7575
7576IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
7577 CALL vol7d_force_alloc_ana(this, ini)
7578 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
7579 IF (linivol) this%volanai(:,:,:) = imiss
7580ENDIF
7581
7582IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
7583 CALL vol7d_force_alloc_ana(this, ini)
7584 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
7585 IF (linivol) this%volanab(:,:,:) = ibmiss
7586ENDIF
7587
7588IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
7589 CALL vol7d_force_alloc_ana(this, ini)
7590 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
7591 IF (linivol) this%volanac(:,:,:) = cmiss
7592ENDIF
7593
7594! Attributi dell'anagrafica
7595IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
7596 .NOT.ASSOCIATED(this%volanaattrr)) THEN
7597 CALL vol7d_force_alloc_ana(this, ini)
7598 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
7599 SIZE(this%network), SIZE(this%anaattr%r)))
7600 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
7601ENDIF
7602
7603IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
7604 .NOT.ASSOCIATED(this%volanaattrd)) THEN
7605 CALL vol7d_force_alloc_ana(this, ini)
7606 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
7607 SIZE(this%network), SIZE(this%anaattr%d)))
7608 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
7609ENDIF
7610
7611IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
7612 .NOT.ASSOCIATED(this%volanaattri)) THEN
7613 CALL vol7d_force_alloc_ana(this, ini)
7614 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
7615 SIZE(this%network), SIZE(this%anaattr%i)))
7616 IF (linivol) this%volanaattri(:,:,:,:) = imiss
7617ENDIF
7618
7619IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
7620 .NOT.ASSOCIATED(this%volanaattrb)) THEN
7621 CALL vol7d_force_alloc_ana(this, ini)
7622 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
7623 SIZE(this%network), SIZE(this%anaattr%b)))
7624 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
7625ENDIF
7626
7627IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
7628 .NOT.ASSOCIATED(this%volanaattrc)) THEN
7629 CALL vol7d_force_alloc_ana(this, ini)
7630 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
7631 SIZE(this%network), SIZE(this%anaattr%c)))
7632 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
7633ENDIF
7634
7635! Dati
7636IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
7637 CALL vol7d_force_alloc_dati(this, ini)
7638 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7639 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
7640 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
7641ENDIF
7642
7643IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
7644 CALL vol7d_force_alloc_dati(this, ini)
7645 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7646 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
7647 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
7648ENDIF
7649
7650IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
7651 CALL vol7d_force_alloc_dati(this, ini)
7652 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7653 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
7654 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
7655ENDIF
7656
7657IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
7658 CALL vol7d_force_alloc_dati(this, ini)
7659 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7660 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
7661 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
7662ENDIF
7663
7664IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
7665 CALL vol7d_force_alloc_dati(this, ini)
7666 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7667 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
7668 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
7669ENDIF
7670
7671! Attributi dei dati
7672IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
7673 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
7674 CALL vol7d_force_alloc_dati(this, ini)
7675 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7676 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
7677 SIZE(this%datiattr%r)))
7678 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
7679ENDIF
7680
7681IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
7682 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
7683 CALL vol7d_force_alloc_dati(this, ini)
7684 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7685 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
7686 SIZE(this%datiattr%d)))
7687 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
7688ENDIF
7689
7690IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
7691 .NOT.ASSOCIATED(this%voldatiattri)) THEN
7692 CALL vol7d_force_alloc_dati(this, ini)
7693 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7694 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
7695 SIZE(this%datiattr%i)))
7696 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
7697ENDIF
7698
7699IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
7700 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
7701 CALL vol7d_force_alloc_dati(this, ini)
7702 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7703 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
7704 SIZE(this%datiattr%b)))
7705 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
7706ENDIF
7707
7708IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
7709 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
7710 CALL vol7d_force_alloc_dati(this, ini)
7711 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7712 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
7713 SIZE(this%datiattr%c)))
7714 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
7715ENDIF
7716
7717! Catch-all method
7718CALL vol7d_force_alloc(this)
7719
7720! Creo gli indici var-attr
7721
7722#ifdef DEBUG
7723CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
7724#endif
7725
7726CALL vol7d_set_attr_ind(this)
7727
7728
7729
7730END SUBROUTINE vol7d_alloc_vol
7731
7732
7739SUBROUTINE vol7d_set_attr_ind(this)
7740TYPE(vol7d),INTENT(inout) :: this
7741
7742INTEGER :: i
7743
7744! real
7745IF (ASSOCIATED(this%dativar%r)) THEN
7746 IF (ASSOCIATED(this%dativarattr%r)) THEN
7747 DO i = 1, SIZE(this%dativar%r)
7748 this%dativar%r(i)%r = &
7749 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
7750 ENDDO
7751 ENDIF
7752
7753 IF (ASSOCIATED(this%dativarattr%d)) THEN
7754 DO i = 1, SIZE(this%dativar%r)
7755 this%dativar%r(i)%d = &
7756 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
7757 ENDDO
7758 ENDIF
7759
7760 IF (ASSOCIATED(this%dativarattr%i)) THEN
7761 DO i = 1, SIZE(this%dativar%r)
7762 this%dativar%r(i)%i = &
7763 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
7764 ENDDO
7765 ENDIF
7766
7767 IF (ASSOCIATED(this%dativarattr%b)) THEN
7768 DO i = 1, SIZE(this%dativar%r)
7769 this%dativar%r(i)%b = &
7770 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
7771 ENDDO
7772 ENDIF
7773
7774 IF (ASSOCIATED(this%dativarattr%c)) THEN
7775 DO i = 1, SIZE(this%dativar%r)
7776 this%dativar%r(i)%c = &
7777 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
7778 ENDDO
7779 ENDIF
7780ENDIF
7781! double
7782IF (ASSOCIATED(this%dativar%d)) THEN
7783 IF (ASSOCIATED(this%dativarattr%r)) THEN
7784 DO i = 1, SIZE(this%dativar%d)
7785 this%dativar%d(i)%r = &
7786 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
7787 ENDDO
7788 ENDIF
7789
7790 IF (ASSOCIATED(this%dativarattr%d)) THEN
7791 DO i = 1, SIZE(this%dativar%d)
7792 this%dativar%d(i)%d = &
7793 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
7794 ENDDO
7795 ENDIF
7796
7797 IF (ASSOCIATED(this%dativarattr%i)) THEN
7798 DO i = 1, SIZE(this%dativar%d)
7799 this%dativar%d(i)%i = &
7800 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
7801 ENDDO
7802 ENDIF
7803
7804 IF (ASSOCIATED(this%dativarattr%b)) THEN
7805 DO i = 1, SIZE(this%dativar%d)
7806 this%dativar%d(i)%b = &
7807 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
7808 ENDDO
7809 ENDIF
7810
7811 IF (ASSOCIATED(this%dativarattr%c)) THEN
7812 DO i = 1, SIZE(this%dativar%d)
7813 this%dativar%d(i)%c = &
7814 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
7815 ENDDO
7816 ENDIF
7817ENDIF
7818! integer
7819IF (ASSOCIATED(this%dativar%i)) THEN
7820 IF (ASSOCIATED(this%dativarattr%r)) THEN
7821 DO i = 1, SIZE(this%dativar%i)
7822 this%dativar%i(i)%r = &
7823 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
7824 ENDDO
7825 ENDIF
7826
7827 IF (ASSOCIATED(this%dativarattr%d)) THEN
7828 DO i = 1, SIZE(this%dativar%i)
7829 this%dativar%i(i)%d = &
7830 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
7831 ENDDO
7832 ENDIF
7833
7834 IF (ASSOCIATED(this%dativarattr%i)) THEN
7835 DO i = 1, SIZE(this%dativar%i)
7836 this%dativar%i(i)%i = &
7837 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
7838 ENDDO
7839 ENDIF
7840
7841 IF (ASSOCIATED(this%dativarattr%b)) THEN
7842 DO i = 1, SIZE(this%dativar%i)
7843 this%dativar%i(i)%b = &
7844 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
7845 ENDDO
7846 ENDIF
7847
7848 IF (ASSOCIATED(this%dativarattr%c)) THEN
7849 DO i = 1, SIZE(this%dativar%i)
7850 this%dativar%i(i)%c = &
7851 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
7852 ENDDO
7853 ENDIF
7854ENDIF
7855! byte
7856IF (ASSOCIATED(this%dativar%b)) THEN
7857 IF (ASSOCIATED(this%dativarattr%r)) THEN
7858 DO i = 1, SIZE(this%dativar%b)
7859 this%dativar%b(i)%r = &
7860 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
7861 ENDDO
7862 ENDIF
7863
7864 IF (ASSOCIATED(this%dativarattr%d)) THEN
7865 DO i = 1, SIZE(this%dativar%b)
7866 this%dativar%b(i)%d = &
7867 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
7868 ENDDO
7869 ENDIF
7870
7871 IF (ASSOCIATED(this%dativarattr%i)) THEN
7872 DO i = 1, SIZE(this%dativar%b)
7873 this%dativar%b(i)%i = &
7874 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
7875 ENDDO
7876 ENDIF
7877
7878 IF (ASSOCIATED(this%dativarattr%b)) THEN
7879 DO i = 1, SIZE(this%dativar%b)
7880 this%dativar%b(i)%b = &
7881 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
7882 ENDDO
7883 ENDIF
7884
7885 IF (ASSOCIATED(this%dativarattr%c)) THEN
7886 DO i = 1, SIZE(this%dativar%b)
7887 this%dativar%b(i)%c = &
7888 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
7889 ENDDO
7890 ENDIF
7891ENDIF
7892! character
7893IF (ASSOCIATED(this%dativar%c)) THEN
7894 IF (ASSOCIATED(this%dativarattr%r)) THEN
7895 DO i = 1, SIZE(this%dativar%c)
7896 this%dativar%c(i)%r = &
7897 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
7898 ENDDO
7899 ENDIF
7900
7901 IF (ASSOCIATED(this%dativarattr%d)) THEN
7902 DO i = 1, SIZE(this%dativar%c)
7903 this%dativar%c(i)%d = &
7904 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
7905 ENDDO
7906 ENDIF
7907
7908 IF (ASSOCIATED(this%dativarattr%i)) THEN
7909 DO i = 1, SIZE(this%dativar%c)
7910 this%dativar%c(i)%i = &
7911 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
7912 ENDDO
7913 ENDIF
7914
7915 IF (ASSOCIATED(this%dativarattr%b)) THEN
7916 DO i = 1, SIZE(this%dativar%c)
7917 this%dativar%c(i)%b = &
7918 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
7919 ENDDO
7920 ENDIF
7921
7922 IF (ASSOCIATED(this%dativarattr%c)) THEN
7923 DO i = 1, SIZE(this%dativar%c)
7924 this%dativar%c(i)%c = &
7925 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
7926 ENDDO
7927 ENDIF
7928ENDIF
7929
7930END SUBROUTINE vol7d_set_attr_ind
7931
7932
7937SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
7938 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7939TYPE(vol7d),INTENT(INOUT) :: this
7940TYPE(vol7d),INTENT(INOUT) :: that
7941LOGICAL,INTENT(IN),OPTIONAL :: sort
7942LOGICAL,INTENT(in),OPTIONAL :: bestdata
7943LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
7944
7945TYPE(vol7d) :: v7d_clean
7946
7947
7949 this = that
7951 that = v7d_clean ! destroy that without deallocating
7952ELSE ! Append that to this and destroy that
7954 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7956ENDIF
7957
7958END SUBROUTINE vol7d_merge
7959
7960
7989SUBROUTINE vol7d_append(this, that, sort, bestdata, &
7990 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
7991TYPE(vol7d),INTENT(INOUT) :: this
7992TYPE(vol7d),INTENT(IN) :: that
7993LOGICAL,INTENT(IN),OPTIONAL :: sort
7994! experimental, please do not use outside the library now, they force the use
7995! of a simplified mapping algorithm which is valid only whene the dimension
7996! content is the same in both volumes , or when one of them is empty
7997LOGICAL,INTENT(in),OPTIONAL :: bestdata
7998LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
7999
8000
8001TYPE(vol7d) :: v7dtmp
8002LOGICAL :: lsort, lbestdata
8003INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
8004 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
8005
8007IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
8010 RETURN
8011ENDIF
8012
8013IF (this%time_definition /= that%time_definition) THEN
8014 CALL l4f_log(l4f_fatal, &
8015 'in vol7d_append, cannot append volumes with different &
8016 &time definition')
8017 CALL raise_fatal_error()
8018ENDIF
8019
8020! Completo l'allocazione per avere volumi a norma
8021CALL vol7d_alloc_vol(this)
8022
8026
8027! Calcolo le mappature tra volumi vecchi e volume nuovo
8028! I puntatori remap* vengono tutti o allocati o nullificati
8029IF (optio_log(ltimesimple)) THEN
8030 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
8031 lsort, remapt1, remapt2)
8032ELSE
8033 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
8034 lsort, remapt1, remapt2)
8035ENDIF
8036IF (optio_log(ltimerangesimple)) THEN
8037 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
8038 v7dtmp%timerange, lsort, remaptr1, remaptr2)
8039ELSE
8040 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
8041 v7dtmp%timerange, lsort, remaptr1, remaptr2)
8042ENDIF
8043IF (optio_log(llevelsimple)) THEN
8044 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
8045 lsort, remapl1, remapl2)
8046ELSE
8047 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
8048 lsort, remapl1, remapl2)
8049ENDIF
8050IF (optio_log(lanasimple)) THEN
8051 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
8052 .false., remapa1, remapa2)
8053ELSE
8054 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
8055 .false., remapa1, remapa2)
8056ENDIF
8057IF (optio_log(lnetworksimple)) THEN
8058 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
8059 .false., remapn1, remapn2)
8060ELSE
8061 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
8062 .false., remapn1, remapn2)
8063ENDIF
8064
8065! Faccio la fusione fisica dei volumi
8066CALL vol7d_merge_finalr(this, that, v7dtmp, &
8067 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
8068 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
8069CALL vol7d_merge_finald(this, that, v7dtmp, &
8070 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
8071 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
8072CALL vol7d_merge_finali(this, that, v7dtmp, &
8073 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
8074 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
8075CALL vol7d_merge_finalb(this, that, v7dtmp, &
8076 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
8077 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
8078CALL vol7d_merge_finalc(this, that, v7dtmp, &
8079 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
8080 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
8081
8082! Dealloco i vettori di rimappatura
8083IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
8084IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
8085IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
8086IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
8087IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
8088IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
8089IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
8090IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
8091IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
8092IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
8093
8094! Distruggo il vecchio volume e assegno il nuovo a this
8096this = v7dtmp
8097! Ricreo gli indici var-attr
8098CALL vol7d_set_attr_ind(this)
8099
8100END SUBROUTINE vol7d_append
8101
8102
8135SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
8136 lsort_time, lsort_timerange, lsort_level, &
8137 ltime, ltimerange, llevel, lana, lnetwork, &
8138 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
8139 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
8140 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
8141 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
8142 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
8143 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
8144TYPE(vol7d),INTENT(IN) :: this
8145TYPE(vol7d),INTENT(INOUT) :: that
8146LOGICAL,INTENT(IN),OPTIONAL :: sort
8147LOGICAL,INTENT(IN),OPTIONAL :: unique
8148LOGICAL,INTENT(IN),OPTIONAL :: miss
8149LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
8150LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
8151LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
8159LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
8161LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
8163LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
8165LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
8167LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
8169LOGICAL,INTENT(in),OPTIONAL :: &
8170 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
8171 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
8172 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
8173 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
8174 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
8175 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
8176
8177LOGICAL :: lsort, lunique, lmiss
8178INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
8179
8182IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
8183
8187
8188! Calcolo le mappature tra volume vecchio e volume nuovo
8189! I puntatori remap* vengono tutti o allocati o nullificati
8190CALL vol7d_remap1_datetime(this%time, that%time, &
8191 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
8192CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
8193 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
8194CALL vol7d_remap1_vol7d_level(this%level, that%level, &
8195 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
8196CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
8197 lsort, lunique, lmiss, remapa, lana)
8198CALL vol7d_remap1_vol7d_network(this%network, that%network, &
8199 lsort, lunique, lmiss, remapn, lnetwork)
8200
8201! lanavari, lanavarb, lanavarc, &
8202! lanaattri, lanaattrb, lanaattrc, &
8203! lanavarattri, lanavarattrb, lanavarattrc, &
8204! ldativari, ldativarb, ldativarc, &
8205! ldatiattri, ldatiattrb, ldatiattrc, &
8206! ldativarattri, ldativarattrb, ldativarattrc
8207! Faccio la riforma fisica dei volumi
8208CALL vol7d_reform_finalr(this, that, &
8209 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8210 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
8211CALL vol7d_reform_finald(this, that, &
8212 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8213 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
8214CALL vol7d_reform_finali(this, that, &
8215 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8216 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
8217CALL vol7d_reform_finalb(this, that, &
8218 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8219 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
8220CALL vol7d_reform_finalc(this, that, &
8221 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8222 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
8223
8224! Dealloco i vettori di rimappatura
8225IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
8226IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
8227IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
8228IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
8229IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
8230
8231! Ricreo gli indici var-attr
8232CALL vol7d_set_attr_ind(that)
8233that%time_definition = this%time_definition
8234
8235END SUBROUTINE vol7d_copy
8236
8237
8248SUBROUTINE vol7d_reform(this, sort, unique, miss, &
8249 lsort_time, lsort_timerange, lsort_level, &
8250 ltime, ltimerange, llevel, lana, lnetwork, &
8251 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
8252 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
8253 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
8254 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
8255 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
8256 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
8257 ,purgeana)
8258TYPE(vol7d),INTENT(INOUT) :: this
8259LOGICAL,INTENT(IN),OPTIONAL :: sort
8260LOGICAL,INTENT(IN),OPTIONAL :: unique
8261LOGICAL,INTENT(IN),OPTIONAL :: miss
8262LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
8263LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
8264LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
8272LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
8273LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
8274LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
8275LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
8276LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
8278LOGICAL,INTENT(in),OPTIONAL :: &
8279 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
8280 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
8281 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
8282 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
8283 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
8284 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
8285LOGICAL,INTENT(IN),OPTIONAL :: purgeana
8286
8287TYPE(vol7d) :: v7dtmp
8288logical,allocatable :: llana(:)
8289integer :: i
8290
8292 lsort_time, lsort_timerange, lsort_level, &
8293 ltime, ltimerange, llevel, lana, lnetwork, &
8294 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
8295 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
8296 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
8297 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
8298 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
8299 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
8300
8301! destroy old volume
8303
8304if (optio_log(purgeana)) then
8305 allocate(llana(size(v7dtmp%ana)))
8306 llana =.false.
8307 do i =1,size(v7dtmp%ana)
8308 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
8309 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
8310 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
8311 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
8312 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
8313 end do
8314 CALL vol7d_copy(v7dtmp, this,lana=llana)
8316 deallocate(llana)
8317else
8318 this=v7dtmp
8319end if
8320
8321END SUBROUTINE vol7d_reform
8322
8323
8331SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
8332TYPE(vol7d),INTENT(INOUT) :: this
8333LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
8334LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
8335LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
8336
8337INTEGER :: i
8338LOGICAL :: to_be_sorted
8339
8340to_be_sorted = .false.
8341CALL vol7d_alloc_vol(this) ! usual safety check
8342
8343IF (optio_log(lsort_time)) THEN
8344 DO i = 2, SIZE(this%time)
8345 IF (this%time(i) < this%time(i-1)) THEN
8346 to_be_sorted = .true.
8347 EXIT
8348 ENDIF
8349 ENDDO
8350ENDIF
8351IF (optio_log(lsort_timerange)) THEN
8352 DO i = 2, SIZE(this%timerange)
8353 IF (this%timerange(i) < this%timerange(i-1)) THEN
8354 to_be_sorted = .true.
8355 EXIT
8356 ENDIF
8357 ENDDO
8358ENDIF
8359IF (optio_log(lsort_level)) THEN
8360 DO i = 2, SIZE(this%level)
8361 IF (this%level(i) < this%level(i-1)) THEN
8362 to_be_sorted = .true.
8363 EXIT
8364 ENDIF
8365 ENDDO
8366ENDIF
8367
8368IF (to_be_sorted) CALL vol7d_reform(this, &
8369 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
8370
8371END SUBROUTINE vol7d_smart_sort
8372
8380SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
8381TYPE(vol7d),INTENT(inout) :: this
8382CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
8383CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
8384TYPE(vol7d_network),OPTIONAL :: nl(:)
8385TYPE(datetime),INTENT(in),OPTIONAL :: s_d
8386TYPE(datetime),INTENT(in),OPTIONAL :: e_d
8387
8388INTEGER :: i
8389
8390IF (PRESENT(avl)) THEN
8391 IF (SIZE(avl) > 0) THEN
8392
8393 IF (ASSOCIATED(this%anavar%r)) THEN
8394 DO i = 1, SIZE(this%anavar%r)
8395 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
8396 ENDDO
8397 ENDIF
8398
8399 IF (ASSOCIATED(this%anavar%i)) THEN
8400 DO i = 1, SIZE(this%anavar%i)
8401 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
8402 ENDDO
8403 ENDIF
8404
8405 IF (ASSOCIATED(this%anavar%b)) THEN
8406 DO i = 1, SIZE(this%anavar%b)
8407 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
8408 ENDDO
8409 ENDIF
8410
8411 IF (ASSOCIATED(this%anavar%d)) THEN
8412 DO i = 1, SIZE(this%anavar%d)
8413 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
8414 ENDDO
8415 ENDIF
8416
8417 IF (ASSOCIATED(this%anavar%c)) THEN
8418 DO i = 1, SIZE(this%anavar%c)
8419 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
8420 ENDDO
8421 ENDIF
8422
8423 ENDIF
8424ENDIF
8425
8426
8427IF (PRESENT(vl)) THEN
8428 IF (size(vl) > 0) THEN
8429 IF (ASSOCIATED(this%dativar%r)) THEN
8430 DO i = 1, SIZE(this%dativar%r)
8431 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
8432 ENDDO
8433 ENDIF
8434
8435 IF (ASSOCIATED(this%dativar%i)) THEN
8436 DO i = 1, SIZE(this%dativar%i)
8437 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
8438 ENDDO
8439 ENDIF
8440
8441 IF (ASSOCIATED(this%dativar%b)) THEN
8442 DO i = 1, SIZE(this%dativar%b)
8443 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
8444 ENDDO
8445 ENDIF
8446
8447 IF (ASSOCIATED(this%dativar%d)) THEN
8448 DO i = 1, SIZE(this%dativar%d)
8449 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
8450 ENDDO
8451 ENDIF
8452
8453 IF (ASSOCIATED(this%dativar%c)) THEN
8454 DO i = 1, SIZE(this%dativar%c)
8455 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
8456 ENDDO
8457 ENDIF
8458
8459 IF (ASSOCIATED(this%dativar%c)) THEN
8460 DO i = 1, SIZE(this%dativar%c)
8461 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
8462 ENDDO
8463 ENDIF
8464
8465 ENDIF
8466ENDIF
8467
8468IF (PRESENT(nl)) THEN
8469 IF (SIZE(nl) > 0) THEN
8470 DO i = 1, SIZE(this%network)
8471 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
8472 ENDDO
8473 ENDIF
8474ENDIF
8475
8476IF (PRESENT(s_d)) THEN
8478 WHERE (this%time < s_d)
8479 this%time = datetime_miss
8480 END WHERE
8481 ENDIF
8482ENDIF
8483
8484IF (PRESENT(e_d)) THEN
8486 WHERE (this%time > e_d)
8487 this%time = datetime_miss
8488 END WHERE
8489 ENDIF
8490ENDIF
8491
8492CALL vol7d_reform(this, miss=.true.)
8493
8494END SUBROUTINE vol7d_filter
8495
8496
8503SUBROUTINE vol7d_convr(this, that, anaconv)
8504TYPE(vol7d),INTENT(IN) :: this
8505TYPE(vol7d),INTENT(INOUT) :: that
8506LOGICAL,OPTIONAL,INTENT(in) :: anaconv
8507INTEGER :: i
8508LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
8509TYPE(vol7d) :: v7d_tmp
8510
8511IF (optio_log(anaconv)) THEN
8512 acp=fv
8513 acn=tv
8514ELSE
8515 acp=tv
8516 acn=fv
8517ENDIF
8518
8519! Volume con solo i dati reali e tutti gli attributi
8520! l'anagrafica e` copiata interamente se necessario
8521CALL vol7d_copy(this, that, &
8522 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
8523 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
8524
8525! Volume solo di dati double
8526CALL vol7d_copy(this, v7d_tmp, &
8527 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
8528 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8529 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8530 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
8531 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8532 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8533
8534! converto a dati reali
8535IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
8536
8537 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
8538! alloco i dati reali e vi trasferisco i double
8539 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
8540 SIZE(v7d_tmp%volanad, 3)))
8541 DO i = 1, SIZE(v7d_tmp%anavar%d)
8542 v7d_tmp%volanar(:,i,:) = &
8543 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
8544 ENDDO
8545 DEALLOCATE(v7d_tmp%volanad)
8546! trasferisco le variabili
8547 v7d_tmp%anavar%r => v7d_tmp%anavar%d
8548 NULLIFY(v7d_tmp%anavar%d)
8549 ENDIF
8550
8551 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
8552! alloco i dati reali e vi trasferisco i double
8553 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
8554 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
8555 SIZE(v7d_tmp%voldatid, 6)))
8556 DO i = 1, SIZE(v7d_tmp%dativar%d)
8557 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8558 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
8559 ENDDO
8560 DEALLOCATE(v7d_tmp%voldatid)
8561! trasferisco le variabili
8562 v7d_tmp%dativar%r => v7d_tmp%dativar%d
8563 NULLIFY(v7d_tmp%dativar%d)
8564 ENDIF
8565
8566! fondo con il volume definitivo
8567 CALL vol7d_merge(that, v7d_tmp)
8568ELSE
8570ENDIF
8571
8572
8573! Volume solo di dati interi
8574CALL vol7d_copy(this, v7d_tmp, &
8575 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
8576 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8577 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8578 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
8579 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8580 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8581
8582! converto a dati reali
8583IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
8584
8585 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
8586! alloco i dati reali e vi trasferisco gli interi
8587 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
8588 SIZE(v7d_tmp%volanai, 3)))
8589 DO i = 1, SIZE(v7d_tmp%anavar%i)
8590 v7d_tmp%volanar(:,i,:) = &
8591 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
8592 ENDDO
8593 DEALLOCATE(v7d_tmp%volanai)
8594! trasferisco le variabili
8595 v7d_tmp%anavar%r => v7d_tmp%anavar%i
8596 NULLIFY(v7d_tmp%anavar%i)
8597 ENDIF
8598
8599 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
8600! alloco i dati reali e vi trasferisco gli interi
8601 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
8602 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
8603 SIZE(v7d_tmp%voldatii, 6)))
8604 DO i = 1, SIZE(v7d_tmp%dativar%i)
8605 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8606 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
8607 ENDDO
8608 DEALLOCATE(v7d_tmp%voldatii)
8609! trasferisco le variabili
8610 v7d_tmp%dativar%r => v7d_tmp%dativar%i
8611 NULLIFY(v7d_tmp%dativar%i)
8612 ENDIF
8613
8614! fondo con il volume definitivo
8615 CALL vol7d_merge(that, v7d_tmp)
8616ELSE
8618ENDIF
8619
8620
8621! Volume solo di dati byte
8622CALL vol7d_copy(this, v7d_tmp, &
8623 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
8624 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8625 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8626 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
8627 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8628 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8629
8630! converto a dati reali
8631IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
8632
8633 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
8634! alloco i dati reali e vi trasferisco i byte
8635 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
8636 SIZE(v7d_tmp%volanab, 3)))
8637 DO i = 1, SIZE(v7d_tmp%anavar%b)
8638 v7d_tmp%volanar(:,i,:) = &
8639 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
8640 ENDDO
8641 DEALLOCATE(v7d_tmp%volanab)
8642! trasferisco le variabili
8643 v7d_tmp%anavar%r => v7d_tmp%anavar%b
8644 NULLIFY(v7d_tmp%anavar%b)
8645 ENDIF
8646
8647 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
8648! alloco i dati reali e vi trasferisco i byte
8649 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
8650 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
8651 SIZE(v7d_tmp%voldatib, 6)))
8652 DO i = 1, SIZE(v7d_tmp%dativar%b)
8653 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8654 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
8655 ENDDO
8656 DEALLOCATE(v7d_tmp%voldatib)
8657! trasferisco le variabili
8658 v7d_tmp%dativar%r => v7d_tmp%dativar%b
8659 NULLIFY(v7d_tmp%dativar%b)
8660 ENDIF
8661
8662! fondo con il volume definitivo
8663 CALL vol7d_merge(that, v7d_tmp)
8664ELSE
8666ENDIF
8667
8668
8669! Volume solo di dati character
8670CALL vol7d_copy(this, v7d_tmp, &
8671 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
8672 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8673 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8674 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
8675 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8676 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8677
8678! converto a dati reali
8679IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
8680
8681 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
8682! alloco i dati reali e vi trasferisco i character
8683 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
8684 SIZE(v7d_tmp%volanac, 3)))
8685 DO i = 1, SIZE(v7d_tmp%anavar%c)
8686 v7d_tmp%volanar(:,i,:) = &
8687 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
8688 ENDDO
8689 DEALLOCATE(v7d_tmp%volanac)
8690! trasferisco le variabili
8691 v7d_tmp%anavar%r => v7d_tmp%anavar%c
8692 NULLIFY(v7d_tmp%anavar%c)
8693 ENDIF
8694
8695 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
8696! alloco i dati reali e vi trasferisco i character
8697 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
8698 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
8699 SIZE(v7d_tmp%voldatic, 6)))
8700 DO i = 1, SIZE(v7d_tmp%dativar%c)
8701 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8702 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
8703 ENDDO
8704 DEALLOCATE(v7d_tmp%voldatic)
8705! trasferisco le variabili
8706 v7d_tmp%dativar%r => v7d_tmp%dativar%c
8707 NULLIFY(v7d_tmp%dativar%c)
8708 ENDIF
8709
8710! fondo con il volume definitivo
8711 CALL vol7d_merge(that, v7d_tmp)
8712ELSE
8714ENDIF
8715
8716END SUBROUTINE vol7d_convr
8717
8718
8722SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
8723TYPE(vol7d),INTENT(IN) :: this
8724TYPE(vol7d),INTENT(OUT) :: that
8725logical , optional, intent(in) :: data_only
8726logical , optional, intent(in) :: ana
8727logical :: ldata_only,lana
8728
8729IF (PRESENT(data_only)) THEN
8730 ldata_only = data_only
8731ELSE
8732 ldata_only = .false.
8733ENDIF
8734
8735IF (PRESENT(ana)) THEN
8736 lana = ana
8737ELSE
8738 lana = .false.
8739ENDIF
8740
8741
8742#undef VOL7D_POLY_ARRAY
8743#define VOL7D_POLY_ARRAY voldati
8744#include "vol7d_class_diff.F90"
8745#undef VOL7D_POLY_ARRAY
8746#define VOL7D_POLY_ARRAY voldatiattr
8747#include "vol7d_class_diff.F90"
8748#undef VOL7D_POLY_ARRAY
8749
8750if ( .not. ldata_only) then
8751
8752#define VOL7D_POLY_ARRAY volana
8753#include "vol7d_class_diff.F90"
8754#undef VOL7D_POLY_ARRAY
8755#define VOL7D_POLY_ARRAY volanaattr
8756#include "vol7d_class_diff.F90"
8757#undef VOL7D_POLY_ARRAY
8758
8759 if(lana)then
8760 where ( this%ana == that%ana )
8761 that%ana = vol7d_ana_miss
8762 end where
8763 end if
8764
8765end if
8766
8767
8768
8769END SUBROUTINE vol7d_diff_only
8770
8771
8772
8773! Creo le routine da ripetere per i vari tipi di dati di v7d
8774! tramite un template e il preprocessore
8775#undef VOL7D_POLY_TYPE
8776#undef VOL7D_POLY_TYPES
8777#define VOL7D_POLY_TYPE REAL
8778#define VOL7D_POLY_TYPES r
8779#include "vol7d_class_type_templ.F90"
8780#undef VOL7D_POLY_TYPE
8781#undef VOL7D_POLY_TYPES
8782#define VOL7D_POLY_TYPE DOUBLE PRECISION
8783#define VOL7D_POLY_TYPES d
8784#include "vol7d_class_type_templ.F90"
8785#undef VOL7D_POLY_TYPE
8786#undef VOL7D_POLY_TYPES
8787#define VOL7D_POLY_TYPE INTEGER
8788#define VOL7D_POLY_TYPES i
8789#include "vol7d_class_type_templ.F90"
8790#undef VOL7D_POLY_TYPE
8791#undef VOL7D_POLY_TYPES
8792#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
8793#define VOL7D_POLY_TYPES b
8794#include "vol7d_class_type_templ.F90"
8795#undef VOL7D_POLY_TYPE
8796#undef VOL7D_POLY_TYPES
8797#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
8798#define VOL7D_POLY_TYPES c
8799#include "vol7d_class_type_templ.F90"
8800
8801! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
8802! tramite un template e il preprocessore
8803#define VOL7D_SORT
8804#undef VOL7D_NO_ZERO_ALLOC
8805#undef VOL7D_POLY_TYPE
8806#define VOL7D_POLY_TYPE datetime
8807#include "vol7d_class_desc_templ.F90"
8808#undef VOL7D_POLY_TYPE
8809#define VOL7D_POLY_TYPE vol7d_timerange
8810#include "vol7d_class_desc_templ.F90"
8811#undef VOL7D_POLY_TYPE
8812#define VOL7D_POLY_TYPE vol7d_level
8813#include "vol7d_class_desc_templ.F90"
8814#undef VOL7D_SORT
8815#undef VOL7D_POLY_TYPE
8816#define VOL7D_POLY_TYPE vol7d_network
8817#include "vol7d_class_desc_templ.F90"
8818#undef VOL7D_POLY_TYPE
8819#define VOL7D_POLY_TYPE vol7d_ana
8820#include "vol7d_class_desc_templ.F90"
8821#define VOL7D_NO_ZERO_ALLOC
8822#undef VOL7D_POLY_TYPE
8823#define VOL7D_POLY_TYPE vol7d_var
8824#include "vol7d_class_desc_templ.F90"
8825
8835subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
8836
8837TYPE(vol7d),INTENT(IN) :: this
8838integer,optional,intent(inout) :: unit
8839character(len=*),intent(in),optional :: filename
8840character(len=*),intent(out),optional :: filename_auto
8841character(len=*),INTENT(IN),optional :: description
8842
8843integer :: lunit
8844character(len=254) :: ldescription,arg,lfilename
8845integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8846 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8847 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8848 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8849 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8850 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8851 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8852!integer :: im,id,iy
8853integer :: tarray(8)
8854logical :: opened,exist
8855
8856 nana=0
8857 ntime=0
8858 ntimerange=0
8859 nlevel=0
8860 nnetwork=0
8861 ndativarr=0
8862 ndativari=0
8863 ndativarb=0
8864 ndativard=0
8865 ndativarc=0
8866 ndatiattrr=0
8867 ndatiattri=0
8868 ndatiattrb=0
8869 ndatiattrd=0
8870 ndatiattrc=0
8871 ndativarattrr=0
8872 ndativarattri=0
8873 ndativarattrb=0
8874 ndativarattrd=0
8875 ndativarattrc=0
8876 nanavarr=0
8877 nanavari=0
8878 nanavarb=0
8879 nanavard=0
8880 nanavarc=0
8881 nanaattrr=0
8882 nanaattri=0
8883 nanaattrb=0
8884 nanaattrd=0
8885 nanaattrc=0
8886 nanavarattrr=0
8887 nanavarattri=0
8888 nanavarattrb=0
8889 nanavarattrd=0
8890 nanavarattrc=0
8891
8892
8893!call idate(im,id,iy)
8894call date_and_time(values=tarray)
8895call getarg(0,arg)
8896
8897if (present(description))then
8898 ldescription=description
8899else
8900 ldescription="Vol7d generated by: "//trim(arg)
8901end if
8902
8903if (.not. present(unit))then
8904 lunit=getunit()
8905else
8906 if (unit==0)then
8907 lunit=getunit()
8908 unit=lunit
8909 else
8910 lunit=unit
8911 end if
8912end if
8913
8914lfilename=trim(arg)//".v7d"
8916
8917if (present(filename))then
8918 if (filename /= "")then
8919 lfilename=filename
8920 end if
8921end if
8922
8923if (present(filename_auto))filename_auto=lfilename
8924
8925
8926inquire(unit=lunit,opened=opened)
8927if (.not. opened) then
8928! inquire(file=lfilename, EXIST=exist)
8929! IF (exist) THEN
8930! CALL l4f_log(L4F_FATAL, &
8931! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
8932! CALL raise_fatal_error()
8933! ENDIF
8934 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
8935 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8936end if
8937
8938if (associated(this%ana)) nana=size(this%ana)
8939if (associated(this%time)) ntime=size(this%time)
8940if (associated(this%timerange)) ntimerange=size(this%timerange)
8941if (associated(this%level)) nlevel=size(this%level)
8942if (associated(this%network)) nnetwork=size(this%network)
8943
8944if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
8945if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
8946if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
8947if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
8948if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
8949
8950if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
8951if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
8952if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
8953if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
8954if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
8955
8956if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
8957if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
8958if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
8959if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
8960if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
8961
8962if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
8963if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
8964if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
8965if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
8966if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
8967
8968if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
8969if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
8970if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
8971if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
8972if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
8973
8974if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
8975if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
8976if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
8977if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
8978if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
8979
8980write(unit=lunit)ldescription
8981write(unit=lunit)tarray
8982
8983write(unit=lunit)&
8984 nana, ntime, ntimerange, nlevel, nnetwork, &
8985 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8986 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8987 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8988 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8989 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8990 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8991 this%time_definition
8992
8993
8994!write(unit=lunit)this
8995
8996
8997!! prime 5 dimensioni
9000if (associated(this%level)) write(unit=lunit)this%level
9001if (associated(this%timerange)) write(unit=lunit)this%timerange
9002if (associated(this%network)) write(unit=lunit)this%network
9003
9004 !! 6a dimensione: variabile dell'anagrafica e dei dati
9005 !! con relativi attributi e in 5 tipi diversi
9006
9007if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
9008if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
9009if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
9010if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
9011if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
9012
9013if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
9014if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
9015if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
9016if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
9017if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
9018
9019if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
9020if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
9021if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
9022if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
9023if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
9024
9025if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
9026if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
9027if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
9028if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
9029if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
9030
9031if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
9032if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
9033if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
9034if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
9035if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
9036
9037if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
9038if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
9039if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
9040if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
9041if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
9042
9043!! Volumi di valori e attributi per anagrafica e dati
9044
9045if (associated(this%volanar)) write(unit=lunit)this%volanar
9046if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
9047if (associated(this%voldatir)) write(unit=lunit)this%voldatir
9048if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
9049
9050if (associated(this%volanai)) write(unit=lunit)this%volanai
9051if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
9052if (associated(this%voldatii)) write(unit=lunit)this%voldatii
9053if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
9054
9055if (associated(this%volanab)) write(unit=lunit)this%volanab
9056if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
9057if (associated(this%voldatib)) write(unit=lunit)this%voldatib
9058if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
9059
9060if (associated(this%volanad)) write(unit=lunit)this%volanad
9061if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
9062if (associated(this%voldatid)) write(unit=lunit)this%voldatid
9063if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
9064
9065if (associated(this%volanac)) write(unit=lunit)this%volanac
9066if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
9067if (associated(this%voldatic)) write(unit=lunit)this%voldatic
9068if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
9069
9070if (.not. present(unit)) close(unit=lunit)
9071
9072end subroutine vol7d_write_on_file
9073
9074
9081
9082
9083subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
9084
9085TYPE(vol7d),INTENT(OUT) :: this
9086integer,intent(inout),optional :: unit
9087character(len=*),INTENT(in),optional :: filename
9088character(len=*),intent(out),optional :: filename_auto
9089character(len=*),INTENT(out),optional :: description
9090integer,intent(out),optional :: tarray(8)
9091
9092
9093integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
9094 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
9095 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
9096 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
9097 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
9098 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
9099 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
9100
9101character(len=254) :: ldescription,lfilename,arg
9102integer :: ltarray(8),lunit,ios
9103logical :: opened,exist
9104
9105
9106call getarg(0,arg)
9107
9108if (.not. present(unit))then
9109 lunit=getunit()
9110else
9111 if (unit==0)then
9112 lunit=getunit()
9113 unit=lunit
9114 else
9115 lunit=unit
9116 end if
9117end if
9118
9119lfilename=trim(arg)//".v7d"
9121
9122if (present(filename))then
9123 if (filename /= "")then
9124 lfilename=filename
9125 end if
9126end if
9127
9128if (present(filename_auto))filename_auto=lfilename
9129
9130
9131inquire(unit=lunit,opened=opened)
9132IF (.NOT. opened) THEN
9133 inquire(file=lfilename,exist=exist)
9134 IF (.NOT.exist) THEN
9135 CALL l4f_log(l4f_fatal, &
9136 'in vol7d_read_from_file, file does not exists, cannot open')
9137 CALL raise_fatal_error()
9138 ENDIF
9139 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
9140 status='OLD', action='READ')
9141 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
9142end if
9143
9144
9146read(unit=lunit,iostat=ios)ldescription
9147
9148if (ios < 0) then ! A negative value indicates that the End of File or End of Record
9149 call vol7d_alloc (this)
9150 call vol7d_alloc_vol (this)
9151 if (present(description))description=ldescription
9152 if (present(tarray))tarray=ltarray
9153 if (.not. present(unit)) close(unit=lunit)
9154end if
9155
9156read(unit=lunit)ltarray
9157
9158CALL l4f_log(l4f_info, 'Reading vol7d from file')
9159CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
9162
9163if (present(description))description=ldescription
9164if (present(tarray))tarray=ltarray
9165
9166read(unit=lunit)&
9167 nana, ntime, ntimerange, nlevel, nnetwork, &
9168 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
9169 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
9170 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
9171 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
9172 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
9173 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
9174 this%time_definition
9175
9176call vol7d_alloc (this, &
9177 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
9178 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
9179 ndativard=ndativard, ndativarc=ndativarc,&
9180 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
9181 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
9182 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
9183 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
9184 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
9185 nanavard=nanavard, nanavarc=nanavarc,&
9186 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
9187 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
9188 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
9189 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
9190
9191
9194if (associated(this%level)) read(unit=lunit)this%level
9195if (associated(this%timerange)) read(unit=lunit)this%timerange
9196if (associated(this%network)) read(unit=lunit)this%network
9197
9198if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
9199if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
9200if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
9201if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
9202if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
9203
9204if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
9205if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
9206if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
9207if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
9208if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
9209
9210if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
9211if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
9212if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
9213if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
9214if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
9215
9216if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
9217if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
9218if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
9219if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
9220if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
9221
9222if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
9223if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
9224if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
9225if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
9226if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
9227
9228if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
9229if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
9230if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
9231if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
9232if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
9233
9234call vol7d_alloc_vol (this)
9235
9236!! Volumi di valori e attributi per anagrafica e dati
9237
9238if (associated(this%volanar)) read(unit=lunit)this%volanar
9239if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
9240if (associated(this%voldatir)) read(unit=lunit)this%voldatir
9241if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
9242
9243if (associated(this%volanai)) read(unit=lunit)this%volanai
9244if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
9245if (associated(this%voldatii)) read(unit=lunit)this%voldatii
9246if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
9247
9248if (associated(this%volanab)) read(unit=lunit)this%volanab
9249if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
9250if (associated(this%voldatib)) read(unit=lunit)this%voldatib
9251if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
9252
9253if (associated(this%volanad)) read(unit=lunit)this%volanad
9254if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
9255if (associated(this%voldatid)) read(unit=lunit)this%voldatid
9256if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
9257
9258if (associated(this%volanac)) read(unit=lunit)this%volanac
9259if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
9260if (associated(this%voldatic)) read(unit=lunit)this%voldatic
9261if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
9262
9263if (.not. present(unit)) close(unit=lunit)
9264
9265end subroutine vol7d_read_from_file
9266
9267
9268! to double precision
9269elemental doubleprecision function doubledatd(voldat,var)
9270doubleprecision,intent(in) :: voldat
9271type(vol7d_var),intent(in) :: var
9272
9273doubledatd=voldat
9274
9275end function doubledatd
9276
9277
9278elemental doubleprecision function doubledatr(voldat,var)
9279real,intent(in) :: voldat
9280type(vol7d_var),intent(in) :: var
9281
9283 doubledatr=dble(voldat)
9284else
9285 doubledatr=dmiss
9286end if
9287
9288end function doubledatr
9289
9290
9291elemental doubleprecision function doubledati(voldat,var)
9292integer,intent(in) :: voldat
9293type(vol7d_var),intent(in) :: var
9294
9297 doubledati=dble(voldat)/10.d0**var%scalefactor
9298 else
9299 doubledati=dble(voldat)
9300 endif
9301else
9302 doubledati=dmiss
9303end if
9304
9305end function doubledati
9306
9307
9308elemental doubleprecision function doubledatb(voldat,var)
9309integer(kind=int_b),intent(in) :: voldat
9310type(vol7d_var),intent(in) :: var
9311
9314 doubledatb=dble(voldat)/10.d0**var%scalefactor
9315 else
9316 doubledatb=dble(voldat)
9317 endif
9318else
9319 doubledatb=dmiss
9320end if
9321
9322end function doubledatb
9323
9324
9325elemental doubleprecision function doubledatc(voldat,var)
9326CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9327type(vol7d_var),intent(in) :: var
9328
9329doubledatc = c2d(voldat)
9331 doubledatc=doubledatc/10.d0**var%scalefactor
9332end if
9333
9334end function doubledatc
9335
9336
9337! to integer
9338elemental integer function integerdatd(voldat,var)
9339doubleprecision,intent(in) :: voldat
9340type(vol7d_var),intent(in) :: var
9341
9344 integerdatd=nint(voldat*10d0**var%scalefactor)
9345 else
9346 integerdatd=nint(voldat)
9347 endif
9348else
9349 integerdatd=imiss
9350end if
9351
9352end function integerdatd
9353
9354
9355elemental integer function integerdatr(voldat,var)
9356real,intent(in) :: voldat
9357type(vol7d_var),intent(in) :: var
9358
9361 integerdatr=nint(voldat*10d0**var%scalefactor)
9362 else
9363 integerdatr=nint(voldat)
9364 endif
9365else
9366 integerdatr=imiss
9367end if
9368
9369end function integerdatr
9370
9371
9372elemental integer function integerdati(voldat,var)
9373integer,intent(in) :: voldat
9374type(vol7d_var),intent(in) :: var
9375
9376integerdati=voldat
9377
9378end function integerdati
9379
9380
9381elemental integer function integerdatb(voldat,var)
9382integer(kind=int_b),intent(in) :: voldat
9383type(vol7d_var),intent(in) :: var
9384
9386 integerdatb=voldat
9387else
9388 integerdatb=imiss
9389end if
9390
9391end function integerdatb
9392
9393
9394elemental integer function integerdatc(voldat,var)
9395CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9396type(vol7d_var),intent(in) :: var
9397
9398integerdatc=c2i(voldat)
9399
9400end function integerdatc
9401
9402
9403! to real
9404elemental real function realdatd(voldat,var)
9405doubleprecision,intent(in) :: voldat
9406type(vol7d_var),intent(in) :: var
9407
9409 realdatd=real(voldat)
9410else
9411 realdatd=rmiss
9412end if
9413
9414end function realdatd
9415
9416
9417elemental real function realdatr(voldat,var)
9418real,intent(in) :: voldat
9419type(vol7d_var),intent(in) :: var
9420
9421realdatr=voldat
9422
9423end function realdatr
9424
9425
9426elemental real function realdati(voldat,var)
9427integer,intent(in) :: voldat
9428type(vol7d_var),intent(in) :: var
9429
9432 realdati=float(voldat)/10.**var%scalefactor
9433 else
9434 realdati=float(voldat)
9435 endif
9436else
9437 realdati=rmiss
9438end if
9439
9440end function realdati
9441
9442
9443elemental real function realdatb(voldat,var)
9444integer(kind=int_b),intent(in) :: voldat
9445type(vol7d_var),intent(in) :: var
9446
9449 realdatb=float(voldat)/10**var%scalefactor
9450 else
9451 realdatb=float(voldat)
9452 endif
9453else
9454 realdatb=rmiss
9455end if
9456
9457end function realdatb
9458
9459
9460elemental real function realdatc(voldat,var)
9461CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9462type(vol7d_var),intent(in) :: var
9463
9464realdatc=c2r(voldat)
9466 realdatc=realdatc/10.**var%scalefactor
9467end if
9468
9469end function realdatc
9470
9471
9477FUNCTION realanavol(this, var) RESULT(vol)
9478TYPE(vol7d),INTENT(in) :: this
9479TYPE(vol7d_var),INTENT(in) :: var
9480REAL :: vol(SIZE(this%ana),size(this%network))
9481
9482CHARACTER(len=1) :: dtype
9483INTEGER :: indvar
9484
9485dtype = cmiss
9486indvar = index(this%anavar, var, type=dtype)
9487
9488IF (indvar > 0) THEN
9489 SELECT CASE (dtype)
9490 CASE("d")
9491 vol = realdat(this%volanad(:,indvar,:), var)
9492 CASE("r")
9493 vol = this%volanar(:,indvar,:)
9494 CASE("i")
9495 vol = realdat(this%volanai(:,indvar,:), var)
9496 CASE("b")
9497 vol = realdat(this%volanab(:,indvar,:), var)
9498 CASE("c")
9499 vol = realdat(this%volanac(:,indvar,:), var)
9500 CASE default
9501 vol = rmiss
9502 END SELECT
9503ELSE
9504 vol = rmiss
9505ENDIF
9506
9507END FUNCTION realanavol
9508
9509
9515FUNCTION integeranavol(this, var) RESULT(vol)
9516TYPE(vol7d),INTENT(in) :: this
9517TYPE(vol7d_var),INTENT(in) :: var
9518INTEGER :: vol(SIZE(this%ana),size(this%network))
9519
9520CHARACTER(len=1) :: dtype
9521INTEGER :: indvar
9522
9523dtype = cmiss
9524indvar = index(this%anavar, var, type=dtype)
9525
9526IF (indvar > 0) THEN
9527 SELECT CASE (dtype)
9528 CASE("d")
9529 vol = integerdat(this%volanad(:,indvar,:), var)
9530 CASE("r")
9531 vol = integerdat(this%volanar(:,indvar,:), var)
9532 CASE("i")
9533 vol = this%volanai(:,indvar,:)
9534 CASE("b")
9535 vol = integerdat(this%volanab(:,indvar,:), var)
9536 CASE("c")
9537 vol = integerdat(this%volanac(:,indvar,:), var)
9538 CASE default
9539 vol = imiss
9540 END SELECT
9541ELSE
9542 vol = imiss
9543ENDIF
9544
9545END FUNCTION integeranavol
9546
9547
9553subroutine move_datac (v7d,&
9554 indana,indtime,indlevel,indtimerange,indnetwork,&
9555 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
9556
9557TYPE(vol7d),intent(inout) :: v7d
9558
9559integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
9560integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
9561integer :: inddativar,inddativarattr
9562
9563
9564do inddativar=1,size(v7d%dativar%c)
9565
9567 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
9568 ) then
9569
9570 ! dati
9571 v7d%voldatic &
9572 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
9573 v7d%voldatic &
9574 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
9575
9576
9577 ! attributi
9578 if (associated (v7d%dativarattr%i)) then
9579 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
9580 if (inddativarattr > 0 ) then
9581 v7d%voldatiattri &
9582 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9583 v7d%voldatiattri &
9584 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9585 end if
9586 end if
9587
9588 if (associated (v7d%dativarattr%r)) then
9589 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
9590 if (inddativarattr > 0 ) then
9591 v7d%voldatiattrr &
9592 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9593 v7d%voldatiattrr &
9594 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9595 end if
9596 end if
9597
9598 if (associated (v7d%dativarattr%d)) then
9599 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
9600 if (inddativarattr > 0 ) then
9601 v7d%voldatiattrd &
9602 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9603 v7d%voldatiattrd &
9604 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9605 end if
9606 end if
9607
9608 if (associated (v7d%dativarattr%b)) then
9609 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
9610 if (inddativarattr > 0 ) then
9611 v7d%voldatiattrb &
9612 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9613 v7d%voldatiattrb &
9614 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9615 end if
9616 end if
9617
9618 if (associated (v7d%dativarattr%c)) then
9619 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
9620 if (inddativarattr > 0 ) then
9621 v7d%voldatiattrc &
9622 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9623 v7d%voldatiattrc &
9624 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9625 end if
9626 end if
9627
9628 end if
9629
9630end do
9631
9632end subroutine move_datac
9633
9639subroutine move_datar (v7d,&
9640 indana,indtime,indlevel,indtimerange,indnetwork,&
9641 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
9642
9643TYPE(vol7d),intent(inout) :: v7d
9644
9645integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
9646integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
9647integer :: inddativar,inddativarattr
9648
9649
9650do inddativar=1,size(v7d%dativar%r)
9651
9653 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
9654 ) then
9655
9656 ! dati
9657 v7d%voldatir &
9658 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
9659 v7d%voldatir &
9660 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
9661
9662
9663 ! attributi
9664 if (associated (v7d%dativarattr%i)) then
9665 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
9666 if (inddativarattr > 0 ) then
9667 v7d%voldatiattri &
9668 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9669 v7d%voldatiattri &
9670 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9671 end if
9672 end if
9673
9674 if (associated (v7d%dativarattr%r)) then
9675 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
9676 if (inddativarattr > 0 ) then
9677 v7d%voldatiattrr &
9678 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9679 v7d%voldatiattrr &
9680 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9681 end if
9682 end if
9683
9684 if (associated (v7d%dativarattr%d)) then
9685 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
9686 if (inddativarattr > 0 ) then
9687 v7d%voldatiattrd &
9688 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9689 v7d%voldatiattrd &
9690 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9691 end if
9692 end if
9693
9694 if (associated (v7d%dativarattr%b)) then
9695 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
9696 if (inddativarattr > 0 ) then
9697 v7d%voldatiattrb &
9698 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9699 v7d%voldatiattrb &
9700 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9701 end if
9702 end if
9703
9704 if (associated (v7d%dativarattr%c)) then
9705 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
9706 if (inddativarattr > 0 ) then
9707 v7d%voldatiattrc &
9708 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9709 v7d%voldatiattrc &
9710 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9711 end if
9712 end if
9713
9714 end if
9715
9716end do
9717
9718end subroutine move_datar
9719
9720
9734subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
9735type(vol7d),intent(inout) :: v7din
9736type(vol7d),intent(out) :: v7dout
9737type(vol7d_level),intent(in),optional :: level(:)
9738type(vol7d_timerange),intent(in),optional :: timerange(:)
9739!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
9740!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
9741logical,intent(in),optional :: nostatproc
9742
9743integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
9744integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
9745type(vol7d_level) :: roundlevel(size(v7din%level))
9746type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
9747type(vol7d) :: v7d_tmp
9748
9749
9750nbin=0
9751
9752if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
9753if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
9754if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
9755if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
9756
9758
9759roundlevel=v7din%level
9760
9761if (present(level))then
9762 do ilevel = 1, size(v7din%level)
9763 if ((any(v7din%level(ilevel) .almosteq. level))) then
9764 roundlevel(ilevel)=level(1)
9765 end if
9766 end do
9767end if
9768
9769roundtimerange=v7din%timerange
9770
9771if (present(timerange))then
9772 do itimerange = 1, size(v7din%timerange)
9773 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
9774 roundtimerange(itimerange)=timerange(1)
9775 end if
9776 end do
9777end if
9778
9779!set istantaneous values everywere
9780!preserve p1 for forecast time
9781if (optio_log(nostatproc)) then
9782 roundtimerange(:)%timerange=254
9783 roundtimerange(:)%p2=0
9784end if
9785
9786
9787nana=size(v7din%ana)
9788nlevel=count_distinct(roundlevel,back=.true.)
9789ntime=size(v7din%time)
9790ntimerange=count_distinct(roundtimerange,back=.true.)
9791nnetwork=size(v7din%network)
9792
9794
9795if (nbin == 0) then
9797else
9798 call vol7d_convr(v7din,v7d_tmp)
9799end if
9800
9801v7d_tmp%level=roundlevel
9802v7d_tmp%timerange=roundtimerange
9803
9804do ilevel=1, size(v7d_tmp%level)
9805 indl=index(v7d_tmp%level,roundlevel(ilevel))
9806 do itimerange=1,size(v7d_tmp%timerange)
9807 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
9808
9809 if (indl /= ilevel .or. indt /= itimerange) then
9810
9811 do iana=1, nana
9812 do itime=1,ntime
9813 do inetwork=1,nnetwork
9814
9815 if (nbin > 0) then
9816 call move_datar (v7d_tmp,&
9817 iana,itime,ilevel,itimerange,inetwork,&
9818 iana,itime,indl,indt,inetwork)
9819 else
9820 call move_datac (v7d_tmp,&
9821 iana,itime,ilevel,itimerange,inetwork,&
9822 iana,itime,indl,indt,inetwork)
9823 end if
9824
9825 end do
9826 end do
9827 end do
9828
9829 end if
9830
9831 end do
9832end do
9833
9834! set to missing level and time > nlevel
9835do ilevel=nlevel+1,size(v7d_tmp%level)
9837end do
9838
9839do itimerange=ntimerange+1,size(v7d_tmp%timerange)
9841end do
9842
9843!copy with remove
9846
9847!call display(v7dout)
9848
9849end subroutine v7d_rounding
9850
9851
9853
9859
9860
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition: char_utilities.F90:284 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:484 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:491 Generic subroutine for checking OPTIONAL parameters. Definition: optional_values.f90:36 Check for problems return 0 if all check passed print diagnostics with log4f. Definition: vol7d_class.F90:451 Reduce some dimensions (level and timerage) for semplification (rounding). Definition: vol7d_class.F90:468 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:218 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:251 Module for quickly interpreting the OPTIONAL parameters passed to a subprogram. Definition: optional_values.f90:28 Classe per la gestione dell'anagrafica di stazioni meteo e affini. Definition: vol7d_ana_class.F90:218 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:219 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition: vol7d_network_class.F90:220 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition: vol7d_timerange_class.F90:221 Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var. Definition: vol7d_varvect_class.f90:22 Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension... Definition: vol7d_class.F90:318 |