libsim Versione 7.1.11
|
◆ vol7d_get_volanac()
Crea una vista a dimensione ridotta di un volume di anagrafica 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 :: vol1d(:)
...
CALL vol7d_get_volanac(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 6250 del file vol7d_class.F90. 6252! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
6253! authors:
6254! Davide Cesari <dcesari@arpa.emr.it>
6255! Paolo Patruno <ppatruno@arpa.emr.it>
6256
6257! This program is free software; you can redistribute it and/or
6258! modify it under the terms of the GNU General Public License as
6259! published by the Free Software Foundation; either version 2 of
6260! the License, or (at your option) any later version.
6261
6262! This program is distributed in the hope that it will be useful,
6263! but WITHOUT ANY WARRANTY; without even the implied warranty of
6264! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
6265! GNU General Public License for more details.
6266
6267! You should have received a copy of the GNU General Public License
6268! along with this program. If not, see <http://www.gnu.org/licenses/>.
6269#include "config.h"
6270
6282
6350IMPLICIT NONE
6351
6352
6353INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
6354 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
6355
6356INTEGER, PARAMETER :: vol7d_ana_a=1
6357INTEGER, PARAMETER :: vol7d_var_a=2
6358INTEGER, PARAMETER :: vol7d_network_a=3
6359INTEGER, PARAMETER :: vol7d_attr_a=4
6360INTEGER, PARAMETER :: vol7d_ana_d=1
6361INTEGER, PARAMETER :: vol7d_time_d=2
6362INTEGER, PARAMETER :: vol7d_level_d=3
6363INTEGER, PARAMETER :: vol7d_timerange_d=4
6364INTEGER, PARAMETER :: vol7d_var_d=5
6365INTEGER, PARAMETER :: vol7d_network_d=6
6366INTEGER, PARAMETER :: vol7d_attr_d=7
6367INTEGER, PARAMETER :: vol7d_cdatalen=32
6368
6369TYPE vol7d_varmap
6370 INTEGER :: r, d, i, b, c
6371END TYPE vol7d_varmap
6372
6377 TYPE(vol7d_ana),POINTER :: ana(:)
6379 TYPE(datetime),POINTER :: time(:)
6381 TYPE(vol7d_level),POINTER :: level(:)
6383 TYPE(vol7d_timerange),POINTER :: timerange(:)
6385 TYPE(vol7d_network),POINTER :: network(:)
6387 TYPE(vol7d_varvect) :: anavar
6389 TYPE(vol7d_varvect) :: anaattr
6391 TYPE(vol7d_varvect) :: anavarattr
6393 TYPE(vol7d_varvect) :: dativar
6395 TYPE(vol7d_varvect) :: datiattr
6397 TYPE(vol7d_varvect) :: dativarattr
6398
6400 REAL,POINTER :: volanar(:,:,:)
6402 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
6404 INTEGER,POINTER :: volanai(:,:,:)
6406 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
6408 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
6409
6411 REAL,POINTER :: volanaattrr(:,:,:,:)
6413 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
6415 INTEGER,POINTER :: volanaattri(:,:,:,:)
6417 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
6419 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
6420
6422 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
6424 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
6426 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
6428 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
6430 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
6431
6433 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
6435 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
6437 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
6439 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
6441 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
6442
6444 integer :: time_definition
6445
6447
6452 MODULE PROCEDURE vol7d_init
6453END INTERFACE
6454
6457 MODULE PROCEDURE vol7d_delete
6458END INTERFACE
6459
6462 MODULE PROCEDURE vol7d_write_on_file
6463END INTERFACE
6464
6466INTERFACE import
6467 MODULE PROCEDURE vol7d_read_from_file
6468END INTERFACE
6469
6472 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
6473END INTERFACE
6474
6477 MODULE PROCEDURE to_char_dat
6478END INTERFACE
6479
6482 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
6483END INTERFACE
6484
6487 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
6488END INTERFACE
6489
6492 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
6493END INTERFACE
6494
6497 MODULE PROCEDURE vol7d_copy
6498END INTERFACE
6499
6502 MODULE PROCEDURE vol7d_c_e
6503END INTERFACE
6504
6509 MODULE PROCEDURE vol7d_check
6510END INTERFACE
6511
6526 MODULE PROCEDURE v7d_rounding
6527END INTERFACE
6528
6529!!$INTERFACE get_volana
6530!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
6531!!$ vol7d_get_volanab, vol7d_get_volanac
6532!!$END INTERFACE
6533!!$
6534!!$INTERFACE get_voldati
6535!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
6536!!$ vol7d_get_voldatib, vol7d_get_voldatic
6537!!$END INTERFACE
6538!!$
6539!!$INTERFACE get_volanaattr
6540!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
6541!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
6542!!$END INTERFACE
6543!!$
6544!!$INTERFACE get_voldatiattr
6545!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
6546!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
6547!!$END INTERFACE
6548
6549PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
6550 vol7d_get_volc, &
6551 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
6552 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
6553 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
6554 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
6555 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
6556 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
6557 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
6558 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
6559 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
6560 vol7d_display, dat_display, dat_vect_display, &
6561 to_char_dat, vol7d_check
6562
6563PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
6564
6565PRIVATE vol7d_c_e
6566
6567CONTAINS
6568
6569
6574SUBROUTINE vol7d_init(this,time_definition)
6575TYPE(vol7d),intent(out) :: this
6576integer,INTENT(IN),OPTIONAL :: time_definition
6577
6584CALL vol7d_var_features_init() ! initialise var features table once
6585
6586NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
6587
6588NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
6589NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
6590NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
6591NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
6592NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
6593
6594if(present(time_definition)) then
6595 this%time_definition=time_definition
6596else
6597 this%time_definition=1 !default to validity time
6598end if
6599
6600END SUBROUTINE vol7d_init
6601
6602
6606ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
6607TYPE(vol7d),intent(inout) :: this
6608LOGICAL, INTENT(in), OPTIONAL :: dataonly
6609
6610
6611IF (.NOT. optio_log(dataonly)) THEN
6612 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
6613 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
6614 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
6615 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
6616 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
6617 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
6618 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
6619 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
6620 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
6621 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
6622ENDIF
6623IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
6624IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
6625IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
6626IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
6627IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
6628IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
6629IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
6630IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
6631IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
6632IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
6633
6634IF (.NOT. optio_log(dataonly)) THEN
6635 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
6636 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
6637ENDIF
6638IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
6639IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
6640IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
6641
6642IF (.NOT. optio_log(dataonly)) THEN
6646ENDIF
6650
6651END SUBROUTINE vol7d_delete
6652
6653
6654
6655integer function vol7d_check(this)
6656TYPE(vol7d),intent(in) :: this
6657integer :: i,j,k,l,m,n
6658
6659vol7d_check=0
6660
6661if (associated(this%voldatii)) then
6662do i = 1,size(this%voldatii,1)
6663 do j = 1,size(this%voldatii,2)
6664 do k = 1,size(this%voldatii,3)
6665 do l = 1,size(this%voldatii,4)
6666 do m = 1,size(this%voldatii,5)
6667 do n = 1,size(this%voldatii,6)
6668 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
6669 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
6671 vol7d_check=1
6672 end if
6673 end do
6674 end do
6675 end do
6676 end do
6677 end do
6678end do
6679end if
6680
6681
6682if (associated(this%voldatir)) then
6683do i = 1,size(this%voldatir,1)
6684 do j = 1,size(this%voldatir,2)
6685 do k = 1,size(this%voldatir,3)
6686 do l = 1,size(this%voldatir,4)
6687 do m = 1,size(this%voldatir,5)
6688 do n = 1,size(this%voldatir,6)
6689 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
6690 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
6692 vol7d_check=2
6693 end if
6694 end do
6695 end do
6696 end do
6697 end do
6698 end do
6699end do
6700end if
6701
6702if (associated(this%voldatid)) then
6703do i = 1,size(this%voldatid,1)
6704 do j = 1,size(this%voldatid,2)
6705 do k = 1,size(this%voldatid,3)
6706 do l = 1,size(this%voldatid,4)
6707 do m = 1,size(this%voldatid,5)
6708 do n = 1,size(this%voldatid,6)
6709 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
6710 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
6712 vol7d_check=3
6713 end if
6714 end do
6715 end do
6716 end do
6717 end do
6718 end do
6719end do
6720end if
6721
6722if (associated(this%voldatib)) then
6723do i = 1,size(this%voldatib,1)
6724 do j = 1,size(this%voldatib,2)
6725 do k = 1,size(this%voldatib,3)
6726 do l = 1,size(this%voldatib,4)
6727 do m = 1,size(this%voldatib,5)
6728 do n = 1,size(this%voldatib,6)
6729 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
6730 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
6732 vol7d_check=4
6733 end if
6734 end do
6735 end do
6736 end do
6737 end do
6738 end do
6739end do
6740end if
6741
6742end function vol7d_check
6743
6744
6745
6746!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
6748SUBROUTINE vol7d_display(this)
6749TYPE(vol7d),intent(in) :: this
6750integer :: i
6751
6752REAL :: rdat
6753DOUBLE PRECISION :: ddat
6754INTEGER :: idat
6755INTEGER(kind=int_b) :: bdat
6756CHARACTER(len=vol7d_cdatalen) :: cdat
6757
6758
6759print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
6760if (this%time_definition == 0) then
6761 print*,"TIME DEFINITION: time is reference time"
6762else if (this%time_definition == 1) then
6763 print*,"TIME DEFINITION: time is validity time"
6764else
6765 print*,"Time definition have a wrong walue:", this%time_definition
6766end if
6767
6768IF (ASSOCIATED(this%network))then
6769 print*,"---- network vector ----"
6770 print*,"elements=",size(this%network)
6771 do i=1, size(this%network)
6773 end do
6774end IF
6775
6776IF (ASSOCIATED(this%ana))then
6777 print*,"---- ana vector ----"
6778 print*,"elements=",size(this%ana)
6779 do i=1, size(this%ana)
6781 end do
6782end IF
6783
6784IF (ASSOCIATED(this%time))then
6785 print*,"---- time vector ----"
6786 print*,"elements=",size(this%time)
6787 do i=1, size(this%time)
6789 end do
6790end if
6791
6792IF (ASSOCIATED(this%level)) then
6793 print*,"---- level vector ----"
6794 print*,"elements=",size(this%level)
6795 do i =1,size(this%level)
6797 end do
6798end if
6799
6800IF (ASSOCIATED(this%timerange))then
6801 print*,"---- timerange vector ----"
6802 print*,"elements=",size(this%timerange)
6803 do i =1,size(this%timerange)
6805 end do
6806end if
6807
6808
6809print*,"---- ana vector ----"
6810print*,""
6811print*,"->>>>>>>>> anavar -"
6813print*,""
6814print*,"->>>>>>>>> anaattr -"
6816print*,""
6817print*,"->>>>>>>>> anavarattr -"
6819
6820print*,"-- ana data section (first point) --"
6821
6822idat=imiss
6823rdat=rmiss
6824ddat=dmiss
6825bdat=ibmiss
6826cdat=cmiss
6827
6828!ntime = MIN(SIZE(this%time),nprint)
6829!ntimerange = MIN(SIZE(this%timerange),nprint)
6830!nlevel = MIN(SIZE(this%level),nprint)
6831!nnetwork = MIN(SIZE(this%network),nprint)
6832!nana = MIN(SIZE(this%ana),nprint)
6833
6834IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
6835if (associated(this%volanai)) then
6836 do i=1,size(this%anavar%i)
6837 idat=this%volanai(1,i,1)
6839 end do
6840end if
6841idat=imiss
6842
6843if (associated(this%volanar)) then
6844 do i=1,size(this%anavar%r)
6845 rdat=this%volanar(1,i,1)
6847 end do
6848end if
6849rdat=rmiss
6850
6851if (associated(this%volanad)) then
6852 do i=1,size(this%anavar%d)
6853 ddat=this%volanad(1,i,1)
6855 end do
6856end if
6857ddat=dmiss
6858
6859if (associated(this%volanab)) then
6860 do i=1,size(this%anavar%b)
6861 bdat=this%volanab(1,i,1)
6863 end do
6864end if
6865bdat=ibmiss
6866
6867if (associated(this%volanac)) then
6868 do i=1,size(this%anavar%c)
6869 cdat=this%volanac(1,i,1)
6871 end do
6872end if
6873cdat=cmiss
6874ENDIF
6875
6876print*,"---- data vector ----"
6877print*,""
6878print*,"->>>>>>>>> dativar -"
6880print*,""
6881print*,"->>>>>>>>> datiattr -"
6883print*,""
6884print*,"->>>>>>>>> dativarattr -"
6886
6887print*,"-- data data section (first point) --"
6888
6889idat=imiss
6890rdat=rmiss
6891ddat=dmiss
6892bdat=ibmiss
6893cdat=cmiss
6894
6895IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
6896 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
6897if (associated(this%voldatii)) then
6898 do i=1,size(this%dativar%i)
6899 idat=this%voldatii(1,1,1,1,i,1)
6901 end do
6902end if
6903idat=imiss
6904
6905if (associated(this%voldatir)) then
6906 do i=1,size(this%dativar%r)
6907 rdat=this%voldatir(1,1,1,1,i,1)
6909 end do
6910end if
6911rdat=rmiss
6912
6913if (associated(this%voldatid)) then
6914 do i=1,size(this%dativar%d)
6915 ddat=this%voldatid(1,1,1,1,i,1)
6917 end do
6918end if
6919ddat=dmiss
6920
6921if (associated(this%voldatib)) then
6922 do i=1,size(this%dativar%b)
6923 bdat=this%voldatib(1,1,1,1,i,1)
6925 end do
6926end if
6927bdat=ibmiss
6928
6929if (associated(this%voldatic)) then
6930 do i=1,size(this%dativar%c)
6931 cdat=this%voldatic(1,1,1,1,i,1)
6933 end do
6934end if
6935cdat=cmiss
6936ENDIF
6937
6938print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
6939
6940END SUBROUTINE vol7d_display
6941
6942
6944SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
6945TYPE(vol7d_var),intent(in) :: this
6947REAL :: rdat
6949DOUBLE PRECISION :: ddat
6951INTEGER :: idat
6953INTEGER(kind=int_b) :: bdat
6955CHARACTER(len=*) :: cdat
6956
6957print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6958
6959end SUBROUTINE dat_display
6960
6962SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
6963
6964TYPE(vol7d_var),intent(in) :: this(:)
6966REAL :: rdat(:)
6968DOUBLE PRECISION :: ddat(:)
6970INTEGER :: idat(:)
6972INTEGER(kind=int_b) :: bdat(:)
6974CHARACTER(len=*):: cdat(:)
6975
6976integer :: i
6977
6978do i =1,size(this)
6980end do
6981
6982end SUBROUTINE dat_vect_display
6983
6984
6985FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
6986#ifdef HAVE_DBALLE
6987USE dballef
6988#endif
6989TYPE(vol7d_var),INTENT(in) :: this
6991REAL :: rdat
6993DOUBLE PRECISION :: ddat
6995INTEGER :: idat
6997INTEGER(kind=int_b) :: bdat
6999CHARACTER(len=*) :: cdat
7000CHARACTER(len=80) :: to_char_dat
7001
7002CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
7003
7004
7005#ifdef HAVE_DBALLE
7006INTEGER :: handle, ier
7007
7008handle = 0
7009to_char_dat="VALUE: "
7010
7015
7017 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
7018 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
7019 ier = idba_fatto(handle)
7020 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
7021endif
7022
7023#else
7024
7025to_char_dat="VALUE: "
7031
7032#endif
7033
7034END FUNCTION to_char_dat
7035
7036
7039FUNCTION vol7d_c_e(this) RESULT(c_e)
7040TYPE(vol7d), INTENT(in) :: this
7041
7042LOGICAL :: c_e
7043
7045 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
7046 ASSOCIATED(this%network) .OR. &
7047 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
7048 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
7049 ASSOCIATED(this%anavar%c) .OR. &
7050 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
7051 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
7052 ASSOCIATED(this%anaattr%c) .OR. &
7053 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
7054 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
7055 ASSOCIATED(this%dativar%c) .OR. &
7056 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
7057 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
7058 ASSOCIATED(this%datiattr%c)
7059
7060END FUNCTION vol7d_c_e
7061
7062
7101SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
7102 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
7103 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
7104 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
7105 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
7106 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
7107 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
7108 ini)
7109TYPE(vol7d),INTENT(inout) :: this
7110INTEGER,INTENT(in),OPTIONAL :: nana
7111INTEGER,INTENT(in),OPTIONAL :: ntime
7112INTEGER,INTENT(in),OPTIONAL :: nlevel
7113INTEGER,INTENT(in),OPTIONAL :: ntimerange
7114INTEGER,INTENT(in),OPTIONAL :: nnetwork
7116INTEGER,INTENT(in),OPTIONAL :: &
7117 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
7118 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
7119 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
7120 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
7121 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
7122 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
7123LOGICAL,INTENT(in),OPTIONAL :: ini
7124
7125INTEGER :: i
7126LOGICAL :: linit
7127
7128IF (PRESENT(ini)) THEN
7129 linit = ini
7130ELSE
7131 linit = .false.
7132ENDIF
7133
7134! Dimensioni principali
7135IF (PRESENT(nana)) THEN
7136 IF (nana >= 0) THEN
7137 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
7138 ALLOCATE(this%ana(nana))
7139 IF (linit) THEN
7140 DO i = 1, nana
7142 ENDDO
7143 ENDIF
7144 ENDIF
7145ENDIF
7146IF (PRESENT(ntime)) THEN
7147 IF (ntime >= 0) THEN
7148 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
7149 ALLOCATE(this%time(ntime))
7150 IF (linit) THEN
7151 DO i = 1, ntime
7153 ENDDO
7154 ENDIF
7155 ENDIF
7156ENDIF
7157IF (PRESENT(nlevel)) THEN
7158 IF (nlevel >= 0) THEN
7159 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
7160 ALLOCATE(this%level(nlevel))
7161 IF (linit) THEN
7162 DO i = 1, nlevel
7164 ENDDO
7165 ENDIF
7166 ENDIF
7167ENDIF
7168IF (PRESENT(ntimerange)) THEN
7169 IF (ntimerange >= 0) THEN
7170 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
7171 ALLOCATE(this%timerange(ntimerange))
7172 IF (linit) THEN
7173 DO i = 1, ntimerange
7175 ENDDO
7176 ENDIF
7177 ENDIF
7178ENDIF
7179IF (PRESENT(nnetwork)) THEN
7180 IF (nnetwork >= 0) THEN
7181 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
7182 ALLOCATE(this%network(nnetwork))
7183 IF (linit) THEN
7184 DO i = 1, nnetwork
7186 ENDDO
7187 ENDIF
7188 ENDIF
7189ENDIF
7190! Dimensioni dei tipi delle variabili
7191CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
7192 nanavari, nanavarb, nanavarc, ini)
7193CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
7194 nanaattri, nanaattrb, nanaattrc, ini)
7195CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
7196 nanavarattri, nanavarattrb, nanavarattrc, ini)
7197CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
7198 ndativari, ndativarb, ndativarc, ini)
7199CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
7200 ndatiattri, ndatiattrb, ndatiattrc, ini)
7201CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
7202 ndativarattri, ndativarattrb, ndativarattrc, ini)
7203
7204END SUBROUTINE vol7d_alloc
7205
7206
7207FUNCTION vol7d_check_alloc_ana(this)
7208TYPE(vol7d),INTENT(in) :: this
7209LOGICAL :: vol7d_check_alloc_ana
7210
7211vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
7212
7213END FUNCTION vol7d_check_alloc_ana
7214
7215SUBROUTINE vol7d_force_alloc_ana(this, ini)
7216TYPE(vol7d),INTENT(inout) :: this
7217LOGICAL,INTENT(in),OPTIONAL :: ini
7218
7219! Alloco i descrittori minimi per avere un volume di anagrafica
7220IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
7221IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
7222
7223END SUBROUTINE vol7d_force_alloc_ana
7224
7225
7226FUNCTION vol7d_check_alloc_dati(this)
7227TYPE(vol7d),INTENT(in) :: this
7228LOGICAL :: vol7d_check_alloc_dati
7229
7230vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
7231 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
7232 ASSOCIATED(this%timerange)
7233
7234END FUNCTION vol7d_check_alloc_dati
7235
7236SUBROUTINE vol7d_force_alloc_dati(this, ini)
7237TYPE(vol7d),INTENT(inout) :: this
7238LOGICAL,INTENT(in),OPTIONAL :: ini
7239
7240! Alloco i descrittori minimi per avere un volume di dati
7241CALL vol7d_force_alloc_ana(this, ini)
7242IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
7243IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
7244IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
7245
7246END SUBROUTINE vol7d_force_alloc_dati
7247
7248
7249SUBROUTINE vol7d_force_alloc(this)
7250TYPE(vol7d),INTENT(inout) :: this
7251
7252! If anything really not allocated yet, allocate with size 0
7253IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
7254IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
7255IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
7256IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
7257IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
7258
7259END SUBROUTINE vol7d_force_alloc
7260
7261
7262FUNCTION vol7d_check_vol(this)
7263TYPE(vol7d),INTENT(in) :: this
7264LOGICAL :: vol7d_check_vol
7265
7266vol7d_check_vol = c_e(this)
7267
7268! Anagrafica
7269IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
7270 vol7d_check_vol = .false.
7271ENDIF
7272
7273IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
7274 vol7d_check_vol = .false.
7275ENDIF
7276
7277IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
7278 vol7d_check_vol = .false.
7279ENDIF
7280
7281IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
7282 vol7d_check_vol = .false.
7283ENDIF
7284
7285IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
7286 vol7d_check_vol = .false.
7287ENDIF
7288IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
7289 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
7290 ASSOCIATED(this%anavar%c)) THEN
7291 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
7292ENDIF
7293
7294! Attributi dell'anagrafica
7295IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
7296 .NOT.ASSOCIATED(this%volanaattrr)) THEN
7297 vol7d_check_vol = .false.
7298ENDIF
7299
7300IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
7301 .NOT.ASSOCIATED(this%volanaattrd)) THEN
7302 vol7d_check_vol = .false.
7303ENDIF
7304
7305IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
7306 .NOT.ASSOCIATED(this%volanaattri)) THEN
7307 vol7d_check_vol = .false.
7308ENDIF
7309
7310IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
7311 .NOT.ASSOCIATED(this%volanaattrb)) THEN
7312 vol7d_check_vol = .false.
7313ENDIF
7314
7315IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
7316 .NOT.ASSOCIATED(this%volanaattrc)) THEN
7317 vol7d_check_vol = .false.
7318ENDIF
7319
7320! Dati
7321IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
7322 vol7d_check_vol = .false.
7323ENDIF
7324
7325IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
7326 vol7d_check_vol = .false.
7327ENDIF
7328
7329IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
7330 vol7d_check_vol = .false.
7331ENDIF
7332
7333IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
7334 vol7d_check_vol = .false.
7335ENDIF
7336
7337IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
7338 vol7d_check_vol = .false.
7339ENDIF
7340
7341! Attributi dei dati
7342IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
7343 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
7344 vol7d_check_vol = .false.
7345ENDIF
7346
7347IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
7348 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
7349 vol7d_check_vol = .false.
7350ENDIF
7351
7352IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
7353 .NOT.ASSOCIATED(this%voldatiattri)) THEN
7354 vol7d_check_vol = .false.
7355ENDIF
7356
7357IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
7358 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
7359 vol7d_check_vol = .false.
7360ENDIF
7361
7362IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
7363 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
7364 vol7d_check_vol = .false.
7365ENDIF
7366IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
7367 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
7368 ASSOCIATED(this%dativar%c)) THEN
7369 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
7370ENDIF
7371
7372END FUNCTION vol7d_check_vol
7373
7374
7389SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
7390TYPE(vol7d),INTENT(inout) :: this
7391LOGICAL,INTENT(in),OPTIONAL :: ini
7392LOGICAL,INTENT(in),OPTIONAL :: inivol
7393
7394LOGICAL :: linivol
7395
7396IF (PRESENT(inivol)) THEN
7397 linivol = inivol
7398ELSE
7399 linivol = .true.
7400ENDIF
7401
7402! Anagrafica
7403IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
7404 CALL vol7d_force_alloc_ana(this, ini)
7405 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
7406 IF (linivol) this%volanar(:,:,:) = rmiss
7407ENDIF
7408
7409IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
7410 CALL vol7d_force_alloc_ana(this, ini)
7411 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
7412 IF (linivol) this%volanad(:,:,:) = rdmiss
7413ENDIF
7414
7415IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
7416 CALL vol7d_force_alloc_ana(this, ini)
7417 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
7418 IF (linivol) this%volanai(:,:,:) = imiss
7419ENDIF
7420
7421IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
7422 CALL vol7d_force_alloc_ana(this, ini)
7423 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
7424 IF (linivol) this%volanab(:,:,:) = ibmiss
7425ENDIF
7426
7427IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
7428 CALL vol7d_force_alloc_ana(this, ini)
7429 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
7430 IF (linivol) this%volanac(:,:,:) = cmiss
7431ENDIF
7432
7433! Attributi dell'anagrafica
7434IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
7435 .NOT.ASSOCIATED(this%volanaattrr)) THEN
7436 CALL vol7d_force_alloc_ana(this, ini)
7437 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
7438 SIZE(this%network), SIZE(this%anaattr%r)))
7439 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
7440ENDIF
7441
7442IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
7443 .NOT.ASSOCIATED(this%volanaattrd)) THEN
7444 CALL vol7d_force_alloc_ana(this, ini)
7445 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
7446 SIZE(this%network), SIZE(this%anaattr%d)))
7447 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
7448ENDIF
7449
7450IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
7451 .NOT.ASSOCIATED(this%volanaattri)) THEN
7452 CALL vol7d_force_alloc_ana(this, ini)
7453 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
7454 SIZE(this%network), SIZE(this%anaattr%i)))
7455 IF (linivol) this%volanaattri(:,:,:,:) = imiss
7456ENDIF
7457
7458IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
7459 .NOT.ASSOCIATED(this%volanaattrb)) THEN
7460 CALL vol7d_force_alloc_ana(this, ini)
7461 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
7462 SIZE(this%network), SIZE(this%anaattr%b)))
7463 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
7464ENDIF
7465
7466IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
7467 .NOT.ASSOCIATED(this%volanaattrc)) THEN
7468 CALL vol7d_force_alloc_ana(this, ini)
7469 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
7470 SIZE(this%network), SIZE(this%anaattr%c)))
7471 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
7472ENDIF
7473
7474! Dati
7475IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
7476 CALL vol7d_force_alloc_dati(this, ini)
7477 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7478 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
7479 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
7480ENDIF
7481
7482IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
7483 CALL vol7d_force_alloc_dati(this, ini)
7484 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7485 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
7486 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
7487ENDIF
7488
7489IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
7490 CALL vol7d_force_alloc_dati(this, ini)
7491 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7492 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
7493 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
7494ENDIF
7495
7496IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
7497 CALL vol7d_force_alloc_dati(this, ini)
7498 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7499 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
7500 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
7501ENDIF
7502
7503IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
7504 CALL vol7d_force_alloc_dati(this, ini)
7505 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7506 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
7507 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
7508ENDIF
7509
7510! Attributi dei dati
7511IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
7512 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
7513 CALL vol7d_force_alloc_dati(this, ini)
7514 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7515 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
7516 SIZE(this%datiattr%r)))
7517 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
7518ENDIF
7519
7520IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
7521 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
7522 CALL vol7d_force_alloc_dati(this, ini)
7523 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7524 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
7525 SIZE(this%datiattr%d)))
7526 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
7527ENDIF
7528
7529IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
7530 .NOT.ASSOCIATED(this%voldatiattri)) THEN
7531 CALL vol7d_force_alloc_dati(this, ini)
7532 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7533 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
7534 SIZE(this%datiattr%i)))
7535 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
7536ENDIF
7537
7538IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
7539 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
7540 CALL vol7d_force_alloc_dati(this, ini)
7541 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7542 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
7543 SIZE(this%datiattr%b)))
7544 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
7545ENDIF
7546
7547IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
7548 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
7549 CALL vol7d_force_alloc_dati(this, ini)
7550 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
7551 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
7552 SIZE(this%datiattr%c)))
7553 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
7554ENDIF
7555
7556! Catch-all method
7557CALL vol7d_force_alloc(this)
7558
7559! Creo gli indici var-attr
7560
7561#ifdef DEBUG
7562CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
7563#endif
7564
7565CALL vol7d_set_attr_ind(this)
7566
7567
7568
7569END SUBROUTINE vol7d_alloc_vol
7570
7571
7578SUBROUTINE vol7d_set_attr_ind(this)
7579TYPE(vol7d),INTENT(inout) :: this
7580
7581INTEGER :: i
7582
7583! real
7584IF (ASSOCIATED(this%dativar%r)) THEN
7585 IF (ASSOCIATED(this%dativarattr%r)) THEN
7586 DO i = 1, SIZE(this%dativar%r)
7587 this%dativar%r(i)%r = &
7588 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
7589 ENDDO
7590 ENDIF
7591
7592 IF (ASSOCIATED(this%dativarattr%d)) THEN
7593 DO i = 1, SIZE(this%dativar%r)
7594 this%dativar%r(i)%d = &
7595 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
7596 ENDDO
7597 ENDIF
7598
7599 IF (ASSOCIATED(this%dativarattr%i)) THEN
7600 DO i = 1, SIZE(this%dativar%r)
7601 this%dativar%r(i)%i = &
7602 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
7603 ENDDO
7604 ENDIF
7605
7606 IF (ASSOCIATED(this%dativarattr%b)) THEN
7607 DO i = 1, SIZE(this%dativar%r)
7608 this%dativar%r(i)%b = &
7609 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
7610 ENDDO
7611 ENDIF
7612
7613 IF (ASSOCIATED(this%dativarattr%c)) THEN
7614 DO i = 1, SIZE(this%dativar%r)
7615 this%dativar%r(i)%c = &
7616 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
7617 ENDDO
7618 ENDIF
7619ENDIF
7620! double
7621IF (ASSOCIATED(this%dativar%d)) THEN
7622 IF (ASSOCIATED(this%dativarattr%r)) THEN
7623 DO i = 1, SIZE(this%dativar%d)
7624 this%dativar%d(i)%r = &
7625 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
7626 ENDDO
7627 ENDIF
7628
7629 IF (ASSOCIATED(this%dativarattr%d)) THEN
7630 DO i = 1, SIZE(this%dativar%d)
7631 this%dativar%d(i)%d = &
7632 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
7633 ENDDO
7634 ENDIF
7635
7636 IF (ASSOCIATED(this%dativarattr%i)) THEN
7637 DO i = 1, SIZE(this%dativar%d)
7638 this%dativar%d(i)%i = &
7639 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
7640 ENDDO
7641 ENDIF
7642
7643 IF (ASSOCIATED(this%dativarattr%b)) THEN
7644 DO i = 1, SIZE(this%dativar%d)
7645 this%dativar%d(i)%b = &
7646 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
7647 ENDDO
7648 ENDIF
7649
7650 IF (ASSOCIATED(this%dativarattr%c)) THEN
7651 DO i = 1, SIZE(this%dativar%d)
7652 this%dativar%d(i)%c = &
7653 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
7654 ENDDO
7655 ENDIF
7656ENDIF
7657! integer
7658IF (ASSOCIATED(this%dativar%i)) THEN
7659 IF (ASSOCIATED(this%dativarattr%r)) THEN
7660 DO i = 1, SIZE(this%dativar%i)
7661 this%dativar%i(i)%r = &
7662 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
7663 ENDDO
7664 ENDIF
7665
7666 IF (ASSOCIATED(this%dativarattr%d)) THEN
7667 DO i = 1, SIZE(this%dativar%i)
7668 this%dativar%i(i)%d = &
7669 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
7670 ENDDO
7671 ENDIF
7672
7673 IF (ASSOCIATED(this%dativarattr%i)) THEN
7674 DO i = 1, SIZE(this%dativar%i)
7675 this%dativar%i(i)%i = &
7676 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
7677 ENDDO
7678 ENDIF
7679
7680 IF (ASSOCIATED(this%dativarattr%b)) THEN
7681 DO i = 1, SIZE(this%dativar%i)
7682 this%dativar%i(i)%b = &
7683 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
7684 ENDDO
7685 ENDIF
7686
7687 IF (ASSOCIATED(this%dativarattr%c)) THEN
7688 DO i = 1, SIZE(this%dativar%i)
7689 this%dativar%i(i)%c = &
7690 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
7691 ENDDO
7692 ENDIF
7693ENDIF
7694! byte
7695IF (ASSOCIATED(this%dativar%b)) THEN
7696 IF (ASSOCIATED(this%dativarattr%r)) THEN
7697 DO i = 1, SIZE(this%dativar%b)
7698 this%dativar%b(i)%r = &
7699 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
7700 ENDDO
7701 ENDIF
7702
7703 IF (ASSOCIATED(this%dativarattr%d)) THEN
7704 DO i = 1, SIZE(this%dativar%b)
7705 this%dativar%b(i)%d = &
7706 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
7707 ENDDO
7708 ENDIF
7709
7710 IF (ASSOCIATED(this%dativarattr%i)) THEN
7711 DO i = 1, SIZE(this%dativar%b)
7712 this%dativar%b(i)%i = &
7713 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
7714 ENDDO
7715 ENDIF
7716
7717 IF (ASSOCIATED(this%dativarattr%b)) THEN
7718 DO i = 1, SIZE(this%dativar%b)
7719 this%dativar%b(i)%b = &
7720 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
7721 ENDDO
7722 ENDIF
7723
7724 IF (ASSOCIATED(this%dativarattr%c)) THEN
7725 DO i = 1, SIZE(this%dativar%b)
7726 this%dativar%b(i)%c = &
7727 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
7728 ENDDO
7729 ENDIF
7730ENDIF
7731! character
7732IF (ASSOCIATED(this%dativar%c)) THEN
7733 IF (ASSOCIATED(this%dativarattr%r)) THEN
7734 DO i = 1, SIZE(this%dativar%c)
7735 this%dativar%c(i)%r = &
7736 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
7737 ENDDO
7738 ENDIF
7739
7740 IF (ASSOCIATED(this%dativarattr%d)) THEN
7741 DO i = 1, SIZE(this%dativar%c)
7742 this%dativar%c(i)%d = &
7743 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
7744 ENDDO
7745 ENDIF
7746
7747 IF (ASSOCIATED(this%dativarattr%i)) THEN
7748 DO i = 1, SIZE(this%dativar%c)
7749 this%dativar%c(i)%i = &
7750 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
7751 ENDDO
7752 ENDIF
7753
7754 IF (ASSOCIATED(this%dativarattr%b)) THEN
7755 DO i = 1, SIZE(this%dativar%c)
7756 this%dativar%c(i)%b = &
7757 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
7758 ENDDO
7759 ENDIF
7760
7761 IF (ASSOCIATED(this%dativarattr%c)) THEN
7762 DO i = 1, SIZE(this%dativar%c)
7763 this%dativar%c(i)%c = &
7764 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
7765 ENDDO
7766 ENDIF
7767ENDIF
7768
7769END SUBROUTINE vol7d_set_attr_ind
7770
7771
7776SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
7777 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7778TYPE(vol7d),INTENT(INOUT) :: this
7779TYPE(vol7d),INTENT(INOUT) :: that
7780LOGICAL,INTENT(IN),OPTIONAL :: sort
7781LOGICAL,INTENT(in),OPTIONAL :: bestdata
7782LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
7783
7784TYPE(vol7d) :: v7d_clean
7785
7786
7788 this = that
7790 that = v7d_clean ! destroy that without deallocating
7791ELSE ! Append that to this and destroy that
7793 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
7795ENDIF
7796
7797END SUBROUTINE vol7d_merge
7798
7799
7828SUBROUTINE vol7d_append(this, that, sort, bestdata, &
7829 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
7830TYPE(vol7d),INTENT(INOUT) :: this
7831TYPE(vol7d),INTENT(IN) :: that
7832LOGICAL,INTENT(IN),OPTIONAL :: sort
7833! experimental, please do not use outside the library now, they force the use
7834! of a simplified mapping algorithm which is valid only whene the dimension
7835! content is the same in both volumes , or when one of them is empty
7836LOGICAL,INTENT(in),OPTIONAL :: bestdata
7837LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
7838
7839
7840TYPE(vol7d) :: v7dtmp
7841LOGICAL :: lsort, lbestdata
7842INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
7843 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
7844
7846IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
7849 RETURN
7850ENDIF
7851
7852IF (this%time_definition /= that%time_definition) THEN
7853 CALL l4f_log(l4f_fatal, &
7854 'in vol7d_append, cannot append volumes with different &
7855 &time definition')
7856 CALL raise_fatal_error()
7857ENDIF
7858
7859! Completo l'allocazione per avere volumi a norma
7860CALL vol7d_alloc_vol(this)
7861
7865
7866! Calcolo le mappature tra volumi vecchi e volume nuovo
7867! I puntatori remap* vengono tutti o allocati o nullificati
7868IF (optio_log(ltimesimple)) THEN
7869 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
7870 lsort, remapt1, remapt2)
7871ELSE
7872 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
7873 lsort, remapt1, remapt2)
7874ENDIF
7875IF (optio_log(ltimerangesimple)) THEN
7876 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
7877 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7878ELSE
7879 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
7880 v7dtmp%timerange, lsort, remaptr1, remaptr2)
7881ENDIF
7882IF (optio_log(llevelsimple)) THEN
7883 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
7884 lsort, remapl1, remapl2)
7885ELSE
7886 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
7887 lsort, remapl1, remapl2)
7888ENDIF
7889IF (optio_log(lanasimple)) THEN
7890 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7891 .false., remapa1, remapa2)
7892ELSE
7893 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
7894 .false., remapa1, remapa2)
7895ENDIF
7896IF (optio_log(lnetworksimple)) THEN
7897 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
7898 .false., remapn1, remapn2)
7899ELSE
7900 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
7901 .false., remapn1, remapn2)
7902ENDIF
7903
7904! Faccio la fusione fisica dei volumi
7905CALL vol7d_merge_finalr(this, that, v7dtmp, &
7906 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7907 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7908CALL vol7d_merge_finald(this, that, v7dtmp, &
7909 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7910 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7911CALL vol7d_merge_finali(this, that, v7dtmp, &
7912 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7913 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7914CALL vol7d_merge_finalb(this, that, v7dtmp, &
7915 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7916 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7917CALL vol7d_merge_finalc(this, that, v7dtmp, &
7918 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
7919 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
7920
7921! Dealloco i vettori di rimappatura
7922IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
7923IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
7924IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
7925IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
7926IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
7927IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
7928IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
7929IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
7930IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
7931IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
7932
7933! Distruggo il vecchio volume e assegno il nuovo a this
7935this = v7dtmp
7936! Ricreo gli indici var-attr
7937CALL vol7d_set_attr_ind(this)
7938
7939END SUBROUTINE vol7d_append
7940
7941
7974SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
7975 lsort_time, lsort_timerange, lsort_level, &
7976 ltime, ltimerange, llevel, lana, lnetwork, &
7977 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
7978 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
7979 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
7980 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
7981 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
7982 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
7983TYPE(vol7d),INTENT(IN) :: this
7984TYPE(vol7d),INTENT(INOUT) :: that
7985LOGICAL,INTENT(IN),OPTIONAL :: sort
7986LOGICAL,INTENT(IN),OPTIONAL :: unique
7987LOGICAL,INTENT(IN),OPTIONAL :: miss
7988LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
7989LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
7990LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
7998LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
8000LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
8002LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
8004LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
8006LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
8008LOGICAL,INTENT(in),OPTIONAL :: &
8009 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
8010 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
8011 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
8012 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
8013 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
8014 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
8015
8016LOGICAL :: lsort, lunique, lmiss
8017INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
8018
8021IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
8022
8026
8027! Calcolo le mappature tra volume vecchio e volume nuovo
8028! I puntatori remap* vengono tutti o allocati o nullificati
8029CALL vol7d_remap1_datetime(this%time, that%time, &
8030 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
8031CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
8032 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
8033CALL vol7d_remap1_vol7d_level(this%level, that%level, &
8034 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
8035CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
8036 lsort, lunique, lmiss, remapa, lana)
8037CALL vol7d_remap1_vol7d_network(this%network, that%network, &
8038 lsort, lunique, lmiss, remapn, lnetwork)
8039
8040! lanavari, lanavarb, lanavarc, &
8041! lanaattri, lanaattrb, lanaattrc, &
8042! lanavarattri, lanavarattrb, lanavarattrc, &
8043! ldativari, ldativarb, ldativarc, &
8044! ldatiattri, ldatiattrb, ldatiattrc, &
8045! ldativarattri, ldativarattrb, ldativarattrc
8046! Faccio la riforma fisica dei volumi
8047CALL vol7d_reform_finalr(this, that, &
8048 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8049 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
8050CALL vol7d_reform_finald(this, that, &
8051 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8052 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
8053CALL vol7d_reform_finali(this, that, &
8054 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8055 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
8056CALL vol7d_reform_finalb(this, that, &
8057 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8058 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
8059CALL vol7d_reform_finalc(this, that, &
8060 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
8061 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
8062
8063! Dealloco i vettori di rimappatura
8064IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
8065IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
8066IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
8067IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
8068IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
8069
8070! Ricreo gli indici var-attr
8071CALL vol7d_set_attr_ind(that)
8072that%time_definition = this%time_definition
8073
8074END SUBROUTINE vol7d_copy
8075
8076
8087SUBROUTINE vol7d_reform(this, sort, unique, miss, &
8088 lsort_time, lsort_timerange, lsort_level, &
8089 ltime, ltimerange, llevel, lana, lnetwork, &
8090 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
8091 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
8092 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
8093 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
8094 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
8095 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
8096 ,purgeana)
8097TYPE(vol7d),INTENT(INOUT) :: this
8098LOGICAL,INTENT(IN),OPTIONAL :: sort
8099LOGICAL,INTENT(IN),OPTIONAL :: unique
8100LOGICAL,INTENT(IN),OPTIONAL :: miss
8101LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
8102LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
8103LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
8111LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
8112LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
8113LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
8114LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
8115LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
8117LOGICAL,INTENT(in),OPTIONAL :: &
8118 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
8119 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
8120 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
8121 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
8122 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
8123 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
8124LOGICAL,INTENT(IN),OPTIONAL :: purgeana
8125
8126TYPE(vol7d) :: v7dtmp
8127logical,allocatable :: llana(:)
8128integer :: i
8129
8131 lsort_time, lsort_timerange, lsort_level, &
8132 ltime, ltimerange, llevel, lana, lnetwork, &
8133 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
8134 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
8135 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
8136 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
8137 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
8138 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
8139
8140! destroy old volume
8142
8143if (optio_log(purgeana)) then
8144 allocate(llana(size(v7dtmp%ana)))
8145 llana =.false.
8146 do i =1,size(v7dtmp%ana)
8147 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
8148 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
8149 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
8150 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
8151 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
8152 end do
8153 CALL vol7d_copy(v7dtmp, this,lana=llana)
8155 deallocate(llana)
8156else
8157 this=v7dtmp
8158end if
8159
8160END SUBROUTINE vol7d_reform
8161
8162
8170SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
8171TYPE(vol7d),INTENT(INOUT) :: this
8172LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
8173LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
8174LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
8175
8176INTEGER :: i
8177LOGICAL :: to_be_sorted
8178
8179to_be_sorted = .false.
8180CALL vol7d_alloc_vol(this) ! usual safety check
8181
8182IF (optio_log(lsort_time)) THEN
8183 DO i = 2, SIZE(this%time)
8184 IF (this%time(i) < this%time(i-1)) THEN
8185 to_be_sorted = .true.
8186 EXIT
8187 ENDIF
8188 ENDDO
8189ENDIF
8190IF (optio_log(lsort_timerange)) THEN
8191 DO i = 2, SIZE(this%timerange)
8192 IF (this%timerange(i) < this%timerange(i-1)) THEN
8193 to_be_sorted = .true.
8194 EXIT
8195 ENDIF
8196 ENDDO
8197ENDIF
8198IF (optio_log(lsort_level)) THEN
8199 DO i = 2, SIZE(this%level)
8200 IF (this%level(i) < this%level(i-1)) THEN
8201 to_be_sorted = .true.
8202 EXIT
8203 ENDIF
8204 ENDDO
8205ENDIF
8206
8207IF (to_be_sorted) CALL vol7d_reform(this, &
8208 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
8209
8210END SUBROUTINE vol7d_smart_sort
8211
8219SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
8220TYPE(vol7d),INTENT(inout) :: this
8221CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
8222CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
8223TYPE(vol7d_network),OPTIONAL :: nl(:)
8224TYPE(datetime),INTENT(in),OPTIONAL :: s_d
8225TYPE(datetime),INTENT(in),OPTIONAL :: e_d
8226
8227INTEGER :: i
8228
8229IF (PRESENT(avl)) THEN
8230 IF (SIZE(avl) > 0) THEN
8231
8232 IF (ASSOCIATED(this%anavar%r)) THEN
8233 DO i = 1, SIZE(this%anavar%r)
8234 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
8235 ENDDO
8236 ENDIF
8237
8238 IF (ASSOCIATED(this%anavar%i)) THEN
8239 DO i = 1, SIZE(this%anavar%i)
8240 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
8241 ENDDO
8242 ENDIF
8243
8244 IF (ASSOCIATED(this%anavar%b)) THEN
8245 DO i = 1, SIZE(this%anavar%b)
8246 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
8247 ENDDO
8248 ENDIF
8249
8250 IF (ASSOCIATED(this%anavar%d)) THEN
8251 DO i = 1, SIZE(this%anavar%d)
8252 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
8253 ENDDO
8254 ENDIF
8255
8256 IF (ASSOCIATED(this%anavar%c)) THEN
8257 DO i = 1, SIZE(this%anavar%c)
8258 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
8259 ENDDO
8260 ENDIF
8261
8262 ENDIF
8263ENDIF
8264
8265
8266IF (PRESENT(vl)) THEN
8267 IF (size(vl) > 0) THEN
8268 IF (ASSOCIATED(this%dativar%r)) THEN
8269 DO i = 1, SIZE(this%dativar%r)
8270 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
8271 ENDDO
8272 ENDIF
8273
8274 IF (ASSOCIATED(this%dativar%i)) THEN
8275 DO i = 1, SIZE(this%dativar%i)
8276 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
8277 ENDDO
8278 ENDIF
8279
8280 IF (ASSOCIATED(this%dativar%b)) THEN
8281 DO i = 1, SIZE(this%dativar%b)
8282 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
8283 ENDDO
8284 ENDIF
8285
8286 IF (ASSOCIATED(this%dativar%d)) THEN
8287 DO i = 1, SIZE(this%dativar%d)
8288 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
8289 ENDDO
8290 ENDIF
8291
8292 IF (ASSOCIATED(this%dativar%c)) THEN
8293 DO i = 1, SIZE(this%dativar%c)
8294 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
8295 ENDDO
8296 ENDIF
8297
8298 IF (ASSOCIATED(this%dativar%c)) THEN
8299 DO i = 1, SIZE(this%dativar%c)
8300 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
8301 ENDDO
8302 ENDIF
8303
8304 ENDIF
8305ENDIF
8306
8307IF (PRESENT(nl)) THEN
8308 IF (SIZE(nl) > 0) THEN
8309 DO i = 1, SIZE(this%network)
8310 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
8311 ENDDO
8312 ENDIF
8313ENDIF
8314
8315IF (PRESENT(s_d)) THEN
8317 WHERE (this%time < s_d)
8318 this%time = datetime_miss
8319 END WHERE
8320 ENDIF
8321ENDIF
8322
8323IF (PRESENT(e_d)) THEN
8325 WHERE (this%time > e_d)
8326 this%time = datetime_miss
8327 END WHERE
8328 ENDIF
8329ENDIF
8330
8331CALL vol7d_reform(this, miss=.true.)
8332
8333END SUBROUTINE vol7d_filter
8334
8335
8342SUBROUTINE vol7d_convr(this, that, anaconv)
8343TYPE(vol7d),INTENT(IN) :: this
8344TYPE(vol7d),INTENT(INOUT) :: that
8345LOGICAL,OPTIONAL,INTENT(in) :: anaconv
8346INTEGER :: i
8347LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
8348TYPE(vol7d) :: v7d_tmp
8349
8350IF (optio_log(anaconv)) THEN
8351 acp=fv
8352 acn=tv
8353ELSE
8354 acp=tv
8355 acn=fv
8356ENDIF
8357
8358! Volume con solo i dati reali e tutti gli attributi
8359! l'anagrafica e` copiata interamente se necessario
8360CALL vol7d_copy(this, that, &
8361 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
8362 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
8363
8364! Volume solo di dati double
8365CALL vol7d_copy(this, v7d_tmp, &
8366 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
8367 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8368 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8369 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
8370 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8371 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8372
8373! converto a dati reali
8374IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
8375
8376 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
8377! alloco i dati reali e vi trasferisco i double
8378 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
8379 SIZE(v7d_tmp%volanad, 3)))
8380 DO i = 1, SIZE(v7d_tmp%anavar%d)
8381 v7d_tmp%volanar(:,i,:) = &
8382 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
8383 ENDDO
8384 DEALLOCATE(v7d_tmp%volanad)
8385! trasferisco le variabili
8386 v7d_tmp%anavar%r => v7d_tmp%anavar%d
8387 NULLIFY(v7d_tmp%anavar%d)
8388 ENDIF
8389
8390 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
8391! alloco i dati reali e vi trasferisco i double
8392 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
8393 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
8394 SIZE(v7d_tmp%voldatid, 6)))
8395 DO i = 1, SIZE(v7d_tmp%dativar%d)
8396 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8397 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
8398 ENDDO
8399 DEALLOCATE(v7d_tmp%voldatid)
8400! trasferisco le variabili
8401 v7d_tmp%dativar%r => v7d_tmp%dativar%d
8402 NULLIFY(v7d_tmp%dativar%d)
8403 ENDIF
8404
8405! fondo con il volume definitivo
8406 CALL vol7d_merge(that, v7d_tmp)
8407ELSE
8409ENDIF
8410
8411
8412! Volume solo di dati interi
8413CALL vol7d_copy(this, v7d_tmp, &
8414 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
8415 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8416 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8417 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
8418 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8419 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8420
8421! converto a dati reali
8422IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
8423
8424 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
8425! alloco i dati reali e vi trasferisco gli interi
8426 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
8427 SIZE(v7d_tmp%volanai, 3)))
8428 DO i = 1, SIZE(v7d_tmp%anavar%i)
8429 v7d_tmp%volanar(:,i,:) = &
8430 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
8431 ENDDO
8432 DEALLOCATE(v7d_tmp%volanai)
8433! trasferisco le variabili
8434 v7d_tmp%anavar%r => v7d_tmp%anavar%i
8435 NULLIFY(v7d_tmp%anavar%i)
8436 ENDIF
8437
8438 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
8439! alloco i dati reali e vi trasferisco gli interi
8440 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
8441 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
8442 SIZE(v7d_tmp%voldatii, 6)))
8443 DO i = 1, SIZE(v7d_tmp%dativar%i)
8444 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8445 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
8446 ENDDO
8447 DEALLOCATE(v7d_tmp%voldatii)
8448! trasferisco le variabili
8449 v7d_tmp%dativar%r => v7d_tmp%dativar%i
8450 NULLIFY(v7d_tmp%dativar%i)
8451 ENDIF
8452
8453! fondo con il volume definitivo
8454 CALL vol7d_merge(that, v7d_tmp)
8455ELSE
8457ENDIF
8458
8459
8460! Volume solo di dati byte
8461CALL vol7d_copy(this, v7d_tmp, &
8462 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
8463 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8464 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8465 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
8466 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8467 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8468
8469! converto a dati reali
8470IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
8471
8472 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
8473! alloco i dati reali e vi trasferisco i byte
8474 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
8475 SIZE(v7d_tmp%volanab, 3)))
8476 DO i = 1, SIZE(v7d_tmp%anavar%b)
8477 v7d_tmp%volanar(:,i,:) = &
8478 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
8479 ENDDO
8480 DEALLOCATE(v7d_tmp%volanab)
8481! trasferisco le variabili
8482 v7d_tmp%anavar%r => v7d_tmp%anavar%b
8483 NULLIFY(v7d_tmp%anavar%b)
8484 ENDIF
8485
8486 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
8487! alloco i dati reali e vi trasferisco i byte
8488 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
8489 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
8490 SIZE(v7d_tmp%voldatib, 6)))
8491 DO i = 1, SIZE(v7d_tmp%dativar%b)
8492 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8493 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
8494 ENDDO
8495 DEALLOCATE(v7d_tmp%voldatib)
8496! trasferisco le variabili
8497 v7d_tmp%dativar%r => v7d_tmp%dativar%b
8498 NULLIFY(v7d_tmp%dativar%b)
8499 ENDIF
8500
8501! fondo con il volume definitivo
8502 CALL vol7d_merge(that, v7d_tmp)
8503ELSE
8505ENDIF
8506
8507
8508! Volume solo di dati character
8509CALL vol7d_copy(this, v7d_tmp, &
8510 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
8511 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
8512 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
8513 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
8514 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
8515 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
8516
8517! converto a dati reali
8518IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
8519
8520 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
8521! alloco i dati reali e vi trasferisco i character
8522 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
8523 SIZE(v7d_tmp%volanac, 3)))
8524 DO i = 1, SIZE(v7d_tmp%anavar%c)
8525 v7d_tmp%volanar(:,i,:) = &
8526 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
8527 ENDDO
8528 DEALLOCATE(v7d_tmp%volanac)
8529! trasferisco le variabili
8530 v7d_tmp%anavar%r => v7d_tmp%anavar%c
8531 NULLIFY(v7d_tmp%anavar%c)
8532 ENDIF
8533
8534 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
8535! alloco i dati reali e vi trasferisco i character
8536 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
8537 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
8538 SIZE(v7d_tmp%voldatic, 6)))
8539 DO i = 1, SIZE(v7d_tmp%dativar%c)
8540 v7d_tmp%voldatir(:,:,:,:,i,:) = &
8541 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
8542 ENDDO
8543 DEALLOCATE(v7d_tmp%voldatic)
8544! trasferisco le variabili
8545 v7d_tmp%dativar%r => v7d_tmp%dativar%c
8546 NULLIFY(v7d_tmp%dativar%c)
8547 ENDIF
8548
8549! fondo con il volume definitivo
8550 CALL vol7d_merge(that, v7d_tmp)
8551ELSE
8553ENDIF
8554
8555END SUBROUTINE vol7d_convr
8556
8557
8561SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
8562TYPE(vol7d),INTENT(IN) :: this
8563TYPE(vol7d),INTENT(OUT) :: that
8564logical , optional, intent(in) :: data_only
8565logical , optional, intent(in) :: ana
8566logical :: ldata_only,lana
8567
8568IF (PRESENT(data_only)) THEN
8569 ldata_only = data_only
8570ELSE
8571 ldata_only = .false.
8572ENDIF
8573
8574IF (PRESENT(ana)) THEN
8575 lana = ana
8576ELSE
8577 lana = .false.
8578ENDIF
8579
8580
8581#undef VOL7D_POLY_ARRAY
8582#define VOL7D_POLY_ARRAY voldati
8583#include "vol7d_class_diff.F90"
8584#undef VOL7D_POLY_ARRAY
8585#define VOL7D_POLY_ARRAY voldatiattr
8586#include "vol7d_class_diff.F90"
8587#undef VOL7D_POLY_ARRAY
8588
8589if ( .not. ldata_only) then
8590
8591#define VOL7D_POLY_ARRAY volana
8592#include "vol7d_class_diff.F90"
8593#undef VOL7D_POLY_ARRAY
8594#define VOL7D_POLY_ARRAY volanaattr
8595#include "vol7d_class_diff.F90"
8596#undef VOL7D_POLY_ARRAY
8597
8598 if(lana)then
8599 where ( this%ana == that%ana )
8600 that%ana = vol7d_ana_miss
8601 end where
8602 end if
8603
8604end if
8605
8606
8607
8608END SUBROUTINE vol7d_diff_only
8609
8610
8611
8612! Creo le routine da ripetere per i vari tipi di dati di v7d
8613! tramite un template e il preprocessore
8614#undef VOL7D_POLY_TYPE
8615#undef VOL7D_POLY_TYPES
8616#define VOL7D_POLY_TYPE REAL
8617#define VOL7D_POLY_TYPES r
8618#include "vol7d_class_type_templ.F90"
8619#undef VOL7D_POLY_TYPE
8620#undef VOL7D_POLY_TYPES
8621#define VOL7D_POLY_TYPE DOUBLE PRECISION
8622#define VOL7D_POLY_TYPES d
8623#include "vol7d_class_type_templ.F90"
8624#undef VOL7D_POLY_TYPE
8625#undef VOL7D_POLY_TYPES
8626#define VOL7D_POLY_TYPE INTEGER
8627#define VOL7D_POLY_TYPES i
8628#include "vol7d_class_type_templ.F90"
8629#undef VOL7D_POLY_TYPE
8630#undef VOL7D_POLY_TYPES
8631#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
8632#define VOL7D_POLY_TYPES b
8633#include "vol7d_class_type_templ.F90"
8634#undef VOL7D_POLY_TYPE
8635#undef VOL7D_POLY_TYPES
8636#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
8637#define VOL7D_POLY_TYPES c
8638#include "vol7d_class_type_templ.F90"
8639
8640! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
8641! tramite un template e il preprocessore
8642#define VOL7D_SORT
8643#undef VOL7D_NO_ZERO_ALLOC
8644#undef VOL7D_POLY_TYPE
8645#define VOL7D_POLY_TYPE datetime
8646#include "vol7d_class_desc_templ.F90"
8647#undef VOL7D_POLY_TYPE
8648#define VOL7D_POLY_TYPE vol7d_timerange
8649#include "vol7d_class_desc_templ.F90"
8650#undef VOL7D_POLY_TYPE
8651#define VOL7D_POLY_TYPE vol7d_level
8652#include "vol7d_class_desc_templ.F90"
8653#undef VOL7D_SORT
8654#undef VOL7D_POLY_TYPE
8655#define VOL7D_POLY_TYPE vol7d_network
8656#include "vol7d_class_desc_templ.F90"
8657#undef VOL7D_POLY_TYPE
8658#define VOL7D_POLY_TYPE vol7d_ana
8659#include "vol7d_class_desc_templ.F90"
8660#define VOL7D_NO_ZERO_ALLOC
8661#undef VOL7D_POLY_TYPE
8662#define VOL7D_POLY_TYPE vol7d_var
8663#include "vol7d_class_desc_templ.F90"
8664
8674subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
8675
8676TYPE(vol7d),INTENT(IN) :: this
8677integer,optional,intent(inout) :: unit
8678character(len=*),intent(in),optional :: filename
8679character(len=*),intent(out),optional :: filename_auto
8680character(len=*),INTENT(IN),optional :: description
8681
8682integer :: lunit
8683character(len=254) :: ldescription,arg,lfilename
8684integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8685 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8686 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8687 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8688 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8689 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8690 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8691!integer :: im,id,iy
8692integer :: tarray(8)
8693logical :: opened,exist
8694
8695 nana=0
8696 ntime=0
8697 ntimerange=0
8698 nlevel=0
8699 nnetwork=0
8700 ndativarr=0
8701 ndativari=0
8702 ndativarb=0
8703 ndativard=0
8704 ndativarc=0
8705 ndatiattrr=0
8706 ndatiattri=0
8707 ndatiattrb=0
8708 ndatiattrd=0
8709 ndatiattrc=0
8710 ndativarattrr=0
8711 ndativarattri=0
8712 ndativarattrb=0
8713 ndativarattrd=0
8714 ndativarattrc=0
8715 nanavarr=0
8716 nanavari=0
8717 nanavarb=0
8718 nanavard=0
8719 nanavarc=0
8720 nanaattrr=0
8721 nanaattri=0
8722 nanaattrb=0
8723 nanaattrd=0
8724 nanaattrc=0
8725 nanavarattrr=0
8726 nanavarattri=0
8727 nanavarattrb=0
8728 nanavarattrd=0
8729 nanavarattrc=0
8730
8731
8732!call idate(im,id,iy)
8733call date_and_time(values=tarray)
8734call getarg(0,arg)
8735
8736if (present(description))then
8737 ldescription=description
8738else
8739 ldescription="Vol7d generated by: "//trim(arg)
8740end if
8741
8742if (.not. present(unit))then
8743 lunit=getunit()
8744else
8745 if (unit==0)then
8746 lunit=getunit()
8747 unit=lunit
8748 else
8749 lunit=unit
8750 end if
8751end if
8752
8753lfilename=trim(arg)//".v7d"
8755
8756if (present(filename))then
8757 if (filename /= "")then
8758 lfilename=filename
8759 end if
8760end if
8761
8762if (present(filename_auto))filename_auto=lfilename
8763
8764
8765inquire(unit=lunit,opened=opened)
8766if (.not. opened) then
8767! inquire(file=lfilename, EXIST=exist)
8768! IF (exist) THEN
8769! CALL l4f_log(L4F_FATAL, &
8770! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
8771! CALL raise_fatal_error()
8772! ENDIF
8773 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
8774 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8775end if
8776
8777if (associated(this%ana)) nana=size(this%ana)
8778if (associated(this%time)) ntime=size(this%time)
8779if (associated(this%timerange)) ntimerange=size(this%timerange)
8780if (associated(this%level)) nlevel=size(this%level)
8781if (associated(this%network)) nnetwork=size(this%network)
8782
8783if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
8784if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
8785if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
8786if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
8787if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
8788
8789if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
8790if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
8791if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
8792if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
8793if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
8794
8795if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
8796if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
8797if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
8798if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
8799if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
8800
8801if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
8802if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
8803if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
8804if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
8805if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
8806
8807if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
8808if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
8809if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
8810if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
8811if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
8812
8813if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
8814if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
8815if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
8816if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
8817if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
8818
8819write(unit=lunit)ldescription
8820write(unit=lunit)tarray
8821
8822write(unit=lunit)&
8823 nana, ntime, ntimerange, nlevel, nnetwork, &
8824 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8825 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8826 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8827 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8828 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8829 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
8830 this%time_definition
8831
8832
8833!write(unit=lunit)this
8834
8835
8836!! prime 5 dimensioni
8839if (associated(this%level)) write(unit=lunit)this%level
8840if (associated(this%timerange)) write(unit=lunit)this%timerange
8841if (associated(this%network)) write(unit=lunit)this%network
8842
8843 !! 6a dimensione: variabile dell'anagrafica e dei dati
8844 !! con relativi attributi e in 5 tipi diversi
8845
8846if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
8847if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
8848if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
8849if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
8850if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
8851
8852if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
8853if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
8854if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
8855if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
8856if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
8857
8858if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
8859if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
8860if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
8861if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
8862if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
8863
8864if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
8865if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
8866if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
8867if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
8868if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
8869
8870if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
8871if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
8872if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
8873if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
8874if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
8875
8876if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
8877if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
8878if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
8879if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
8880if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
8881
8882!! Volumi di valori e attributi per anagrafica e dati
8883
8884if (associated(this%volanar)) write(unit=lunit)this%volanar
8885if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
8886if (associated(this%voldatir)) write(unit=lunit)this%voldatir
8887if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
8888
8889if (associated(this%volanai)) write(unit=lunit)this%volanai
8890if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
8891if (associated(this%voldatii)) write(unit=lunit)this%voldatii
8892if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
8893
8894if (associated(this%volanab)) write(unit=lunit)this%volanab
8895if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
8896if (associated(this%voldatib)) write(unit=lunit)this%voldatib
8897if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
8898
8899if (associated(this%volanad)) write(unit=lunit)this%volanad
8900if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
8901if (associated(this%voldatid)) write(unit=lunit)this%voldatid
8902if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
8903
8904if (associated(this%volanac)) write(unit=lunit)this%volanac
8905if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
8906if (associated(this%voldatic)) write(unit=lunit)this%voldatic
8907if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
8908
8909if (.not. present(unit)) close(unit=lunit)
8910
8911end subroutine vol7d_write_on_file
8912
8913
8920
8921
8922subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
8923
8924TYPE(vol7d),INTENT(OUT) :: this
8925integer,intent(inout),optional :: unit
8926character(len=*),INTENT(in),optional :: filename
8927character(len=*),intent(out),optional :: filename_auto
8928character(len=*),INTENT(out),optional :: description
8929integer,intent(out),optional :: tarray(8)
8930
8931
8932integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
8933 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
8934 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
8935 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
8936 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
8937 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
8938 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
8939
8940character(len=254) :: ldescription,lfilename,arg
8941integer :: ltarray(8),lunit,ios
8942logical :: opened,exist
8943
8944
8945call getarg(0,arg)
8946
8947if (.not. present(unit))then
8948 lunit=getunit()
8949else
8950 if (unit==0)then
8951 lunit=getunit()
8952 unit=lunit
8953 else
8954 lunit=unit
8955 end if
8956end if
8957
8958lfilename=trim(arg)//".v7d"
8960
8961if (present(filename))then
8962 if (filename /= "")then
8963 lfilename=filename
8964 end if
8965end if
8966
8967if (present(filename_auto))filename_auto=lfilename
8968
8969
8970inquire(unit=lunit,opened=opened)
8971IF (.NOT. opened) THEN
8972 inquire(file=lfilename,exist=exist)
8973 IF (.NOT.exist) THEN
8974 CALL l4f_log(l4f_fatal, &
8975 'in vol7d_read_from_file, file does not exists, cannot open')
8976 CALL raise_fatal_error()
8977 ENDIF
8978 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
8979 status='OLD', action='READ')
8980 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
8981end if
8982
8983
8985read(unit=lunit,iostat=ios)ldescription
8986
8987if (ios < 0) then ! A negative value indicates that the End of File or End of Record
8988 call vol7d_alloc (this)
8989 call vol7d_alloc_vol (this)
8990 if (present(description))description=ldescription
8991 if (present(tarray))tarray=ltarray
8992 if (.not. present(unit)) close(unit=lunit)
8993end if
8994
8995read(unit=lunit)ltarray
8996
8997CALL l4f_log(l4f_info, 'Reading vol7d from file')
8998CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
9001
9002if (present(description))description=ldescription
9003if (present(tarray))tarray=ltarray
9004
9005read(unit=lunit)&
9006 nana, ntime, ntimerange, nlevel, nnetwork, &
9007 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
9008 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
9009 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
9010 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
9011 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
9012 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
9013 this%time_definition
9014
9015call vol7d_alloc (this, &
9016 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
9017 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
9018 ndativard=ndativard, ndativarc=ndativarc,&
9019 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
9020 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
9021 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
9022 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
9023 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
9024 nanavard=nanavard, nanavarc=nanavarc,&
9025 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
9026 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
9027 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
9028 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
9029
9030
9033if (associated(this%level)) read(unit=lunit)this%level
9034if (associated(this%timerange)) read(unit=lunit)this%timerange
9035if (associated(this%network)) read(unit=lunit)this%network
9036
9037if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
9038if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
9039if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
9040if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
9041if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
9042
9043if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
9044if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
9045if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
9046if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
9047if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
9048
9049if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
9050if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
9051if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
9052if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
9053if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
9054
9055if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
9056if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
9057if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
9058if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
9059if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
9060
9061if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
9062if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
9063if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
9064if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
9065if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
9066
9067if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
9068if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
9069if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
9070if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
9071if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
9072
9073call vol7d_alloc_vol (this)
9074
9075!! Volumi di valori e attributi per anagrafica e dati
9076
9077if (associated(this%volanar)) read(unit=lunit)this%volanar
9078if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
9079if (associated(this%voldatir)) read(unit=lunit)this%voldatir
9080if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
9081
9082if (associated(this%volanai)) read(unit=lunit)this%volanai
9083if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
9084if (associated(this%voldatii)) read(unit=lunit)this%voldatii
9085if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
9086
9087if (associated(this%volanab)) read(unit=lunit)this%volanab
9088if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
9089if (associated(this%voldatib)) read(unit=lunit)this%voldatib
9090if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
9091
9092if (associated(this%volanad)) read(unit=lunit)this%volanad
9093if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
9094if (associated(this%voldatid)) read(unit=lunit)this%voldatid
9095if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
9096
9097if (associated(this%volanac)) read(unit=lunit)this%volanac
9098if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
9099if (associated(this%voldatic)) read(unit=lunit)this%voldatic
9100if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
9101
9102if (.not. present(unit)) close(unit=lunit)
9103
9104end subroutine vol7d_read_from_file
9105
9106
9107! to double precision
9108elemental doubleprecision function doubledatd(voldat,var)
9109doubleprecision,intent(in) :: voldat
9110type(vol7d_var),intent(in) :: var
9111
9112doubledatd=voldat
9113
9114end function doubledatd
9115
9116
9117elemental doubleprecision function doubledatr(voldat,var)
9118real,intent(in) :: voldat
9119type(vol7d_var),intent(in) :: var
9120
9122 doubledatr=dble(voldat)
9123else
9124 doubledatr=dmiss
9125end if
9126
9127end function doubledatr
9128
9129
9130elemental doubleprecision function doubledati(voldat,var)
9131integer,intent(in) :: voldat
9132type(vol7d_var),intent(in) :: var
9133
9136 doubledati=dble(voldat)/10.d0**var%scalefactor
9137 else
9138 doubledati=dble(voldat)
9139 endif
9140else
9141 doubledati=dmiss
9142end if
9143
9144end function doubledati
9145
9146
9147elemental doubleprecision function doubledatb(voldat,var)
9148integer(kind=int_b),intent(in) :: voldat
9149type(vol7d_var),intent(in) :: var
9150
9153 doubledatb=dble(voldat)/10.d0**var%scalefactor
9154 else
9155 doubledatb=dble(voldat)
9156 endif
9157else
9158 doubledatb=dmiss
9159end if
9160
9161end function doubledatb
9162
9163
9164elemental doubleprecision function doubledatc(voldat,var)
9165CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9166type(vol7d_var),intent(in) :: var
9167
9168doubledatc = c2d(voldat)
9170 doubledatc=doubledatc/10.d0**var%scalefactor
9171end if
9172
9173end function doubledatc
9174
9175
9176! to integer
9177elemental integer function integerdatd(voldat,var)
9178doubleprecision,intent(in) :: voldat
9179type(vol7d_var),intent(in) :: var
9180
9183 integerdatd=nint(voldat*10d0**var%scalefactor)
9184 else
9185 integerdatd=nint(voldat)
9186 endif
9187else
9188 integerdatd=imiss
9189end if
9190
9191end function integerdatd
9192
9193
9194elemental integer function integerdatr(voldat,var)
9195real,intent(in) :: voldat
9196type(vol7d_var),intent(in) :: var
9197
9200 integerdatr=nint(voldat*10d0**var%scalefactor)
9201 else
9202 integerdatr=nint(voldat)
9203 endif
9204else
9205 integerdatr=imiss
9206end if
9207
9208end function integerdatr
9209
9210
9211elemental integer function integerdati(voldat,var)
9212integer,intent(in) :: voldat
9213type(vol7d_var),intent(in) :: var
9214
9215integerdati=voldat
9216
9217end function integerdati
9218
9219
9220elemental integer function integerdatb(voldat,var)
9221integer(kind=int_b),intent(in) :: voldat
9222type(vol7d_var),intent(in) :: var
9223
9225 integerdatb=voldat
9226else
9227 integerdatb=imiss
9228end if
9229
9230end function integerdatb
9231
9232
9233elemental integer function integerdatc(voldat,var)
9234CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9235type(vol7d_var),intent(in) :: var
9236
9237integerdatc=c2i(voldat)
9238
9239end function integerdatc
9240
9241
9242! to real
9243elemental real function realdatd(voldat,var)
9244doubleprecision,intent(in) :: voldat
9245type(vol7d_var),intent(in) :: var
9246
9248 realdatd=real(voldat)
9249else
9250 realdatd=rmiss
9251end if
9252
9253end function realdatd
9254
9255
9256elemental real function realdatr(voldat,var)
9257real,intent(in) :: voldat
9258type(vol7d_var),intent(in) :: var
9259
9260realdatr=voldat
9261
9262end function realdatr
9263
9264
9265elemental real function realdati(voldat,var)
9266integer,intent(in) :: voldat
9267type(vol7d_var),intent(in) :: var
9268
9271 realdati=float(voldat)/10.**var%scalefactor
9272 else
9273 realdati=float(voldat)
9274 endif
9275else
9276 realdati=rmiss
9277end if
9278
9279end function realdati
9280
9281
9282elemental real function realdatb(voldat,var)
9283integer(kind=int_b),intent(in) :: voldat
9284type(vol7d_var),intent(in) :: var
9285
9288 realdatb=float(voldat)/10**var%scalefactor
9289 else
9290 realdatb=float(voldat)
9291 endif
9292else
9293 realdatb=rmiss
9294end if
9295
9296end function realdatb
9297
9298
9299elemental real function realdatc(voldat,var)
9300CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
9301type(vol7d_var),intent(in) :: var
9302
9303realdatc=c2r(voldat)
9305 realdatc=realdatc/10.**var%scalefactor
9306end if
9307
9308end function realdatc
9309
9310
9316FUNCTION realanavol(this, var) RESULT(vol)
9317TYPE(vol7d),INTENT(in) :: this
9318TYPE(vol7d_var),INTENT(in) :: var
9319REAL :: vol(SIZE(this%ana),size(this%network))
9320
9321CHARACTER(len=1) :: dtype
9322INTEGER :: indvar
9323
9324dtype = cmiss
9325indvar = index(this%anavar, var, type=dtype)
9326
9327IF (indvar > 0) THEN
9328 SELECT CASE (dtype)
9329 CASE("d")
9330 vol = realdat(this%volanad(:,indvar,:), var)
9331 CASE("r")
9332 vol = this%volanar(:,indvar,:)
9333 CASE("i")
9334 vol = realdat(this%volanai(:,indvar,:), var)
9335 CASE("b")
9336 vol = realdat(this%volanab(:,indvar,:), var)
9337 CASE("c")
9338 vol = realdat(this%volanac(:,indvar,:), var)
9339 CASE default
9340 vol = rmiss
9341 END SELECT
9342ELSE
9343 vol = rmiss
9344ENDIF
9345
9346END FUNCTION realanavol
9347
9348
9354FUNCTION integeranavol(this, var) RESULT(vol)
9355TYPE(vol7d),INTENT(in) :: this
9356TYPE(vol7d_var),INTENT(in) :: var
9357INTEGER :: vol(SIZE(this%ana),size(this%network))
9358
9359CHARACTER(len=1) :: dtype
9360INTEGER :: indvar
9361
9362dtype = cmiss
9363indvar = index(this%anavar, var, type=dtype)
9364
9365IF (indvar > 0) THEN
9366 SELECT CASE (dtype)
9367 CASE("d")
9368 vol = integerdat(this%volanad(:,indvar,:), var)
9369 CASE("r")
9370 vol = integerdat(this%volanar(:,indvar,:), var)
9371 CASE("i")
9372 vol = this%volanai(:,indvar,:)
9373 CASE("b")
9374 vol = integerdat(this%volanab(:,indvar,:), var)
9375 CASE("c")
9376 vol = integerdat(this%volanac(:,indvar,:), var)
9377 CASE default
9378 vol = imiss
9379 END SELECT
9380ELSE
9381 vol = imiss
9382ENDIF
9383
9384END FUNCTION integeranavol
9385
9386
9392subroutine move_datac (v7d,&
9393 indana,indtime,indlevel,indtimerange,indnetwork,&
9394 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
9395
9396TYPE(vol7d),intent(inout) :: v7d
9397
9398integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
9399integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
9400integer :: inddativar,inddativarattr
9401
9402
9403do inddativar=1,size(v7d%dativar%c)
9404
9406 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
9407 ) then
9408
9409 ! dati
9410 v7d%voldatic &
9411 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
9412 v7d%voldatic &
9413 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
9414
9415
9416 ! attributi
9417 if (associated (v7d%dativarattr%i)) then
9418 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
9419 if (inddativarattr > 0 ) then
9420 v7d%voldatiattri &
9421 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9422 v7d%voldatiattri &
9423 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9424 end if
9425 end if
9426
9427 if (associated (v7d%dativarattr%r)) then
9428 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
9429 if (inddativarattr > 0 ) then
9430 v7d%voldatiattrr &
9431 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9432 v7d%voldatiattrr &
9433 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9434 end if
9435 end if
9436
9437 if (associated (v7d%dativarattr%d)) then
9438 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
9439 if (inddativarattr > 0 ) then
9440 v7d%voldatiattrd &
9441 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9442 v7d%voldatiattrd &
9443 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9444 end if
9445 end if
9446
9447 if (associated (v7d%dativarattr%b)) then
9448 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
9449 if (inddativarattr > 0 ) then
9450 v7d%voldatiattrb &
9451 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9452 v7d%voldatiattrb &
9453 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9454 end if
9455 end if
9456
9457 if (associated (v7d%dativarattr%c)) then
9458 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
9459 if (inddativarattr > 0 ) then
9460 v7d%voldatiattrc &
9461 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9462 v7d%voldatiattrc &
9463 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9464 end if
9465 end if
9466
9467 end if
9468
9469end do
9470
9471end subroutine move_datac
9472
9478subroutine move_datar (v7d,&
9479 indana,indtime,indlevel,indtimerange,indnetwork,&
9480 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
9481
9482TYPE(vol7d),intent(inout) :: v7d
9483
9484integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
9485integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
9486integer :: inddativar,inddativarattr
9487
9488
9489do inddativar=1,size(v7d%dativar%r)
9490
9492 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
9493 ) then
9494
9495 ! dati
9496 v7d%voldatir &
9497 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
9498 v7d%voldatir &
9499 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
9500
9501
9502 ! attributi
9503 if (associated (v7d%dativarattr%i)) then
9504 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
9505 if (inddativarattr > 0 ) then
9506 v7d%voldatiattri &
9507 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9508 v7d%voldatiattri &
9509 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9510 end if
9511 end if
9512
9513 if (associated (v7d%dativarattr%r)) then
9514 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
9515 if (inddativarattr > 0 ) then
9516 v7d%voldatiattrr &
9517 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9518 v7d%voldatiattrr &
9519 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9520 end if
9521 end if
9522
9523 if (associated (v7d%dativarattr%d)) then
9524 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
9525 if (inddativarattr > 0 ) then
9526 v7d%voldatiattrd &
9527 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9528 v7d%voldatiattrd &
9529 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9530 end if
9531 end if
9532
9533 if (associated (v7d%dativarattr%b)) then
9534 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
9535 if (inddativarattr > 0 ) then
9536 v7d%voldatiattrb &
9537 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9538 v7d%voldatiattrb &
9539 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9540 end if
9541 end if
9542
9543 if (associated (v7d%dativarattr%c)) then
9544 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
9545 if (inddativarattr > 0 ) then
9546 v7d%voldatiattrc &
9547 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
9548 v7d%voldatiattrc &
9549 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
9550 end if
9551 end if
9552
9553 end if
9554
9555end do
9556
9557end subroutine move_datar
9558
9559
9573subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
9574type(vol7d),intent(inout) :: v7din
9575type(vol7d),intent(out) :: v7dout
9576type(vol7d_level),intent(in),optional :: level(:)
9577type(vol7d_timerange),intent(in),optional :: timerange(:)
9578!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
9579!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
9580logical,intent(in),optional :: nostatproc
9581
9582integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
9583integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
9584type(vol7d_level) :: roundlevel(size(v7din%level))
9585type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
9586type(vol7d) :: v7d_tmp
9587
9588
9589nbin=0
9590
9591if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
9592if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
9593if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
9594if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
9595
9597
9598roundlevel=v7din%level
9599
9600if (present(level))then
9601 do ilevel = 1, size(v7din%level)
9602 if ((any(v7din%level(ilevel) .almosteq. level))) then
9603 roundlevel(ilevel)=level(1)
9604 end if
9605 end do
9606end if
9607
9608roundtimerange=v7din%timerange
9609
9610if (present(timerange))then
9611 do itimerange = 1, size(v7din%timerange)
9612 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
9613 roundtimerange(itimerange)=timerange(1)
9614 end if
9615 end do
9616end if
9617
9618!set istantaneous values everywere
9619!preserve p1 for forecast time
9620if (optio_log(nostatproc)) then
9621 roundtimerange(:)%timerange=254
9622 roundtimerange(:)%p2=0
9623end if
9624
9625
9626nana=size(v7din%ana)
9627nlevel=count_distinct(roundlevel,back=.true.)
9628ntime=size(v7din%time)
9629ntimerange=count_distinct(roundtimerange,back=.true.)
9630nnetwork=size(v7din%network)
9631
9633
9634if (nbin == 0) then
9636else
9637 call vol7d_convr(v7din,v7d_tmp)
9638end if
9639
9640v7d_tmp%level=roundlevel
9641v7d_tmp%timerange=roundtimerange
9642
9643do ilevel=1, size(v7d_tmp%level)
9644 indl=index(v7d_tmp%level,roundlevel(ilevel))
9645 do itimerange=1,size(v7d_tmp%timerange)
9646 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
9647
9648 if (indl /= ilevel .or. indt /= itimerange) then
9649
9650 do iana=1, nana
9651 do itime=1,ntime
9652 do inetwork=1,nnetwork
9653
9654 if (nbin > 0) then
9655 call move_datar (v7d_tmp,&
9656 iana,itime,ilevel,itimerange,inetwork,&
9657 iana,itime,indl,indt,inetwork)
9658 else
9659 call move_datac (v7d_tmp,&
9660 iana,itime,ilevel,itimerange,inetwork,&
9661 iana,itime,indl,indt,inetwork)
9662 end if
9663
9664 end do
9665 end do
9666 end do
9667
9668 end if
9669
9670 end do
9671end do
9672
9673! set to missing level and time > nlevel
9674do ilevel=nlevel+1,size(v7d_tmp%level)
9676end do
9677
9678do itimerange=ntimerange+1,size(v7d_tmp%timerange)
9680end do
9681
9682!copy with remove
9685
9686!call display(v7dout)
9687
9688end subroutine v7d_rounding
9689
9690
9692
9698
9699
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 |