libsim Versione 7.2.1
|
◆ vol7d_get_voldatii()
Crea una vista a dimensione ridotta di un volume di dati di tipo INTEGER. È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio: INTEGER, POINTER :: vol2d(:,:)
...
CALL vol7d_get_voldatii(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
ENDIF
return
Definizione alla linea 4997 del file vol7d_class.F90. 4999! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
5000! authors:
5001! Davide Cesari <dcesari@arpa.emr.it>
5002! Paolo Patruno <ppatruno@arpa.emr.it>
5003
5004! This program is free software; you can redistribute it and/or
5005! modify it under the terms of the GNU General Public License as
5006! published by the Free Software Foundation; either version 2 of
5007! the License, or (at your option) any later version.
5008
5009! This program is distributed in the hope that it will be useful,
5010! but WITHOUT ANY WARRANTY; without even the implied warranty of
5011! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
5012! GNU General Public License for more details.
5013
5014! You should have received a copy of the GNU General Public License
5015! along with this program. If not, see <http://www.gnu.org/licenses/>.
5016#include "config.h"
5017
5029
5097IMPLICIT NONE
5098
5099
5100INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
5101 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
5102
5103INTEGER, PARAMETER :: vol7d_ana_a=1
5104INTEGER, PARAMETER :: vol7d_var_a=2
5105INTEGER, PARAMETER :: vol7d_network_a=3
5106INTEGER, PARAMETER :: vol7d_attr_a=4
5107INTEGER, PARAMETER :: vol7d_ana_d=1
5108INTEGER, PARAMETER :: vol7d_time_d=2
5109INTEGER, PARAMETER :: vol7d_level_d=3
5110INTEGER, PARAMETER :: vol7d_timerange_d=4
5111INTEGER, PARAMETER :: vol7d_var_d=5
5112INTEGER, PARAMETER :: vol7d_network_d=6
5113INTEGER, PARAMETER :: vol7d_attr_d=7
5114INTEGER, PARAMETER :: vol7d_cdatalen=32
5115
5116TYPE vol7d_varmap
5117 INTEGER :: r, d, i, b, c
5118END TYPE vol7d_varmap
5119
5124 TYPE(vol7d_ana),POINTER :: ana(:)
5126 TYPE(datetime),POINTER :: time(:)
5128 TYPE(vol7d_level),POINTER :: level(:)
5130 TYPE(vol7d_timerange),POINTER :: timerange(:)
5132 TYPE(vol7d_network),POINTER :: network(:)
5134 TYPE(vol7d_varvect) :: anavar
5136 TYPE(vol7d_varvect) :: anaattr
5138 TYPE(vol7d_varvect) :: anavarattr
5140 TYPE(vol7d_varvect) :: dativar
5142 TYPE(vol7d_varvect) :: datiattr
5144 TYPE(vol7d_varvect) :: dativarattr
5145
5147 REAL,POINTER :: volanar(:,:,:)
5149 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5151 INTEGER,POINTER :: volanai(:,:,:)
5153 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5155 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5156
5158 REAL,POINTER :: volanaattrr(:,:,:,:)
5160 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5162 INTEGER,POINTER :: volanaattri(:,:,:,:)
5164 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5166 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5167
5169 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5171 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5173 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5175 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5177 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5178
5180 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5182 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5184 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5186 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5188 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5189
5191 integer :: time_definition
5192
5194
5199 MODULE PROCEDURE vol7d_init
5200END INTERFACE
5201
5204 MODULE PROCEDURE vol7d_delete
5205END INTERFACE
5206
5209 MODULE PROCEDURE vol7d_write_on_file
5210END INTERFACE
5211
5213INTERFACE import
5214 MODULE PROCEDURE vol7d_read_from_file
5215END INTERFACE
5216
5219 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5220END INTERFACE
5221
5224 MODULE PROCEDURE to_char_dat
5225END INTERFACE
5226
5229 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5230END INTERFACE
5231
5234 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5235END INTERFACE
5236
5239 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5240END INTERFACE
5241
5244 MODULE PROCEDURE vol7d_copy
5245END INTERFACE
5246
5249 MODULE PROCEDURE vol7d_c_e
5250END INTERFACE
5251
5256 MODULE PROCEDURE vol7d_check
5257END INTERFACE
5258
5273 MODULE PROCEDURE v7d_rounding
5274END INTERFACE
5275
5276!!$INTERFACE get_volana
5277!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
5278!!$ vol7d_get_volanab, vol7d_get_volanac
5279!!$END INTERFACE
5280!!$
5281!!$INTERFACE get_voldati
5282!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
5283!!$ vol7d_get_voldatib, vol7d_get_voldatic
5284!!$END INTERFACE
5285!!$
5286!!$INTERFACE get_volanaattr
5287!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
5288!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
5289!!$END INTERFACE
5290!!$
5291!!$INTERFACE get_voldatiattr
5292!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
5293!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
5294!!$END INTERFACE
5295
5296PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
5297 vol7d_get_volc, &
5298 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
5299 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
5300 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
5301 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
5302 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
5303 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
5304 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
5305 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
5306 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
5307 vol7d_display, dat_display, dat_vect_display, &
5308 to_char_dat, vol7d_check
5309
5310PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5311
5312PRIVATE vol7d_c_e
5313
5314CONTAINS
5315
5316
5321SUBROUTINE vol7d_init(this,time_definition)
5322TYPE(vol7d),intent(out) :: this
5323integer,INTENT(IN),OPTIONAL :: time_definition
5324
5331CALL vol7d_var_features_init() ! initialise var features table once
5332
5333NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
5334
5335NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
5336NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
5337NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
5338NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
5339NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
5340
5341if(present(time_definition)) then
5342 this%time_definition=time_definition
5343else
5344 this%time_definition=1 !default to validity time
5345end if
5346
5347END SUBROUTINE vol7d_init
5348
5349
5353ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
5354TYPE(vol7d),intent(inout) :: this
5355LOGICAL, INTENT(in), OPTIONAL :: dataonly
5356
5357
5358IF (.NOT. optio_log(dataonly)) THEN
5359 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
5360 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
5361 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
5362 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
5363 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
5364 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
5365 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
5366 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
5367 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
5368 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
5369ENDIF
5370IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
5371IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
5372IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
5373IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
5374IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
5375IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
5376IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
5377IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
5378IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
5379IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
5380
5381IF (.NOT. optio_log(dataonly)) THEN
5382 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5383 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5384ENDIF
5385IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5386IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5387IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5388
5389IF (.NOT. optio_log(dataonly)) THEN
5393ENDIF
5397
5398END SUBROUTINE vol7d_delete
5399
5400
5401
5402integer function vol7d_check(this)
5403TYPE(vol7d),intent(in) :: this
5404integer :: i,j,k,l,m,n
5405
5406vol7d_check=0
5407
5408if (associated(this%voldatii)) then
5409do i = 1,size(this%voldatii,1)
5410 do j = 1,size(this%voldatii,2)
5411 do k = 1,size(this%voldatii,3)
5412 do l = 1,size(this%voldatii,4)
5413 do m = 1,size(this%voldatii,5)
5414 do n = 1,size(this%voldatii,6)
5415 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
5416 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
5418 vol7d_check=1
5419 end if
5420 end do
5421 end do
5422 end do
5423 end do
5424 end do
5425end do
5426end if
5427
5428
5429if (associated(this%voldatir)) then
5430do i = 1,size(this%voldatir,1)
5431 do j = 1,size(this%voldatir,2)
5432 do k = 1,size(this%voldatir,3)
5433 do l = 1,size(this%voldatir,4)
5434 do m = 1,size(this%voldatir,5)
5435 do n = 1,size(this%voldatir,6)
5436 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
5437 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
5439 vol7d_check=2
5440 end if
5441 end do
5442 end do
5443 end do
5444 end do
5445 end do
5446end do
5447end if
5448
5449if (associated(this%voldatid)) then
5450do i = 1,size(this%voldatid,1)
5451 do j = 1,size(this%voldatid,2)
5452 do k = 1,size(this%voldatid,3)
5453 do l = 1,size(this%voldatid,4)
5454 do m = 1,size(this%voldatid,5)
5455 do n = 1,size(this%voldatid,6)
5456 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
5457 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
5459 vol7d_check=3
5460 end if
5461 end do
5462 end do
5463 end do
5464 end do
5465 end do
5466end do
5467end if
5468
5469if (associated(this%voldatib)) then
5470do i = 1,size(this%voldatib,1)
5471 do j = 1,size(this%voldatib,2)
5472 do k = 1,size(this%voldatib,3)
5473 do l = 1,size(this%voldatib,4)
5474 do m = 1,size(this%voldatib,5)
5475 do n = 1,size(this%voldatib,6)
5476 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
5477 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
5479 vol7d_check=4
5480 end if
5481 end do
5482 end do
5483 end do
5484 end do
5485 end do
5486end do
5487end if
5488
5489end function vol7d_check
5490
5491
5492
5493!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
5495SUBROUTINE vol7d_display(this)
5496TYPE(vol7d),intent(in) :: this
5497integer :: i
5498
5499REAL :: rdat
5500DOUBLE PRECISION :: ddat
5501INTEGER :: idat
5502INTEGER(kind=int_b) :: bdat
5503CHARACTER(len=vol7d_cdatalen) :: cdat
5504
5505
5506print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
5507if (this%time_definition == 0) then
5508 print*,"TIME DEFINITION: time is reference time"
5509else if (this%time_definition == 1) then
5510 print*,"TIME DEFINITION: time is validity time"
5511else
5512 print*,"Time definition have a wrong walue:", this%time_definition
5513end if
5514
5515IF (ASSOCIATED(this%network))then
5516 print*,"---- network vector ----"
5517 print*,"elements=",size(this%network)
5518 do i=1, size(this%network)
5520 end do
5521end IF
5522
5523IF (ASSOCIATED(this%ana))then
5524 print*,"---- ana vector ----"
5525 print*,"elements=",size(this%ana)
5526 do i=1, size(this%ana)
5528 end do
5529end IF
5530
5531IF (ASSOCIATED(this%time))then
5532 print*,"---- time vector ----"
5533 print*,"elements=",size(this%time)
5534 do i=1, size(this%time)
5536 end do
5537end if
5538
5539IF (ASSOCIATED(this%level)) then
5540 print*,"---- level vector ----"
5541 print*,"elements=",size(this%level)
5542 do i =1,size(this%level)
5544 end do
5545end if
5546
5547IF (ASSOCIATED(this%timerange))then
5548 print*,"---- timerange vector ----"
5549 print*,"elements=",size(this%timerange)
5550 do i =1,size(this%timerange)
5552 end do
5553end if
5554
5555
5556print*,"---- ana vector ----"
5557print*,""
5558print*,"->>>>>>>>> anavar -"
5560print*,""
5561print*,"->>>>>>>>> anaattr -"
5563print*,""
5564print*,"->>>>>>>>> anavarattr -"
5566
5567print*,"-- ana data section (first point) --"
5568
5569idat=imiss
5570rdat=rmiss
5571ddat=dmiss
5572bdat=ibmiss
5573cdat=cmiss
5574
5575!ntime = MIN(SIZE(this%time),nprint)
5576!ntimerange = MIN(SIZE(this%timerange),nprint)
5577!nlevel = MIN(SIZE(this%level),nprint)
5578!nnetwork = MIN(SIZE(this%network),nprint)
5579!nana = MIN(SIZE(this%ana),nprint)
5580
5581IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
5582if (associated(this%volanai)) then
5583 do i=1,size(this%anavar%i)
5584 idat=this%volanai(1,i,1)
5586 end do
5587end if
5588idat=imiss
5589
5590if (associated(this%volanar)) then
5591 do i=1,size(this%anavar%r)
5592 rdat=this%volanar(1,i,1)
5594 end do
5595end if
5596rdat=rmiss
5597
5598if (associated(this%volanad)) then
5599 do i=1,size(this%anavar%d)
5600 ddat=this%volanad(1,i,1)
5602 end do
5603end if
5604ddat=dmiss
5605
5606if (associated(this%volanab)) then
5607 do i=1,size(this%anavar%b)
5608 bdat=this%volanab(1,i,1)
5610 end do
5611end if
5612bdat=ibmiss
5613
5614if (associated(this%volanac)) then
5615 do i=1,size(this%anavar%c)
5616 cdat=this%volanac(1,i,1)
5618 end do
5619end if
5620cdat=cmiss
5621ENDIF
5622
5623print*,"---- data vector ----"
5624print*,""
5625print*,"->>>>>>>>> dativar -"
5627print*,""
5628print*,"->>>>>>>>> datiattr -"
5630print*,""
5631print*,"->>>>>>>>> dativarattr -"
5633
5634print*,"-- data data section (first point) --"
5635
5636idat=imiss
5637rdat=rmiss
5638ddat=dmiss
5639bdat=ibmiss
5640cdat=cmiss
5641
5642IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
5643 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
5644if (associated(this%voldatii)) then
5645 do i=1,size(this%dativar%i)
5646 idat=this%voldatii(1,1,1,1,i,1)
5648 end do
5649end if
5650idat=imiss
5651
5652if (associated(this%voldatir)) then
5653 do i=1,size(this%dativar%r)
5654 rdat=this%voldatir(1,1,1,1,i,1)
5656 end do
5657end if
5658rdat=rmiss
5659
5660if (associated(this%voldatid)) then
5661 do i=1,size(this%dativar%d)
5662 ddat=this%voldatid(1,1,1,1,i,1)
5664 end do
5665end if
5666ddat=dmiss
5667
5668if (associated(this%voldatib)) then
5669 do i=1,size(this%dativar%b)
5670 bdat=this%voldatib(1,1,1,1,i,1)
5672 end do
5673end if
5674bdat=ibmiss
5675
5676if (associated(this%voldatic)) then
5677 do i=1,size(this%dativar%c)
5678 cdat=this%voldatic(1,1,1,1,i,1)
5680 end do
5681end if
5682cdat=cmiss
5683ENDIF
5684
5685print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
5686
5687END SUBROUTINE vol7d_display
5688
5689
5691SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
5692TYPE(vol7d_var),intent(in) :: this
5694REAL :: rdat
5696DOUBLE PRECISION :: ddat
5698INTEGER :: idat
5700INTEGER(kind=int_b) :: bdat
5702CHARACTER(len=*) :: cdat
5703
5704print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5705
5706end SUBROUTINE dat_display
5707
5709SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
5710
5711TYPE(vol7d_var),intent(in) :: this(:)
5713REAL :: rdat(:)
5715DOUBLE PRECISION :: ddat(:)
5717INTEGER :: idat(:)
5719INTEGER(kind=int_b) :: bdat(:)
5721CHARACTER(len=*):: cdat(:)
5722
5723integer :: i
5724
5725do i =1,size(this)
5727end do
5728
5729end SUBROUTINE dat_vect_display
5730
5731
5732FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5733#ifdef HAVE_DBALLE
5734USE dballef
5735#endif
5736TYPE(vol7d_var),INTENT(in) :: this
5738REAL :: rdat
5740DOUBLE PRECISION :: ddat
5742INTEGER :: idat
5744INTEGER(kind=int_b) :: bdat
5746CHARACTER(len=*) :: cdat
5747CHARACTER(len=80) :: to_char_dat
5748
5749CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
5750
5751
5752#ifdef HAVE_DBALLE
5753INTEGER :: handle, ier
5754
5755handle = 0
5756to_char_dat="VALUE: "
5757
5762
5764 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
5765 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
5766 ier = idba_fatto(handle)
5767 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
5768endif
5769
5770#else
5771
5772to_char_dat="VALUE: "
5778
5779#endif
5780
5781END FUNCTION to_char_dat
5782
5783
5786FUNCTION vol7d_c_e(this) RESULT(c_e)
5787TYPE(vol7d), INTENT(in) :: this
5788
5789LOGICAL :: c_e
5790
5792 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5793 ASSOCIATED(this%network) .OR. &
5794 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5795 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5796 ASSOCIATED(this%anavar%c) .OR. &
5797 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5798 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5799 ASSOCIATED(this%anaattr%c) .OR. &
5800 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5801 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5802 ASSOCIATED(this%dativar%c) .OR. &
5803 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5804 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5805 ASSOCIATED(this%datiattr%c)
5806
5807END FUNCTION vol7d_c_e
5808
5809
5848SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5849 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5850 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5851 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5852 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5853 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5854 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5855 ini)
5856TYPE(vol7d),INTENT(inout) :: this
5857INTEGER,INTENT(in),OPTIONAL :: nana
5858INTEGER,INTENT(in),OPTIONAL :: ntime
5859INTEGER,INTENT(in),OPTIONAL :: nlevel
5860INTEGER,INTENT(in),OPTIONAL :: ntimerange
5861INTEGER,INTENT(in),OPTIONAL :: nnetwork
5863INTEGER,INTENT(in),OPTIONAL :: &
5864 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5865 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5866 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5867 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5868 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5869 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5870LOGICAL,INTENT(in),OPTIONAL :: ini
5871
5872INTEGER :: i
5873LOGICAL :: linit
5874
5875IF (PRESENT(ini)) THEN
5876 linit = ini
5877ELSE
5878 linit = .false.
5879ENDIF
5880
5881! Dimensioni principali
5882IF (PRESENT(nana)) THEN
5883 IF (nana >= 0) THEN
5884 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5885 ALLOCATE(this%ana(nana))
5886 IF (linit) THEN
5887 DO i = 1, nana
5889 ENDDO
5890 ENDIF
5891 ENDIF
5892ENDIF
5893IF (PRESENT(ntime)) THEN
5894 IF (ntime >= 0) THEN
5895 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5896 ALLOCATE(this%time(ntime))
5897 IF (linit) THEN
5898 DO i = 1, ntime
5900 ENDDO
5901 ENDIF
5902 ENDIF
5903ENDIF
5904IF (PRESENT(nlevel)) THEN
5905 IF (nlevel >= 0) THEN
5906 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5907 ALLOCATE(this%level(nlevel))
5908 IF (linit) THEN
5909 DO i = 1, nlevel
5911 ENDDO
5912 ENDIF
5913 ENDIF
5914ENDIF
5915IF (PRESENT(ntimerange)) THEN
5916 IF (ntimerange >= 0) THEN
5917 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5918 ALLOCATE(this%timerange(ntimerange))
5919 IF (linit) THEN
5920 DO i = 1, ntimerange
5922 ENDDO
5923 ENDIF
5924 ENDIF
5925ENDIF
5926IF (PRESENT(nnetwork)) THEN
5927 IF (nnetwork >= 0) THEN
5928 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5929 ALLOCATE(this%network(nnetwork))
5930 IF (linit) THEN
5931 DO i = 1, nnetwork
5933 ENDDO
5934 ENDIF
5935 ENDIF
5936ENDIF
5937! Dimensioni dei tipi delle variabili
5938CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5939 nanavari, nanavarb, nanavarc, ini)
5940CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5941 nanaattri, nanaattrb, nanaattrc, ini)
5942CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5943 nanavarattri, nanavarattrb, nanavarattrc, ini)
5944CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5945 ndativari, ndativarb, ndativarc, ini)
5946CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5947 ndatiattri, ndatiattrb, ndatiattrc, ini)
5948CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5949 ndativarattri, ndativarattrb, ndativarattrc, ini)
5950
5951END SUBROUTINE vol7d_alloc
5952
5953
5954FUNCTION vol7d_check_alloc_ana(this)
5955TYPE(vol7d),INTENT(in) :: this
5956LOGICAL :: vol7d_check_alloc_ana
5957
5958vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5959
5960END FUNCTION vol7d_check_alloc_ana
5961
5962SUBROUTINE vol7d_force_alloc_ana(this, ini)
5963TYPE(vol7d),INTENT(inout) :: this
5964LOGICAL,INTENT(in),OPTIONAL :: ini
5965
5966! Alloco i descrittori minimi per avere un volume di anagrafica
5967IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5968IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5969
5970END SUBROUTINE vol7d_force_alloc_ana
5971
5972
5973FUNCTION vol7d_check_alloc_dati(this)
5974TYPE(vol7d),INTENT(in) :: this
5975LOGICAL :: vol7d_check_alloc_dati
5976
5977vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5978 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5979 ASSOCIATED(this%timerange)
5980
5981END FUNCTION vol7d_check_alloc_dati
5982
5983SUBROUTINE vol7d_force_alloc_dati(this, ini)
5984TYPE(vol7d),INTENT(inout) :: this
5985LOGICAL,INTENT(in),OPTIONAL :: ini
5986
5987! Alloco i descrittori minimi per avere un volume di dati
5988CALL vol7d_force_alloc_ana(this, ini)
5989IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5990IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5991IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5992
5993END SUBROUTINE vol7d_force_alloc_dati
5994
5995
5996SUBROUTINE vol7d_force_alloc(this)
5997TYPE(vol7d),INTENT(inout) :: this
5998
5999! If anything really not allocated yet, allocate with size 0
6000IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
6001IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
6002IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
6003IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
6004IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
6005
6006END SUBROUTINE vol7d_force_alloc
6007
6008
6009FUNCTION vol7d_check_vol(this)
6010TYPE(vol7d),INTENT(in) :: this
6011LOGICAL :: vol7d_check_vol
6012
6013vol7d_check_vol = c_e(this)
6014
6015! Anagrafica
6016IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6017 vol7d_check_vol = .false.
6018ENDIF
6019
6020IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6021 vol7d_check_vol = .false.
6022ENDIF
6023
6024IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6025 vol7d_check_vol = .false.
6026ENDIF
6027
6028IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6029 vol7d_check_vol = .false.
6030ENDIF
6031
6032IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6033 vol7d_check_vol = .false.
6034ENDIF
6035IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
6036 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
6037 ASSOCIATED(this%anavar%c)) THEN
6038 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
6039ENDIF
6040
6041! Attributi dell'anagrafica
6042IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6043 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6044 vol7d_check_vol = .false.
6045ENDIF
6046
6047IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6048 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6049 vol7d_check_vol = .false.
6050ENDIF
6051
6052IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6053 .NOT.ASSOCIATED(this%volanaattri)) THEN
6054 vol7d_check_vol = .false.
6055ENDIF
6056
6057IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6058 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6059 vol7d_check_vol = .false.
6060ENDIF
6061
6062IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6063 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6064 vol7d_check_vol = .false.
6065ENDIF
6066
6067! Dati
6068IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6069 vol7d_check_vol = .false.
6070ENDIF
6071
6072IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6073 vol7d_check_vol = .false.
6074ENDIF
6075
6076IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6077 vol7d_check_vol = .false.
6078ENDIF
6079
6080IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6081 vol7d_check_vol = .false.
6082ENDIF
6083
6084IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6085 vol7d_check_vol = .false.
6086ENDIF
6087
6088! Attributi dei dati
6089IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6090 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6091 vol7d_check_vol = .false.
6092ENDIF
6093
6094IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6095 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6096 vol7d_check_vol = .false.
6097ENDIF
6098
6099IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6100 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6101 vol7d_check_vol = .false.
6102ENDIF
6103
6104IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6105 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6106 vol7d_check_vol = .false.
6107ENDIF
6108
6109IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6110 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6111 vol7d_check_vol = .false.
6112ENDIF
6113IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6114 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6115 ASSOCIATED(this%dativar%c)) THEN
6116 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6117ENDIF
6118
6119END FUNCTION vol7d_check_vol
6120
6121
6136SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6137TYPE(vol7d),INTENT(inout) :: this
6138LOGICAL,INTENT(in),OPTIONAL :: ini
6139LOGICAL,INTENT(in),OPTIONAL :: inivol
6140
6141LOGICAL :: linivol
6142
6143IF (PRESENT(inivol)) THEN
6144 linivol = inivol
6145ELSE
6146 linivol = .true.
6147ENDIF
6148
6149! Anagrafica
6150IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6151 CALL vol7d_force_alloc_ana(this, ini)
6152 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6153 IF (linivol) this%volanar(:,:,:) = rmiss
6154ENDIF
6155
6156IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6157 CALL vol7d_force_alloc_ana(this, ini)
6158 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6159 IF (linivol) this%volanad(:,:,:) = rdmiss
6160ENDIF
6161
6162IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6163 CALL vol7d_force_alloc_ana(this, ini)
6164 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6165 IF (linivol) this%volanai(:,:,:) = imiss
6166ENDIF
6167
6168IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6169 CALL vol7d_force_alloc_ana(this, ini)
6170 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6171 IF (linivol) this%volanab(:,:,:) = ibmiss
6172ENDIF
6173
6174IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6175 CALL vol7d_force_alloc_ana(this, ini)
6176 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6177 IF (linivol) this%volanac(:,:,:) = cmiss
6178ENDIF
6179
6180! Attributi dell'anagrafica
6181IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6182 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6183 CALL vol7d_force_alloc_ana(this, ini)
6184 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6185 SIZE(this%network), SIZE(this%anaattr%r)))
6186 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6187ENDIF
6188
6189IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6190 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6191 CALL vol7d_force_alloc_ana(this, ini)
6192 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6193 SIZE(this%network), SIZE(this%anaattr%d)))
6194 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6195ENDIF
6196
6197IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6198 .NOT.ASSOCIATED(this%volanaattri)) THEN
6199 CALL vol7d_force_alloc_ana(this, ini)
6200 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6201 SIZE(this%network), SIZE(this%anaattr%i)))
6202 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6203ENDIF
6204
6205IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6206 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6207 CALL vol7d_force_alloc_ana(this, ini)
6208 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6209 SIZE(this%network), SIZE(this%anaattr%b)))
6210 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6211ENDIF
6212
6213IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6214 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6215 CALL vol7d_force_alloc_ana(this, ini)
6216 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6217 SIZE(this%network), SIZE(this%anaattr%c)))
6218 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6219ENDIF
6220
6221! Dati
6222IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6223 CALL vol7d_force_alloc_dati(this, ini)
6224 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6225 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6226 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6227ENDIF
6228
6229IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6230 CALL vol7d_force_alloc_dati(this, ini)
6231 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6232 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6233 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6234ENDIF
6235
6236IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6237 CALL vol7d_force_alloc_dati(this, ini)
6238 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6239 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6240 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6241ENDIF
6242
6243IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6244 CALL vol7d_force_alloc_dati(this, ini)
6245 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6246 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6247 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6248ENDIF
6249
6250IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6251 CALL vol7d_force_alloc_dati(this, ini)
6252 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6253 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6254 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6255ENDIF
6256
6257! Attributi dei dati
6258IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6259 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6260 CALL vol7d_force_alloc_dati(this, ini)
6261 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6262 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
6263 SIZE(this%datiattr%r)))
6264 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
6265ENDIF
6266
6267IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6268 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6269 CALL vol7d_force_alloc_dati(this, ini)
6270 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6271 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
6272 SIZE(this%datiattr%d)))
6273 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
6274ENDIF
6275
6276IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6277 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6278 CALL vol7d_force_alloc_dati(this, ini)
6279 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6280 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
6281 SIZE(this%datiattr%i)))
6282 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
6283ENDIF
6284
6285IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6286 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6287 CALL vol7d_force_alloc_dati(this, ini)
6288 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6289 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
6290 SIZE(this%datiattr%b)))
6291 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
6292ENDIF
6293
6294IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6295 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6296 CALL vol7d_force_alloc_dati(this, ini)
6297 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6298 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
6299 SIZE(this%datiattr%c)))
6300 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
6301ENDIF
6302
6303! Catch-all method
6304CALL vol7d_force_alloc(this)
6305
6306! Creo gli indici var-attr
6307
6308#ifdef DEBUG
6309CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
6310#endif
6311
6312CALL vol7d_set_attr_ind(this)
6313
6314
6315
6316END SUBROUTINE vol7d_alloc_vol
6317
6318
6325SUBROUTINE vol7d_set_attr_ind(this)
6326TYPE(vol7d),INTENT(inout) :: this
6327
6328INTEGER :: i
6329
6330! real
6331IF (ASSOCIATED(this%dativar%r)) THEN
6332 IF (ASSOCIATED(this%dativarattr%r)) THEN
6333 DO i = 1, SIZE(this%dativar%r)
6334 this%dativar%r(i)%r = &
6335 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
6336 ENDDO
6337 ENDIF
6338
6339 IF (ASSOCIATED(this%dativarattr%d)) THEN
6340 DO i = 1, SIZE(this%dativar%r)
6341 this%dativar%r(i)%d = &
6342 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
6343 ENDDO
6344 ENDIF
6345
6346 IF (ASSOCIATED(this%dativarattr%i)) THEN
6347 DO i = 1, SIZE(this%dativar%r)
6348 this%dativar%r(i)%i = &
6349 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
6350 ENDDO
6351 ENDIF
6352
6353 IF (ASSOCIATED(this%dativarattr%b)) THEN
6354 DO i = 1, SIZE(this%dativar%r)
6355 this%dativar%r(i)%b = &
6356 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
6357 ENDDO
6358 ENDIF
6359
6360 IF (ASSOCIATED(this%dativarattr%c)) THEN
6361 DO i = 1, SIZE(this%dativar%r)
6362 this%dativar%r(i)%c = &
6363 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
6364 ENDDO
6365 ENDIF
6366ENDIF
6367! double
6368IF (ASSOCIATED(this%dativar%d)) THEN
6369 IF (ASSOCIATED(this%dativarattr%r)) THEN
6370 DO i = 1, SIZE(this%dativar%d)
6371 this%dativar%d(i)%r = &
6372 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
6373 ENDDO
6374 ENDIF
6375
6376 IF (ASSOCIATED(this%dativarattr%d)) THEN
6377 DO i = 1, SIZE(this%dativar%d)
6378 this%dativar%d(i)%d = &
6379 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
6380 ENDDO
6381 ENDIF
6382
6383 IF (ASSOCIATED(this%dativarattr%i)) THEN
6384 DO i = 1, SIZE(this%dativar%d)
6385 this%dativar%d(i)%i = &
6386 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
6387 ENDDO
6388 ENDIF
6389
6390 IF (ASSOCIATED(this%dativarattr%b)) THEN
6391 DO i = 1, SIZE(this%dativar%d)
6392 this%dativar%d(i)%b = &
6393 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
6394 ENDDO
6395 ENDIF
6396
6397 IF (ASSOCIATED(this%dativarattr%c)) THEN
6398 DO i = 1, SIZE(this%dativar%d)
6399 this%dativar%d(i)%c = &
6400 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
6401 ENDDO
6402 ENDIF
6403ENDIF
6404! integer
6405IF (ASSOCIATED(this%dativar%i)) THEN
6406 IF (ASSOCIATED(this%dativarattr%r)) THEN
6407 DO i = 1, SIZE(this%dativar%i)
6408 this%dativar%i(i)%r = &
6409 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
6410 ENDDO
6411 ENDIF
6412
6413 IF (ASSOCIATED(this%dativarattr%d)) THEN
6414 DO i = 1, SIZE(this%dativar%i)
6415 this%dativar%i(i)%d = &
6416 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
6417 ENDDO
6418 ENDIF
6419
6420 IF (ASSOCIATED(this%dativarattr%i)) THEN
6421 DO i = 1, SIZE(this%dativar%i)
6422 this%dativar%i(i)%i = &
6423 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
6424 ENDDO
6425 ENDIF
6426
6427 IF (ASSOCIATED(this%dativarattr%b)) THEN
6428 DO i = 1, SIZE(this%dativar%i)
6429 this%dativar%i(i)%b = &
6430 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
6431 ENDDO
6432 ENDIF
6433
6434 IF (ASSOCIATED(this%dativarattr%c)) THEN
6435 DO i = 1, SIZE(this%dativar%i)
6436 this%dativar%i(i)%c = &
6437 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
6438 ENDDO
6439 ENDIF
6440ENDIF
6441! byte
6442IF (ASSOCIATED(this%dativar%b)) THEN
6443 IF (ASSOCIATED(this%dativarattr%r)) THEN
6444 DO i = 1, SIZE(this%dativar%b)
6445 this%dativar%b(i)%r = &
6446 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
6447 ENDDO
6448 ENDIF
6449
6450 IF (ASSOCIATED(this%dativarattr%d)) THEN
6451 DO i = 1, SIZE(this%dativar%b)
6452 this%dativar%b(i)%d = &
6453 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
6454 ENDDO
6455 ENDIF
6456
6457 IF (ASSOCIATED(this%dativarattr%i)) THEN
6458 DO i = 1, SIZE(this%dativar%b)
6459 this%dativar%b(i)%i = &
6460 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
6461 ENDDO
6462 ENDIF
6463
6464 IF (ASSOCIATED(this%dativarattr%b)) THEN
6465 DO i = 1, SIZE(this%dativar%b)
6466 this%dativar%b(i)%b = &
6467 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
6468 ENDDO
6469 ENDIF
6470
6471 IF (ASSOCIATED(this%dativarattr%c)) THEN
6472 DO i = 1, SIZE(this%dativar%b)
6473 this%dativar%b(i)%c = &
6474 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
6475 ENDDO
6476 ENDIF
6477ENDIF
6478! character
6479IF (ASSOCIATED(this%dativar%c)) THEN
6480 IF (ASSOCIATED(this%dativarattr%r)) THEN
6481 DO i = 1, SIZE(this%dativar%c)
6482 this%dativar%c(i)%r = &
6483 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
6484 ENDDO
6485 ENDIF
6486
6487 IF (ASSOCIATED(this%dativarattr%d)) THEN
6488 DO i = 1, SIZE(this%dativar%c)
6489 this%dativar%c(i)%d = &
6490 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
6491 ENDDO
6492 ENDIF
6493
6494 IF (ASSOCIATED(this%dativarattr%i)) THEN
6495 DO i = 1, SIZE(this%dativar%c)
6496 this%dativar%c(i)%i = &
6497 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
6498 ENDDO
6499 ENDIF
6500
6501 IF (ASSOCIATED(this%dativarattr%b)) THEN
6502 DO i = 1, SIZE(this%dativar%c)
6503 this%dativar%c(i)%b = &
6504 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
6505 ENDDO
6506 ENDIF
6507
6508 IF (ASSOCIATED(this%dativarattr%c)) THEN
6509 DO i = 1, SIZE(this%dativar%c)
6510 this%dativar%c(i)%c = &
6511 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
6512 ENDDO
6513 ENDIF
6514ENDIF
6515
6516END SUBROUTINE vol7d_set_attr_ind
6517
6518
6523SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
6524 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6525TYPE(vol7d),INTENT(INOUT) :: this
6526TYPE(vol7d),INTENT(INOUT) :: that
6527LOGICAL,INTENT(IN),OPTIONAL :: sort
6528LOGICAL,INTENT(in),OPTIONAL :: bestdata
6529LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
6530
6531TYPE(vol7d) :: v7d_clean
6532
6533
6535 this = that
6537 that = v7d_clean ! destroy that without deallocating
6538ELSE ! Append that to this and destroy that
6540 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6542ENDIF
6543
6544END SUBROUTINE vol7d_merge
6545
6546
6575SUBROUTINE vol7d_append(this, that, sort, bestdata, &
6576 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
6577TYPE(vol7d),INTENT(INOUT) :: this
6578TYPE(vol7d),INTENT(IN) :: that
6579LOGICAL,INTENT(IN),OPTIONAL :: sort
6580! experimental, please do not use outside the library now, they force the use
6581! of a simplified mapping algorithm which is valid only whene the dimension
6582! content is the same in both volumes , or when one of them is empty
6583LOGICAL,INTENT(in),OPTIONAL :: bestdata
6584LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
6585
6586
6587TYPE(vol7d) :: v7dtmp
6588LOGICAL :: lsort, lbestdata
6589INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
6590 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
6591
6593IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
6596 RETURN
6597ENDIF
6598
6599IF (this%time_definition /= that%time_definition) THEN
6600 CALL l4f_log(l4f_fatal, &
6601 'in vol7d_append, cannot append volumes with different &
6602 &time definition')
6603 CALL raise_fatal_error()
6604ENDIF
6605
6606! Completo l'allocazione per avere volumi a norma
6607CALL vol7d_alloc_vol(this)
6608
6612
6613! Calcolo le mappature tra volumi vecchi e volume nuovo
6614! I puntatori remap* vengono tutti o allocati o nullificati
6615IF (optio_log(ltimesimple)) THEN
6616 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
6617 lsort, remapt1, remapt2)
6618ELSE
6619 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
6620 lsort, remapt1, remapt2)
6621ENDIF
6622IF (optio_log(ltimerangesimple)) THEN
6623 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
6624 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6625ELSE
6626 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
6627 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6628ENDIF
6629IF (optio_log(llevelsimple)) THEN
6630 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
6631 lsort, remapl1, remapl2)
6632ELSE
6633 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
6634 lsort, remapl1, remapl2)
6635ENDIF
6636IF (optio_log(lanasimple)) THEN
6637 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6638 .false., remapa1, remapa2)
6639ELSE
6640 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6641 .false., remapa1, remapa2)
6642ENDIF
6643IF (optio_log(lnetworksimple)) THEN
6644 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
6645 .false., remapn1, remapn2)
6646ELSE
6647 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
6648 .false., remapn1, remapn2)
6649ENDIF
6650
6651! Faccio la fusione fisica dei volumi
6652CALL vol7d_merge_finalr(this, that, v7dtmp, &
6653 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6654 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6655CALL vol7d_merge_finald(this, that, v7dtmp, &
6656 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6657 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6658CALL vol7d_merge_finali(this, that, v7dtmp, &
6659 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6660 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6661CALL vol7d_merge_finalb(this, that, v7dtmp, &
6662 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6663 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6664CALL vol7d_merge_finalc(this, that, v7dtmp, &
6665 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6666 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6667
6668! Dealloco i vettori di rimappatura
6669IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
6670IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
6671IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
6672IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
6673IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
6674IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
6675IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
6676IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
6677IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
6678IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
6679
6680! Distruggo il vecchio volume e assegno il nuovo a this
6682this = v7dtmp
6683! Ricreo gli indici var-attr
6684CALL vol7d_set_attr_ind(this)
6685
6686END SUBROUTINE vol7d_append
6687
6688
6721SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
6722 lsort_time, lsort_timerange, lsort_level, &
6723 ltime, ltimerange, llevel, lana, lnetwork, &
6724 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6725 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6726 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6727 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6728 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6729 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6730TYPE(vol7d),INTENT(IN) :: this
6731TYPE(vol7d),INTENT(INOUT) :: that
6732LOGICAL,INTENT(IN),OPTIONAL :: sort
6733LOGICAL,INTENT(IN),OPTIONAL :: unique
6734LOGICAL,INTENT(IN),OPTIONAL :: miss
6735LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6736LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6737LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6745LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6747LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6749LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6751LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6753LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6755LOGICAL,INTENT(in),OPTIONAL :: &
6756 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6757 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6758 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6759 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6760 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6761 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6762
6763LOGICAL :: lsort, lunique, lmiss
6764INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
6765
6768IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
6769
6773
6774! Calcolo le mappature tra volume vecchio e volume nuovo
6775! I puntatori remap* vengono tutti o allocati o nullificati
6776CALL vol7d_remap1_datetime(this%time, that%time, &
6777 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6778CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6779 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6780CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6781 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6782CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6783 lsort, lunique, lmiss, remapa, lana)
6784CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6785 lsort, lunique, lmiss, remapn, lnetwork)
6786
6787! lanavari, lanavarb, lanavarc, &
6788! lanaattri, lanaattrb, lanaattrc, &
6789! lanavarattri, lanavarattrb, lanavarattrc, &
6790! ldativari, ldativarb, ldativarc, &
6791! ldatiattri, ldatiattrb, ldatiattrc, &
6792! ldativarattri, ldativarattrb, ldativarattrc
6793! Faccio la riforma fisica dei volumi
6794CALL vol7d_reform_finalr(this, that, &
6795 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6796 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6797CALL vol7d_reform_finald(this, that, &
6798 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6799 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6800CALL vol7d_reform_finali(this, that, &
6801 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6802 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6803CALL vol7d_reform_finalb(this, that, &
6804 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6805 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6806CALL vol7d_reform_finalc(this, that, &
6807 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6808 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6809
6810! Dealloco i vettori di rimappatura
6811IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6812IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6813IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6814IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6815IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6816
6817! Ricreo gli indici var-attr
6818CALL vol7d_set_attr_ind(that)
6819that%time_definition = this%time_definition
6820
6821END SUBROUTINE vol7d_copy
6822
6823
6834SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6835 lsort_time, lsort_timerange, lsort_level, &
6836 ltime, ltimerange, llevel, lana, lnetwork, &
6837 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6838 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6839 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6840 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6841 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6842 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6843 ,purgeana)
6844TYPE(vol7d),INTENT(INOUT) :: this
6845LOGICAL,INTENT(IN),OPTIONAL :: sort
6846LOGICAL,INTENT(IN),OPTIONAL :: unique
6847LOGICAL,INTENT(IN),OPTIONAL :: miss
6848LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6849LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6850LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6858LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6859LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6860LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6861LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6862LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6864LOGICAL,INTENT(in),OPTIONAL :: &
6865 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6866 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6867 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6868 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6869 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6870 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6871LOGICAL,INTENT(IN),OPTIONAL :: purgeana
6872
6873TYPE(vol7d) :: v7dtmp
6874logical,allocatable :: llana(:)
6875integer :: i
6876
6878 lsort_time, lsort_timerange, lsort_level, &
6879 ltime, ltimerange, llevel, lana, lnetwork, &
6880 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6881 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6882 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6883 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6884 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6885 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6886
6887! destroy old volume
6889
6890if (optio_log(purgeana)) then
6891 allocate(llana(size(v7dtmp%ana)))
6892 llana =.false.
6893 do i =1,size(v7dtmp%ana)
6894 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6895 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6896 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6897 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6898 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6899 end do
6900 CALL vol7d_copy(v7dtmp, this,lana=llana)
6902 deallocate(llana)
6903else
6904 this=v7dtmp
6905end if
6906
6907END SUBROUTINE vol7d_reform
6908
6909
6917SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6918TYPE(vol7d),INTENT(INOUT) :: this
6919LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
6920LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
6921LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
6922
6923INTEGER :: i
6924LOGICAL :: to_be_sorted
6925
6926to_be_sorted = .false.
6927CALL vol7d_alloc_vol(this) ! usual safety check
6928
6929IF (optio_log(lsort_time)) THEN
6930 DO i = 2, SIZE(this%time)
6931 IF (this%time(i) < this%time(i-1)) THEN
6932 to_be_sorted = .true.
6933 EXIT
6934 ENDIF
6935 ENDDO
6936ENDIF
6937IF (optio_log(lsort_timerange)) THEN
6938 DO i = 2, SIZE(this%timerange)
6939 IF (this%timerange(i) < this%timerange(i-1)) THEN
6940 to_be_sorted = .true.
6941 EXIT
6942 ENDIF
6943 ENDDO
6944ENDIF
6945IF (optio_log(lsort_level)) THEN
6946 DO i = 2, SIZE(this%level)
6947 IF (this%level(i) < this%level(i-1)) THEN
6948 to_be_sorted = .true.
6949 EXIT
6950 ENDIF
6951 ENDDO
6952ENDIF
6953
6954IF (to_be_sorted) CALL vol7d_reform(this, &
6955 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6956
6957END SUBROUTINE vol7d_smart_sort
6958
6966SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6967TYPE(vol7d),INTENT(inout) :: this
6968CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
6969CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
6970TYPE(vol7d_network),OPTIONAL :: nl(:)
6971TYPE(datetime),INTENT(in),OPTIONAL :: s_d
6972TYPE(datetime),INTENT(in),OPTIONAL :: e_d
6973
6974INTEGER :: i
6975
6976IF (PRESENT(avl)) THEN
6977 IF (SIZE(avl) > 0) THEN
6978
6979 IF (ASSOCIATED(this%anavar%r)) THEN
6980 DO i = 1, SIZE(this%anavar%r)
6981 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6982 ENDDO
6983 ENDIF
6984
6985 IF (ASSOCIATED(this%anavar%i)) THEN
6986 DO i = 1, SIZE(this%anavar%i)
6987 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6988 ENDDO
6989 ENDIF
6990
6991 IF (ASSOCIATED(this%anavar%b)) THEN
6992 DO i = 1, SIZE(this%anavar%b)
6993 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6994 ENDDO
6995 ENDIF
6996
6997 IF (ASSOCIATED(this%anavar%d)) THEN
6998 DO i = 1, SIZE(this%anavar%d)
6999 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
7000 ENDDO
7001 ENDIF
7002
7003 IF (ASSOCIATED(this%anavar%c)) THEN
7004 DO i = 1, SIZE(this%anavar%c)
7005 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
7006 ENDDO
7007 ENDIF
7008
7009 ENDIF
7010ENDIF
7011
7012
7013IF (PRESENT(vl)) THEN
7014 IF (size(vl) > 0) THEN
7015 IF (ASSOCIATED(this%dativar%r)) THEN
7016 DO i = 1, SIZE(this%dativar%r)
7017 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
7018 ENDDO
7019 ENDIF
7020
7021 IF (ASSOCIATED(this%dativar%i)) THEN
7022 DO i = 1, SIZE(this%dativar%i)
7023 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
7024 ENDDO
7025 ENDIF
7026
7027 IF (ASSOCIATED(this%dativar%b)) THEN
7028 DO i = 1, SIZE(this%dativar%b)
7029 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
7030 ENDDO
7031 ENDIF
7032
7033 IF (ASSOCIATED(this%dativar%d)) THEN
7034 DO i = 1, SIZE(this%dativar%d)
7035 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
7036 ENDDO
7037 ENDIF
7038
7039 IF (ASSOCIATED(this%dativar%c)) THEN
7040 DO i = 1, SIZE(this%dativar%c)
7041 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7042 ENDDO
7043 ENDIF
7044
7045 IF (ASSOCIATED(this%dativar%c)) THEN
7046 DO i = 1, SIZE(this%dativar%c)
7047 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
7048 ENDDO
7049 ENDIF
7050
7051 ENDIF
7052ENDIF
7053
7054IF (PRESENT(nl)) THEN
7055 IF (SIZE(nl) > 0) THEN
7056 DO i = 1, SIZE(this%network)
7057 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
7058 ENDDO
7059 ENDIF
7060ENDIF
7061
7062IF (PRESENT(s_d)) THEN
7064 WHERE (this%time < s_d)
7065 this%time = datetime_miss
7066 END WHERE
7067 ENDIF
7068ENDIF
7069
7070IF (PRESENT(e_d)) THEN
7072 WHERE (this%time > e_d)
7073 this%time = datetime_miss
7074 END WHERE
7075 ENDIF
7076ENDIF
7077
7078CALL vol7d_reform(this, miss=.true.)
7079
7080END SUBROUTINE vol7d_filter
7081
7082
7089SUBROUTINE vol7d_convr(this, that, anaconv)
7090TYPE(vol7d),INTENT(IN) :: this
7091TYPE(vol7d),INTENT(INOUT) :: that
7092LOGICAL,OPTIONAL,INTENT(in) :: anaconv
7093INTEGER :: i
7094LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
7095TYPE(vol7d) :: v7d_tmp
7096
7097IF (optio_log(anaconv)) THEN
7098 acp=fv
7099 acn=tv
7100ELSE
7101 acp=tv
7102 acn=fv
7103ENDIF
7104
7105! Volume con solo i dati reali e tutti gli attributi
7106! l'anagrafica e` copiata interamente se necessario
7107CALL vol7d_copy(this, that, &
7108 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7109 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7110
7111! Volume solo di dati double
7112CALL vol7d_copy(this, v7d_tmp, &
7113 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7114 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7115 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7116 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7117 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7118 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7119
7120! converto a dati reali
7121IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7122
7123 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7124! alloco i dati reali e vi trasferisco i double
7125 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7126 SIZE(v7d_tmp%volanad, 3)))
7127 DO i = 1, SIZE(v7d_tmp%anavar%d)
7128 v7d_tmp%volanar(:,i,:) = &
7129 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7130 ENDDO
7131 DEALLOCATE(v7d_tmp%volanad)
7132! trasferisco le variabili
7133 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7134 NULLIFY(v7d_tmp%anavar%d)
7135 ENDIF
7136
7137 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7138! alloco i dati reali e vi trasferisco i double
7139 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7140 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7141 SIZE(v7d_tmp%voldatid, 6)))
7142 DO i = 1, SIZE(v7d_tmp%dativar%d)
7143 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7144 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7145 ENDDO
7146 DEALLOCATE(v7d_tmp%voldatid)
7147! trasferisco le variabili
7148 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7149 NULLIFY(v7d_tmp%dativar%d)
7150 ENDIF
7151
7152! fondo con il volume definitivo
7153 CALL vol7d_merge(that, v7d_tmp)
7154ELSE
7156ENDIF
7157
7158
7159! Volume solo di dati interi
7160CALL vol7d_copy(this, v7d_tmp, &
7161 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7162 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7163 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7164 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7165 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7166 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7167
7168! converto a dati reali
7169IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7170
7171 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7172! alloco i dati reali e vi trasferisco gli interi
7173 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7174 SIZE(v7d_tmp%volanai, 3)))
7175 DO i = 1, SIZE(v7d_tmp%anavar%i)
7176 v7d_tmp%volanar(:,i,:) = &
7177 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7178 ENDDO
7179 DEALLOCATE(v7d_tmp%volanai)
7180! trasferisco le variabili
7181 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7182 NULLIFY(v7d_tmp%anavar%i)
7183 ENDIF
7184
7185 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7186! alloco i dati reali e vi trasferisco gli interi
7187 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7188 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7189 SIZE(v7d_tmp%voldatii, 6)))
7190 DO i = 1, SIZE(v7d_tmp%dativar%i)
7191 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7192 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7193 ENDDO
7194 DEALLOCATE(v7d_tmp%voldatii)
7195! trasferisco le variabili
7196 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7197 NULLIFY(v7d_tmp%dativar%i)
7198 ENDIF
7199
7200! fondo con il volume definitivo
7201 CALL vol7d_merge(that, v7d_tmp)
7202ELSE
7204ENDIF
7205
7206
7207! Volume solo di dati byte
7208CALL vol7d_copy(this, v7d_tmp, &
7209 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7210 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7211 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7212 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7213 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7214 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7215
7216! converto a dati reali
7217IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7218
7219 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7220! alloco i dati reali e vi trasferisco i byte
7221 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7222 SIZE(v7d_tmp%volanab, 3)))
7223 DO i = 1, SIZE(v7d_tmp%anavar%b)
7224 v7d_tmp%volanar(:,i,:) = &
7225 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7226 ENDDO
7227 DEALLOCATE(v7d_tmp%volanab)
7228! trasferisco le variabili
7229 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7230 NULLIFY(v7d_tmp%anavar%b)
7231 ENDIF
7232
7233 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7234! alloco i dati reali e vi trasferisco i byte
7235 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7236 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7237 SIZE(v7d_tmp%voldatib, 6)))
7238 DO i = 1, SIZE(v7d_tmp%dativar%b)
7239 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7240 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7241 ENDDO
7242 DEALLOCATE(v7d_tmp%voldatib)
7243! trasferisco le variabili
7244 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7245 NULLIFY(v7d_tmp%dativar%b)
7246 ENDIF
7247
7248! fondo con il volume definitivo
7249 CALL vol7d_merge(that, v7d_tmp)
7250ELSE
7252ENDIF
7253
7254
7255! Volume solo di dati character
7256CALL vol7d_copy(this, v7d_tmp, &
7257 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7258 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7259 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7260 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7261 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7262 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7263
7264! converto a dati reali
7265IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
7266
7267 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
7268! alloco i dati reali e vi trasferisco i character
7269 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
7270 SIZE(v7d_tmp%volanac, 3)))
7271 DO i = 1, SIZE(v7d_tmp%anavar%c)
7272 v7d_tmp%volanar(:,i,:) = &
7273 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
7274 ENDDO
7275 DEALLOCATE(v7d_tmp%volanac)
7276! trasferisco le variabili
7277 v7d_tmp%anavar%r => v7d_tmp%anavar%c
7278 NULLIFY(v7d_tmp%anavar%c)
7279 ENDIF
7280
7281 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
7282! alloco i dati reali e vi trasferisco i character
7283 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
7284 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
7285 SIZE(v7d_tmp%voldatic, 6)))
7286 DO i = 1, SIZE(v7d_tmp%dativar%c)
7287 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7288 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
7289 ENDDO
7290 DEALLOCATE(v7d_tmp%voldatic)
7291! trasferisco le variabili
7292 v7d_tmp%dativar%r => v7d_tmp%dativar%c
7293 NULLIFY(v7d_tmp%dativar%c)
7294 ENDIF
7295
7296! fondo con il volume definitivo
7297 CALL vol7d_merge(that, v7d_tmp)
7298ELSE
7300ENDIF
7301
7302END SUBROUTINE vol7d_convr
7303
7304
7308SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
7309TYPE(vol7d),INTENT(IN) :: this
7310TYPE(vol7d),INTENT(OUT) :: that
7311logical , optional, intent(in) :: data_only
7312logical , optional, intent(in) :: ana
7313logical :: ldata_only,lana
7314
7315IF (PRESENT(data_only)) THEN
7316 ldata_only = data_only
7317ELSE
7318 ldata_only = .false.
7319ENDIF
7320
7321IF (PRESENT(ana)) THEN
7322 lana = ana
7323ELSE
7324 lana = .false.
7325ENDIF
7326
7327
7328#undef VOL7D_POLY_ARRAY
7329#define VOL7D_POLY_ARRAY voldati
7330#include "vol7d_class_diff.F90"
7331#undef VOL7D_POLY_ARRAY
7332#define VOL7D_POLY_ARRAY voldatiattr
7333#include "vol7d_class_diff.F90"
7334#undef VOL7D_POLY_ARRAY
7335
7336if ( .not. ldata_only) then
7337
7338#define VOL7D_POLY_ARRAY volana
7339#include "vol7d_class_diff.F90"
7340#undef VOL7D_POLY_ARRAY
7341#define VOL7D_POLY_ARRAY volanaattr
7342#include "vol7d_class_diff.F90"
7343#undef VOL7D_POLY_ARRAY
7344
7345 if(lana)then
7346 where ( this%ana == that%ana )
7347 that%ana = vol7d_ana_miss
7348 end where
7349 end if
7350
7351end if
7352
7353
7354
7355END SUBROUTINE vol7d_diff_only
7356
7357
7358
7359! Creo le routine da ripetere per i vari tipi di dati di v7d
7360! tramite un template e il preprocessore
7361#undef VOL7D_POLY_TYPE
7362#undef VOL7D_POLY_TYPES
7363#define VOL7D_POLY_TYPE REAL
7364#define VOL7D_POLY_TYPES r
7365#include "vol7d_class_type_templ.F90"
7366#undef VOL7D_POLY_TYPE
7367#undef VOL7D_POLY_TYPES
7368#define VOL7D_POLY_TYPE DOUBLE PRECISION
7369#define VOL7D_POLY_TYPES d
7370#include "vol7d_class_type_templ.F90"
7371#undef VOL7D_POLY_TYPE
7372#undef VOL7D_POLY_TYPES
7373#define VOL7D_POLY_TYPE INTEGER
7374#define VOL7D_POLY_TYPES i
7375#include "vol7d_class_type_templ.F90"
7376#undef VOL7D_POLY_TYPE
7377#undef VOL7D_POLY_TYPES
7378#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
7379#define VOL7D_POLY_TYPES b
7380#include "vol7d_class_type_templ.F90"
7381#undef VOL7D_POLY_TYPE
7382#undef VOL7D_POLY_TYPES
7383#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
7384#define VOL7D_POLY_TYPES c
7385#include "vol7d_class_type_templ.F90"
7386
7387! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
7388! tramite un template e il preprocessore
7389#define VOL7D_SORT
7390#undef VOL7D_NO_ZERO_ALLOC
7391#undef VOL7D_POLY_TYPE
7392#define VOL7D_POLY_TYPE datetime
7393#include "vol7d_class_desc_templ.F90"
7394#undef VOL7D_POLY_TYPE
7395#define VOL7D_POLY_TYPE vol7d_timerange
7396#include "vol7d_class_desc_templ.F90"
7397#undef VOL7D_POLY_TYPE
7398#define VOL7D_POLY_TYPE vol7d_level
7399#include "vol7d_class_desc_templ.F90"
7400#undef VOL7D_SORT
7401#undef VOL7D_POLY_TYPE
7402#define VOL7D_POLY_TYPE vol7d_network
7403#include "vol7d_class_desc_templ.F90"
7404#undef VOL7D_POLY_TYPE
7405#define VOL7D_POLY_TYPE vol7d_ana
7406#include "vol7d_class_desc_templ.F90"
7407#define VOL7D_NO_ZERO_ALLOC
7408#undef VOL7D_POLY_TYPE
7409#define VOL7D_POLY_TYPE vol7d_var
7410#include "vol7d_class_desc_templ.F90"
7411
7421subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
7422
7423TYPE(vol7d),INTENT(IN) :: this
7424integer,optional,intent(inout) :: unit
7425character(len=*),intent(in),optional :: filename
7426character(len=*),intent(out),optional :: filename_auto
7427character(len=*),INTENT(IN),optional :: description
7428
7429integer :: lunit
7430character(len=254) :: ldescription,arg,lfilename
7431integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7432 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7433 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7434 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7435 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7436 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7437 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7438!integer :: im,id,iy
7439integer :: tarray(8)
7440logical :: opened,exist
7441
7442 nana=0
7443 ntime=0
7444 ntimerange=0
7445 nlevel=0
7446 nnetwork=0
7447 ndativarr=0
7448 ndativari=0
7449 ndativarb=0
7450 ndativard=0
7451 ndativarc=0
7452 ndatiattrr=0
7453 ndatiattri=0
7454 ndatiattrb=0
7455 ndatiattrd=0
7456 ndatiattrc=0
7457 ndativarattrr=0
7458 ndativarattri=0
7459 ndativarattrb=0
7460 ndativarattrd=0
7461 ndativarattrc=0
7462 nanavarr=0
7463 nanavari=0
7464 nanavarb=0
7465 nanavard=0
7466 nanavarc=0
7467 nanaattrr=0
7468 nanaattri=0
7469 nanaattrb=0
7470 nanaattrd=0
7471 nanaattrc=0
7472 nanavarattrr=0
7473 nanavarattri=0
7474 nanavarattrb=0
7475 nanavarattrd=0
7476 nanavarattrc=0
7477
7478
7479!call idate(im,id,iy)
7480call date_and_time(values=tarray)
7481call getarg(0,arg)
7482
7483if (present(description))then
7484 ldescription=description
7485else
7486 ldescription="Vol7d generated by: "//trim(arg)
7487end if
7488
7489if (.not. present(unit))then
7490 lunit=getunit()
7491else
7492 if (unit==0)then
7493 lunit=getunit()
7494 unit=lunit
7495 else
7496 lunit=unit
7497 end if
7498end if
7499
7500lfilename=trim(arg)//".v7d"
7502
7503if (present(filename))then
7504 if (filename /= "")then
7505 lfilename=filename
7506 end if
7507end if
7508
7509if (present(filename_auto))filename_auto=lfilename
7510
7511
7512inquire(unit=lunit,opened=opened)
7513if (.not. opened) then
7514! inquire(file=lfilename, EXIST=exist)
7515! IF (exist) THEN
7516! CALL l4f_log(L4F_FATAL, &
7517! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
7518! CALL raise_fatal_error()
7519! ENDIF
7520 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
7521 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7522end if
7523
7524if (associated(this%ana)) nana=size(this%ana)
7525if (associated(this%time)) ntime=size(this%time)
7526if (associated(this%timerange)) ntimerange=size(this%timerange)
7527if (associated(this%level)) nlevel=size(this%level)
7528if (associated(this%network)) nnetwork=size(this%network)
7529
7530if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
7531if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
7532if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
7533if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
7534if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
7535
7536if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
7537if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
7538if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
7539if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
7540if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
7541
7542if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
7543if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
7544if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
7545if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
7546if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
7547
7548if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
7549if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
7550if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
7551if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
7552if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
7553
7554if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
7555if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
7556if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
7557if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
7558if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
7559
7560if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
7561if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
7562if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
7563if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
7564if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
7565
7566write(unit=lunit)ldescription
7567write(unit=lunit)tarray
7568
7569write(unit=lunit)&
7570 nana, ntime, ntimerange, nlevel, nnetwork, &
7571 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7572 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7573 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7574 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7575 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7576 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7577 this%time_definition
7578
7579
7580!write(unit=lunit)this
7581
7582
7583!! prime 5 dimensioni
7586if (associated(this%level)) write(unit=lunit)this%level
7587if (associated(this%timerange)) write(unit=lunit)this%timerange
7588if (associated(this%network)) write(unit=lunit)this%network
7589
7590 !! 6a dimensione: variabile dell'anagrafica e dei dati
7591 !! con relativi attributi e in 5 tipi diversi
7592
7593if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
7594if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
7595if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
7596if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
7597if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
7598
7599if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
7600if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
7601if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
7602if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
7603if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
7604
7605if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
7606if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
7607if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
7608if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
7609if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
7610
7611if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
7612if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
7613if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
7614if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
7615if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
7616
7617if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
7618if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
7619if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
7620if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
7621if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
7622
7623if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
7624if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
7625if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
7626if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
7627if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
7628
7629!! Volumi di valori e attributi per anagrafica e dati
7630
7631if (associated(this%volanar)) write(unit=lunit)this%volanar
7632if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
7633if (associated(this%voldatir)) write(unit=lunit)this%voldatir
7634if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
7635
7636if (associated(this%volanai)) write(unit=lunit)this%volanai
7637if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
7638if (associated(this%voldatii)) write(unit=lunit)this%voldatii
7639if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
7640
7641if (associated(this%volanab)) write(unit=lunit)this%volanab
7642if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
7643if (associated(this%voldatib)) write(unit=lunit)this%voldatib
7644if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
7645
7646if (associated(this%volanad)) write(unit=lunit)this%volanad
7647if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
7648if (associated(this%voldatid)) write(unit=lunit)this%voldatid
7649if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
7650
7651if (associated(this%volanac)) write(unit=lunit)this%volanac
7652if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
7653if (associated(this%voldatic)) write(unit=lunit)this%voldatic
7654if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
7655
7656if (.not. present(unit)) close(unit=lunit)
7657
7658end subroutine vol7d_write_on_file
7659
7660
7667
7668
7669subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
7670
7671TYPE(vol7d),INTENT(OUT) :: this
7672integer,intent(inout),optional :: unit
7673character(len=*),INTENT(in),optional :: filename
7674character(len=*),intent(out),optional :: filename_auto
7675character(len=*),INTENT(out),optional :: description
7676integer,intent(out),optional :: tarray(8)
7677
7678
7679integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7680 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7681 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7682 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7683 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7684 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7685 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7686
7687character(len=254) :: ldescription,lfilename,arg
7688integer :: ltarray(8),lunit,ios
7689logical :: opened,exist
7690
7691
7692call getarg(0,arg)
7693
7694if (.not. present(unit))then
7695 lunit=getunit()
7696else
7697 if (unit==0)then
7698 lunit=getunit()
7699 unit=lunit
7700 else
7701 lunit=unit
7702 end if
7703end if
7704
7705lfilename=trim(arg)//".v7d"
7707
7708if (present(filename))then
7709 if (filename /= "")then
7710 lfilename=filename
7711 end if
7712end if
7713
7714if (present(filename_auto))filename_auto=lfilename
7715
7716
7717inquire(unit=lunit,opened=opened)
7718IF (.NOT. opened) THEN
7719 inquire(file=lfilename,exist=exist)
7720 IF (.NOT.exist) THEN
7721 CALL l4f_log(l4f_fatal, &
7722 'in vol7d_read_from_file, file does not exists, cannot open')
7723 CALL raise_fatal_error()
7724 ENDIF
7725 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
7726 status='OLD', action='READ')
7727 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7728end if
7729
7730
7732read(unit=lunit,iostat=ios)ldescription
7733
7734if (ios < 0) then ! A negative value indicates that the End of File or End of Record
7735 call vol7d_alloc (this)
7736 call vol7d_alloc_vol (this)
7737 if (present(description))description=ldescription
7738 if (present(tarray))tarray=ltarray
7739 if (.not. present(unit)) close(unit=lunit)
7740end if
7741
7742read(unit=lunit)ltarray
7743
7744CALL l4f_log(l4f_info, 'Reading vol7d from file')
7745CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
7748
7749if (present(description))description=ldescription
7750if (present(tarray))tarray=ltarray
7751
7752read(unit=lunit)&
7753 nana, ntime, ntimerange, nlevel, nnetwork, &
7754 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7755 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7756 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7757 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7758 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7759 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7760 this%time_definition
7761
7762call vol7d_alloc (this, &
7763 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
7764 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
7765 ndativard=ndativard, ndativarc=ndativarc,&
7766 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
7767 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
7768 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
7769 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
7770 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
7771 nanavard=nanavard, nanavarc=nanavarc,&
7772 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
7773 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
7774 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7775 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7776
7777
7780if (associated(this%level)) read(unit=lunit)this%level
7781if (associated(this%timerange)) read(unit=lunit)this%timerange
7782if (associated(this%network)) read(unit=lunit)this%network
7783
7784if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7785if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7786if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7787if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7788if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7789
7790if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7791if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7792if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7793if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7794if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7795
7796if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7797if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7798if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7799if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7800if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7801
7802if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7803if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7804if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7805if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7806if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7807
7808if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7809if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7810if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7811if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7812if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7813
7814if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7815if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7816if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7817if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7818if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7819
7820call vol7d_alloc_vol (this)
7821
7822!! Volumi di valori e attributi per anagrafica e dati
7823
7824if (associated(this%volanar)) read(unit=lunit)this%volanar
7825if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7826if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7827if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7828
7829if (associated(this%volanai)) read(unit=lunit)this%volanai
7830if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7831if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7832if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7833
7834if (associated(this%volanab)) read(unit=lunit)this%volanab
7835if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7836if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7837if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7838
7839if (associated(this%volanad)) read(unit=lunit)this%volanad
7840if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7841if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7842if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7843
7844if (associated(this%volanac)) read(unit=lunit)this%volanac
7845if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7846if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7847if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7848
7849if (.not. present(unit)) close(unit=lunit)
7850
7851end subroutine vol7d_read_from_file
7852
7853
7854! to double precision
7855elemental doubleprecision function doubledatd(voldat,var)
7856doubleprecision,intent(in) :: voldat
7857type(vol7d_var),intent(in) :: var
7858
7859doubledatd=voldat
7860
7861end function doubledatd
7862
7863
7864elemental doubleprecision function doubledatr(voldat,var)
7865real,intent(in) :: voldat
7866type(vol7d_var),intent(in) :: var
7867
7869 doubledatr=dble(voldat)
7870else
7871 doubledatr=dmiss
7872end if
7873
7874end function doubledatr
7875
7876
7877elemental doubleprecision function doubledati(voldat,var)
7878integer,intent(in) :: voldat
7879type(vol7d_var),intent(in) :: var
7880
7883 doubledati=dble(voldat)/10.d0**var%scalefactor
7884 else
7885 doubledati=dble(voldat)
7886 endif
7887else
7888 doubledati=dmiss
7889end if
7890
7891end function doubledati
7892
7893
7894elemental doubleprecision function doubledatb(voldat,var)
7895integer(kind=int_b),intent(in) :: voldat
7896type(vol7d_var),intent(in) :: var
7897
7900 doubledatb=dble(voldat)/10.d0**var%scalefactor
7901 else
7902 doubledatb=dble(voldat)
7903 endif
7904else
7905 doubledatb=dmiss
7906end if
7907
7908end function doubledatb
7909
7910
7911elemental doubleprecision function doubledatc(voldat,var)
7912CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7913type(vol7d_var),intent(in) :: var
7914
7915doubledatc = c2d(voldat)
7917 doubledatc=doubledatc/10.d0**var%scalefactor
7918end if
7919
7920end function doubledatc
7921
7922
7923! to integer
7924elemental integer function integerdatd(voldat,var)
7925doubleprecision,intent(in) :: voldat
7926type(vol7d_var),intent(in) :: var
7927
7930 integerdatd=nint(voldat*10d0**var%scalefactor)
7931 else
7932 integerdatd=nint(voldat)
7933 endif
7934else
7935 integerdatd=imiss
7936end if
7937
7938end function integerdatd
7939
7940
7941elemental integer function integerdatr(voldat,var)
7942real,intent(in) :: voldat
7943type(vol7d_var),intent(in) :: var
7944
7947 integerdatr=nint(voldat*10d0**var%scalefactor)
7948 else
7949 integerdatr=nint(voldat)
7950 endif
7951else
7952 integerdatr=imiss
7953end if
7954
7955end function integerdatr
7956
7957
7958elemental integer function integerdati(voldat,var)
7959integer,intent(in) :: voldat
7960type(vol7d_var),intent(in) :: var
7961
7962integerdati=voldat
7963
7964end function integerdati
7965
7966
7967elemental integer function integerdatb(voldat,var)
7968integer(kind=int_b),intent(in) :: voldat
7969type(vol7d_var),intent(in) :: var
7970
7972 integerdatb=voldat
7973else
7974 integerdatb=imiss
7975end if
7976
7977end function integerdatb
7978
7979
7980elemental integer function integerdatc(voldat,var)
7981CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7982type(vol7d_var),intent(in) :: var
7983
7984integerdatc=c2i(voldat)
7985
7986end function integerdatc
7987
7988
7989! to real
7990elemental real function realdatd(voldat,var)
7991doubleprecision,intent(in) :: voldat
7992type(vol7d_var),intent(in) :: var
7993
7995 realdatd=real(voldat)
7996else
7997 realdatd=rmiss
7998end if
7999
8000end function realdatd
8001
8002
8003elemental real function realdatr(voldat,var)
8004real,intent(in) :: voldat
8005type(vol7d_var),intent(in) :: var
8006
8007realdatr=voldat
8008
8009end function realdatr
8010
8011
8012elemental real function realdati(voldat,var)
8013integer,intent(in) :: voldat
8014type(vol7d_var),intent(in) :: var
8015
8018 realdati=float(voldat)/10.**var%scalefactor
8019 else
8020 realdati=float(voldat)
8021 endif
8022else
8023 realdati=rmiss
8024end if
8025
8026end function realdati
8027
8028
8029elemental real function realdatb(voldat,var)
8030integer(kind=int_b),intent(in) :: voldat
8031type(vol7d_var),intent(in) :: var
8032
8035 realdatb=float(voldat)/10**var%scalefactor
8036 else
8037 realdatb=float(voldat)
8038 endif
8039else
8040 realdatb=rmiss
8041end if
8042
8043end function realdatb
8044
8045
8046elemental real function realdatc(voldat,var)
8047CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
8048type(vol7d_var),intent(in) :: var
8049
8050realdatc=c2r(voldat)
8052 realdatc=realdatc/10.**var%scalefactor
8053end if
8054
8055end function realdatc
8056
8057
8063FUNCTION realanavol(this, var) RESULT(vol)
8064TYPE(vol7d),INTENT(in) :: this
8065TYPE(vol7d_var),INTENT(in) :: var
8066REAL :: vol(SIZE(this%ana),size(this%network))
8067
8068CHARACTER(len=1) :: dtype
8069INTEGER :: indvar
8070
8071dtype = cmiss
8072indvar = index(this%anavar, var, type=dtype)
8073
8074IF (indvar > 0) THEN
8075 SELECT CASE (dtype)
8076 CASE("d")
8077 vol = realdat(this%volanad(:,indvar,:), var)
8078 CASE("r")
8079 vol = this%volanar(:,indvar,:)
8080 CASE("i")
8081 vol = realdat(this%volanai(:,indvar,:), var)
8082 CASE("b")
8083 vol = realdat(this%volanab(:,indvar,:), var)
8084 CASE("c")
8085 vol = realdat(this%volanac(:,indvar,:), var)
8086 CASE default
8087 vol = rmiss
8088 END SELECT
8089ELSE
8090 vol = rmiss
8091ENDIF
8092
8093END FUNCTION realanavol
8094
8095
8101FUNCTION integeranavol(this, var) RESULT(vol)
8102TYPE(vol7d),INTENT(in) :: this
8103TYPE(vol7d_var),INTENT(in) :: var
8104INTEGER :: vol(SIZE(this%ana),size(this%network))
8105
8106CHARACTER(len=1) :: dtype
8107INTEGER :: indvar
8108
8109dtype = cmiss
8110indvar = index(this%anavar, var, type=dtype)
8111
8112IF (indvar > 0) THEN
8113 SELECT CASE (dtype)
8114 CASE("d")
8115 vol = integerdat(this%volanad(:,indvar,:), var)
8116 CASE("r")
8117 vol = integerdat(this%volanar(:,indvar,:), var)
8118 CASE("i")
8119 vol = this%volanai(:,indvar,:)
8120 CASE("b")
8121 vol = integerdat(this%volanab(:,indvar,:), var)
8122 CASE("c")
8123 vol = integerdat(this%volanac(:,indvar,:), var)
8124 CASE default
8125 vol = imiss
8126 END SELECT
8127ELSE
8128 vol = imiss
8129ENDIF
8130
8131END FUNCTION integeranavol
8132
8133
8139subroutine move_datac (v7d,&
8140 indana,indtime,indlevel,indtimerange,indnetwork,&
8141 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8142
8143TYPE(vol7d),intent(inout) :: v7d
8144
8145integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8146integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8147integer :: inddativar,inddativarattr
8148
8149
8150do inddativar=1,size(v7d%dativar%c)
8151
8153 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8154 ) then
8155
8156 ! dati
8157 v7d%voldatic &
8158 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8159 v7d%voldatic &
8160 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8161
8162
8163 ! attributi
8164 if (associated (v7d%dativarattr%i)) then
8165 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8166 if (inddativarattr > 0 ) then
8167 v7d%voldatiattri &
8168 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8169 v7d%voldatiattri &
8170 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8171 end if
8172 end if
8173
8174 if (associated (v7d%dativarattr%r)) then
8175 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8176 if (inddativarattr > 0 ) then
8177 v7d%voldatiattrr &
8178 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8179 v7d%voldatiattrr &
8180 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8181 end if
8182 end if
8183
8184 if (associated (v7d%dativarattr%d)) then
8185 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8186 if (inddativarattr > 0 ) then
8187 v7d%voldatiattrd &
8188 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8189 v7d%voldatiattrd &
8190 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8191 end if
8192 end if
8193
8194 if (associated (v7d%dativarattr%b)) then
8195 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8196 if (inddativarattr > 0 ) then
8197 v7d%voldatiattrb &
8198 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8199 v7d%voldatiattrb &
8200 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8201 end if
8202 end if
8203
8204 if (associated (v7d%dativarattr%c)) then
8205 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8206 if (inddativarattr > 0 ) then
8207 v7d%voldatiattrc &
8208 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8209 v7d%voldatiattrc &
8210 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8211 end if
8212 end if
8213
8214 end if
8215
8216end do
8217
8218end subroutine move_datac
8219
8225subroutine move_datar (v7d,&
8226 indana,indtime,indlevel,indtimerange,indnetwork,&
8227 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8228
8229TYPE(vol7d),intent(inout) :: v7d
8230
8231integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8232integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8233integer :: inddativar,inddativarattr
8234
8235
8236do inddativar=1,size(v7d%dativar%r)
8237
8239 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8240 ) then
8241
8242 ! dati
8243 v7d%voldatir &
8244 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8245 v7d%voldatir &
8246 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8247
8248
8249 ! attributi
8250 if (associated (v7d%dativarattr%i)) then
8251 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8252 if (inddativarattr > 0 ) then
8253 v7d%voldatiattri &
8254 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8255 v7d%voldatiattri &
8256 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8257 end if
8258 end if
8259
8260 if (associated (v7d%dativarattr%r)) then
8261 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
8262 if (inddativarattr > 0 ) then
8263 v7d%voldatiattrr &
8264 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8265 v7d%voldatiattrr &
8266 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8267 end if
8268 end if
8269
8270 if (associated (v7d%dativarattr%d)) then
8271 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
8272 if (inddativarattr > 0 ) then
8273 v7d%voldatiattrd &
8274 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8275 v7d%voldatiattrd &
8276 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8277 end if
8278 end if
8279
8280 if (associated (v7d%dativarattr%b)) then
8281 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
8282 if (inddativarattr > 0 ) then
8283 v7d%voldatiattrb &
8284 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8285 v7d%voldatiattrb &
8286 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8287 end if
8288 end if
8289
8290 if (associated (v7d%dativarattr%c)) then
8291 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
8292 if (inddativarattr > 0 ) then
8293 v7d%voldatiattrc &
8294 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8295 v7d%voldatiattrc &
8296 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8297 end if
8298 end if
8299
8300 end if
8301
8302end do
8303
8304end subroutine move_datar
8305
8306
8320subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
8321type(vol7d),intent(inout) :: v7din
8322type(vol7d),intent(out) :: v7dout
8323type(vol7d_level),intent(in),optional :: level(:)
8324type(vol7d_timerange),intent(in),optional :: timerange(:)
8325!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
8326!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
8327logical,intent(in),optional :: nostatproc
8328
8329integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
8330integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
8331type(vol7d_level) :: roundlevel(size(v7din%level))
8332type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
8333type(vol7d) :: v7d_tmp
8334
8335
8336nbin=0
8337
8338if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
8339if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
8340if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
8341if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
8342
8344
8345roundlevel=v7din%level
8346
8347if (present(level))then
8348 do ilevel = 1, size(v7din%level)
8349 if ((any(v7din%level(ilevel) .almosteq. level))) then
8350 roundlevel(ilevel)=level(1)
8351 end if
8352 end do
8353end if
8354
8355roundtimerange=v7din%timerange
8356
8357if (present(timerange))then
8358 do itimerange = 1, size(v7din%timerange)
8359 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
8360 roundtimerange(itimerange)=timerange(1)
8361 end if
8362 end do
8363end if
8364
8365!set istantaneous values everywere
8366!preserve p1 for forecast time
8367if (optio_log(nostatproc)) then
8368 roundtimerange(:)%timerange=254
8369 roundtimerange(:)%p2=0
8370end if
8371
8372
8373nana=size(v7din%ana)
8374nlevel=count_distinct(roundlevel,back=.true.)
8375ntime=size(v7din%time)
8376ntimerange=count_distinct(roundtimerange,back=.true.)
8377nnetwork=size(v7din%network)
8378
8380
8381if (nbin == 0) then
8383else
8384 call vol7d_convr(v7din,v7d_tmp)
8385end if
8386
8387v7d_tmp%level=roundlevel
8388v7d_tmp%timerange=roundtimerange
8389
8390do ilevel=1, size(v7d_tmp%level)
8391 indl=index(v7d_tmp%level,roundlevel(ilevel))
8392 do itimerange=1,size(v7d_tmp%timerange)
8393 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
8394
8395 if (indl /= ilevel .or. indt /= itimerange) then
8396
8397 do iana=1, nana
8398 do itime=1,ntime
8399 do inetwork=1,nnetwork
8400
8401 if (nbin > 0) then
8402 call move_datar (v7d_tmp,&
8403 iana,itime,ilevel,itimerange,inetwork,&
8404 iana,itime,indl,indt,inetwork)
8405 else
8406 call move_datac (v7d_tmp,&
8407 iana,itime,ilevel,itimerange,inetwork,&
8408 iana,itime,indl,indt,inetwork)
8409 end if
8410
8411 end do
8412 end do
8413 end do
8414
8415 end if
8416
8417 end do
8418end do
8419
8420! set to missing level and time > nlevel
8421do ilevel=nlevel+1,size(v7d_tmp%level)
8423end do
8424
8425do itimerange=ntimerange+1,size(v7d_tmp%timerange)
8427end do
8428
8429!copy with remove
8432
8433!call display(v7dout)
8434
8435end subroutine v7d_rounding
8436
8437
8439
8445
8446
Set of functions that return a trimmed CHARACTER representation of the input variable. Definition: char_utilities.F90:278 Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o... Definition: datetime_class.F90:478 Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ... Definition: datetime_class.F90:485 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:445 Reduce some dimensions (level and timerage) for semplification (rounding). Definition: vol7d_class.F90:462 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:212 Definition of constants to be used for declaring variables of a desired type. Definition: kinds.F90:245 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:212 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:273 Classe per la gestione dei livelli verticali in osservazioni meteo e affini. Definition: vol7d_level_class.F90:213 Classe per la gestione delle reti di stazioni per osservazioni meteo e affini. Definition: vol7d_network_class.F90:214 Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. Definition: vol7d_timerange_class.F90:215 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:312 |