libsim Versione 7.2.4
|
◆ vol7d_get_volanai()
Crea una vista a dimensione ridotta di un volume di anagrafica 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 :: vol1d(:)
...
CALL vol7d_get_volanai(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Definizione alla linea 4892 del file vol7d_class.F90. 4894! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
4895! authors:
4896! Davide Cesari <dcesari@arpa.emr.it>
4897! Paolo Patruno <ppatruno@arpa.emr.it>
4898
4899! This program is free software; you can redistribute it and/or
4900! modify it under the terms of the GNU General Public License as
4901! published by the Free Software Foundation; either version 2 of
4902! the License, or (at your option) any later version.
4903
4904! This program is distributed in the hope that it will be useful,
4905! but WITHOUT ANY WARRANTY; without even the implied warranty of
4906! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
4907! GNU General Public License for more details.
4908
4909! You should have received a copy of the GNU General Public License
4910! along with this program. If not, see <http://www.gnu.org/licenses/>.
4911#include "config.h"
4912
4924
4992IMPLICIT NONE
4993
4994
4995INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
4996 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
4997
4998INTEGER, PARAMETER :: vol7d_ana_a=1
4999INTEGER, PARAMETER :: vol7d_var_a=2
5000INTEGER, PARAMETER :: vol7d_network_a=3
5001INTEGER, PARAMETER :: vol7d_attr_a=4
5002INTEGER, PARAMETER :: vol7d_ana_d=1
5003INTEGER, PARAMETER :: vol7d_time_d=2
5004INTEGER, PARAMETER :: vol7d_level_d=3
5005INTEGER, PARAMETER :: vol7d_timerange_d=4
5006INTEGER, PARAMETER :: vol7d_var_d=5
5007INTEGER, PARAMETER :: vol7d_network_d=6
5008INTEGER, PARAMETER :: vol7d_attr_d=7
5009INTEGER, PARAMETER :: vol7d_cdatalen=32
5010
5011TYPE vol7d_varmap
5012 INTEGER :: r, d, i, b, c
5013END TYPE vol7d_varmap
5014
5019 TYPE(vol7d_ana),POINTER :: ana(:)
5021 TYPE(datetime),POINTER :: time(:)
5023 TYPE(vol7d_level),POINTER :: level(:)
5025 TYPE(vol7d_timerange),POINTER :: timerange(:)
5027 TYPE(vol7d_network),POINTER :: network(:)
5029 TYPE(vol7d_varvect) :: anavar
5031 TYPE(vol7d_varvect) :: anaattr
5033 TYPE(vol7d_varvect) :: anavarattr
5035 TYPE(vol7d_varvect) :: dativar
5037 TYPE(vol7d_varvect) :: datiattr
5039 TYPE(vol7d_varvect) :: dativarattr
5040
5042 REAL,POINTER :: volanar(:,:,:)
5044 DOUBLE PRECISION,POINTER :: volanad(:,:,:)
5046 INTEGER,POINTER :: volanai(:,:,:)
5048 INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
5050 CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
5051
5053 REAL,POINTER :: volanaattrr(:,:,:,:)
5055 DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
5057 INTEGER,POINTER :: volanaattri(:,:,:,:)
5059 INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
5061 CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
5062
5064 REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
5066 DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
5068 INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
5070 INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
5072 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
5073
5075 REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
5077 DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
5079 INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
5081 INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
5083 CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
5084
5086 integer :: time_definition
5087
5089
5094 MODULE PROCEDURE vol7d_init
5095END INTERFACE
5096
5099 MODULE PROCEDURE vol7d_delete
5100END INTERFACE
5101
5104 MODULE PROCEDURE vol7d_write_on_file
5105END INTERFACE
5106
5108INTERFACE import
5109 MODULE PROCEDURE vol7d_read_from_file
5110END INTERFACE
5111
5114 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
5115END INTERFACE
5116
5119 MODULE PROCEDURE to_char_dat
5120END INTERFACE
5121
5124 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5125END INTERFACE
5126
5129 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
5130END INTERFACE
5131
5134 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
5135END INTERFACE
5136
5139 MODULE PROCEDURE vol7d_copy
5140END INTERFACE
5141
5144 MODULE PROCEDURE vol7d_c_e
5145END INTERFACE
5146
5151 MODULE PROCEDURE vol7d_check
5152END INTERFACE
5153
5168 MODULE PROCEDURE v7d_rounding
5169END INTERFACE
5170
5171!!$INTERFACE get_volana
5172!!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
5173!!$ vol7d_get_volanab, vol7d_get_volanac
5174!!$END INTERFACE
5175!!$
5176!!$INTERFACE get_voldati
5177!!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
5178!!$ vol7d_get_voldatib, vol7d_get_voldatic
5179!!$END INTERFACE
5180!!$
5181!!$INTERFACE get_volanaattr
5182!!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
5183!!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
5184!!$END INTERFACE
5185!!$
5186!!$INTERFACE get_voldatiattr
5187!!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
5188!!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
5189!!$END INTERFACE
5190
5191PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
5192 vol7d_get_volc, &
5193 volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
5194 volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
5195 volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
5196 volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
5197 volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
5198 vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
5199 vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
5200 vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
5201 vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
5202 vol7d_display, dat_display, dat_vect_display, &
5203 to_char_dat, vol7d_check
5204
5205PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
5206
5207PRIVATE vol7d_c_e
5208
5209CONTAINS
5210
5211
5216SUBROUTINE vol7d_init(this,time_definition)
5217TYPE(vol7d),intent(out) :: this
5218integer,INTENT(IN),OPTIONAL :: time_definition
5219
5226CALL vol7d_var_features_init() ! initialise var features table once
5227
5228NULLIFY(this%ana, this%time, this%level, this%timerange, this%network)
5229
5230NULLIFY(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
5231NULLIFY(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
5232NULLIFY(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
5233NULLIFY(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
5234NULLIFY(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
5235
5236if(present(time_definition)) then
5237 this%time_definition=time_definition
5238else
5239 this%time_definition=1 !default to validity time
5240end if
5241
5242END SUBROUTINE vol7d_init
5243
5244
5248ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
5249TYPE(vol7d),intent(inout) :: this
5250LOGICAL, INTENT(in), OPTIONAL :: dataonly
5251
5252
5253IF (.NOT. optio_log(dataonly)) THEN
5254 IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
5255 IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
5256 IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
5257 IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
5258 IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
5259 IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
5260 IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
5261 IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
5262 IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
5263 IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
5264ENDIF
5265IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
5266IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
5267IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
5268IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
5269IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
5270IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
5271IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
5272IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
5273IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
5274IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
5275
5276IF (.NOT. optio_log(dataonly)) THEN
5277 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5278 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5279ENDIF
5280IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5281IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5282IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5283
5284IF (.NOT. optio_log(dataonly)) THEN
5288ENDIF
5292
5293END SUBROUTINE vol7d_delete
5294
5295
5296
5297integer function vol7d_check(this)
5298TYPE(vol7d),intent(in) :: this
5299integer :: i,j,k,l,m,n
5300
5301vol7d_check=0
5302
5303if (associated(this%voldatii)) then
5304do i = 1,size(this%voldatii,1)
5305 do j = 1,size(this%voldatii,2)
5306 do k = 1,size(this%voldatii,3)
5307 do l = 1,size(this%voldatii,4)
5308 do m = 1,size(this%voldatii,5)
5309 do n = 1,size(this%voldatii,6)
5310 if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
5311 CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
5313 vol7d_check=1
5314 end if
5315 end do
5316 end do
5317 end do
5318 end do
5319 end do
5320end do
5321end if
5322
5323
5324if (associated(this%voldatir)) then
5325do i = 1,size(this%voldatir,1)
5326 do j = 1,size(this%voldatir,2)
5327 do k = 1,size(this%voldatir,3)
5328 do l = 1,size(this%voldatir,4)
5329 do m = 1,size(this%voldatir,5)
5330 do n = 1,size(this%voldatir,6)
5331 if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
5332 CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
5334 vol7d_check=2
5335 end if
5336 end do
5337 end do
5338 end do
5339 end do
5340 end do
5341end do
5342end if
5343
5344if (associated(this%voldatid)) then
5345do i = 1,size(this%voldatid,1)
5346 do j = 1,size(this%voldatid,2)
5347 do k = 1,size(this%voldatid,3)
5348 do l = 1,size(this%voldatid,4)
5349 do m = 1,size(this%voldatid,5)
5350 do n = 1,size(this%voldatid,6)
5351 if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
5352 CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
5354 vol7d_check=3
5355 end if
5356 end do
5357 end do
5358 end do
5359 end do
5360 end do
5361end do
5362end if
5363
5364if (associated(this%voldatib)) then
5365do i = 1,size(this%voldatib,1)
5366 do j = 1,size(this%voldatib,2)
5367 do k = 1,size(this%voldatib,3)
5368 do l = 1,size(this%voldatib,4)
5369 do m = 1,size(this%voldatib,5)
5370 do n = 1,size(this%voldatib,6)
5371 if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
5372 CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
5374 vol7d_check=4
5375 end if
5376 end do
5377 end do
5378 end do
5379 end do
5380 end do
5381end do
5382end if
5383
5384end function vol7d_check
5385
5386
5387
5388!TODO da completare ! aborta se i volumi sono allocati a dimensione 0
5390SUBROUTINE vol7d_display(this)
5391TYPE(vol7d),intent(in) :: this
5392integer :: i
5393
5394REAL :: rdat
5395DOUBLE PRECISION :: ddat
5396INTEGER :: idat
5397INTEGER(kind=int_b) :: bdat
5398CHARACTER(len=vol7d_cdatalen) :: cdat
5399
5400
5401print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
5402if (this%time_definition == 0) then
5403 print*,"TIME DEFINITION: time is reference time"
5404else if (this%time_definition == 1) then
5405 print*,"TIME DEFINITION: time is validity time"
5406else
5407 print*,"Time definition have a wrong walue:", this%time_definition
5408end if
5409
5410IF (ASSOCIATED(this%network))then
5411 print*,"---- network vector ----"
5412 print*,"elements=",size(this%network)
5413 do i=1, size(this%network)
5415 end do
5416end IF
5417
5418IF (ASSOCIATED(this%ana))then
5419 print*,"---- ana vector ----"
5420 print*,"elements=",size(this%ana)
5421 do i=1, size(this%ana)
5423 end do
5424end IF
5425
5426IF (ASSOCIATED(this%time))then
5427 print*,"---- time vector ----"
5428 print*,"elements=",size(this%time)
5429 do i=1, size(this%time)
5431 end do
5432end if
5433
5434IF (ASSOCIATED(this%level)) then
5435 print*,"---- level vector ----"
5436 print*,"elements=",size(this%level)
5437 do i =1,size(this%level)
5439 end do
5440end if
5441
5442IF (ASSOCIATED(this%timerange))then
5443 print*,"---- timerange vector ----"
5444 print*,"elements=",size(this%timerange)
5445 do i =1,size(this%timerange)
5447 end do
5448end if
5449
5450
5451print*,"---- ana vector ----"
5452print*,""
5453print*,"->>>>>>>>> anavar -"
5455print*,""
5456print*,"->>>>>>>>> anaattr -"
5458print*,""
5459print*,"->>>>>>>>> anavarattr -"
5461
5462print*,"-- ana data section (first point) --"
5463
5464idat=imiss
5465rdat=rmiss
5466ddat=dmiss
5467bdat=ibmiss
5468cdat=cmiss
5469
5470!ntime = MIN(SIZE(this%time),nprint)
5471!ntimerange = MIN(SIZE(this%timerange),nprint)
5472!nlevel = MIN(SIZE(this%level),nprint)
5473!nnetwork = MIN(SIZE(this%network),nprint)
5474!nana = MIN(SIZE(this%ana),nprint)
5475
5476IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
5477if (associated(this%volanai)) then
5478 do i=1,size(this%anavar%i)
5479 idat=this%volanai(1,i,1)
5481 end do
5482end if
5483idat=imiss
5484
5485if (associated(this%volanar)) then
5486 do i=1,size(this%anavar%r)
5487 rdat=this%volanar(1,i,1)
5489 end do
5490end if
5491rdat=rmiss
5492
5493if (associated(this%volanad)) then
5494 do i=1,size(this%anavar%d)
5495 ddat=this%volanad(1,i,1)
5497 end do
5498end if
5499ddat=dmiss
5500
5501if (associated(this%volanab)) then
5502 do i=1,size(this%anavar%b)
5503 bdat=this%volanab(1,i,1)
5505 end do
5506end if
5507bdat=ibmiss
5508
5509if (associated(this%volanac)) then
5510 do i=1,size(this%anavar%c)
5511 cdat=this%volanac(1,i,1)
5513 end do
5514end if
5515cdat=cmiss
5516ENDIF
5517
5518print*,"---- data vector ----"
5519print*,""
5520print*,"->>>>>>>>> dativar -"
5522print*,""
5523print*,"->>>>>>>>> datiattr -"
5525print*,""
5526print*,"->>>>>>>>> dativarattr -"
5528
5529print*,"-- data data section (first point) --"
5530
5531idat=imiss
5532rdat=rmiss
5533ddat=dmiss
5534bdat=ibmiss
5535cdat=cmiss
5536
5537IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
5538 .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
5539if (associated(this%voldatii)) then
5540 do i=1,size(this%dativar%i)
5541 idat=this%voldatii(1,1,1,1,i,1)
5543 end do
5544end if
5545idat=imiss
5546
5547if (associated(this%voldatir)) then
5548 do i=1,size(this%dativar%r)
5549 rdat=this%voldatir(1,1,1,1,i,1)
5551 end do
5552end if
5553rdat=rmiss
5554
5555if (associated(this%voldatid)) then
5556 do i=1,size(this%dativar%d)
5557 ddat=this%voldatid(1,1,1,1,i,1)
5559 end do
5560end if
5561ddat=dmiss
5562
5563if (associated(this%voldatib)) then
5564 do i=1,size(this%dativar%b)
5565 bdat=this%voldatib(1,1,1,1,i,1)
5567 end do
5568end if
5569bdat=ibmiss
5570
5571if (associated(this%voldatic)) then
5572 do i=1,size(this%dativar%c)
5573 cdat=this%voldatic(1,1,1,1,i,1)
5575 end do
5576end if
5577cdat=cmiss
5578ENDIF
5579
5580print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
5581
5582END SUBROUTINE vol7d_display
5583
5584
5586SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
5587TYPE(vol7d_var),intent(in) :: this
5589REAL :: rdat
5591DOUBLE PRECISION :: ddat
5593INTEGER :: idat
5595INTEGER(kind=int_b) :: bdat
5597CHARACTER(len=*) :: cdat
5598
5599print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5600
5601end SUBROUTINE dat_display
5602
5604SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
5605
5606TYPE(vol7d_var),intent(in) :: this(:)
5608REAL :: rdat(:)
5610DOUBLE PRECISION :: ddat(:)
5612INTEGER :: idat(:)
5614INTEGER(kind=int_b) :: bdat(:)
5616CHARACTER(len=*):: cdat(:)
5617
5618integer :: i
5619
5620do i =1,size(this)
5622end do
5623
5624end SUBROUTINE dat_vect_display
5625
5626
5627FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
5628#ifdef HAVE_DBALLE
5629USE dballef
5630#endif
5631TYPE(vol7d_var),INTENT(in) :: this
5633REAL :: rdat
5635DOUBLE PRECISION :: ddat
5637INTEGER :: idat
5639INTEGER(kind=int_b) :: bdat
5641CHARACTER(len=*) :: cdat
5642CHARACTER(len=80) :: to_char_dat
5643
5644CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
5645
5646
5647#ifdef HAVE_DBALLE
5648INTEGER :: handle, ier
5649
5650handle = 0
5651to_char_dat="VALUE: "
5652
5657
5659 ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
5660 ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
5661 ier = idba_fatto(handle)
5662 to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
5663endif
5664
5665#else
5666
5667to_char_dat="VALUE: "
5673
5674#endif
5675
5676END FUNCTION to_char_dat
5677
5678
5681FUNCTION vol7d_c_e(this) RESULT(c_e)
5682TYPE(vol7d), INTENT(in) :: this
5683
5684LOGICAL :: c_e
5685
5687 ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
5688 ASSOCIATED(this%network) .OR. &
5689 ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5690 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5691 ASSOCIATED(this%anavar%c) .OR. &
5692 ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
5693 ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
5694 ASSOCIATED(this%anaattr%c) .OR. &
5695 ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
5696 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
5697 ASSOCIATED(this%dativar%c) .OR. &
5698 ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
5699 ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
5700 ASSOCIATED(this%datiattr%c)
5701
5702END FUNCTION vol7d_c_e
5703
5704
5743SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
5744 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5745 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5746 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5747 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5748 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5749 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
5750 ini)
5751TYPE(vol7d),INTENT(inout) :: this
5752INTEGER,INTENT(in),OPTIONAL :: nana
5753INTEGER,INTENT(in),OPTIONAL :: ntime
5754INTEGER,INTENT(in),OPTIONAL :: nlevel
5755INTEGER,INTENT(in),OPTIONAL :: ntimerange
5756INTEGER,INTENT(in),OPTIONAL :: nnetwork
5758INTEGER,INTENT(in),OPTIONAL :: &
5759 nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
5760 nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
5761 nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
5762 ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
5763 ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
5764 ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
5765LOGICAL,INTENT(in),OPTIONAL :: ini
5766
5767INTEGER :: i
5768LOGICAL :: linit
5769
5770IF (PRESENT(ini)) THEN
5771 linit = ini
5772ELSE
5773 linit = .false.
5774ENDIF
5775
5776! Dimensioni principali
5777IF (PRESENT(nana)) THEN
5778 IF (nana >= 0) THEN
5779 IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
5780 ALLOCATE(this%ana(nana))
5781 IF (linit) THEN
5782 DO i = 1, nana
5784 ENDDO
5785 ENDIF
5786 ENDIF
5787ENDIF
5788IF (PRESENT(ntime)) THEN
5789 IF (ntime >= 0) THEN
5790 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
5791 ALLOCATE(this%time(ntime))
5792 IF (linit) THEN
5793 DO i = 1, ntime
5795 ENDDO
5796 ENDIF
5797 ENDIF
5798ENDIF
5799IF (PRESENT(nlevel)) THEN
5800 IF (nlevel >= 0) THEN
5801 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
5802 ALLOCATE(this%level(nlevel))
5803 IF (linit) THEN
5804 DO i = 1, nlevel
5806 ENDDO
5807 ENDIF
5808 ENDIF
5809ENDIF
5810IF (PRESENT(ntimerange)) THEN
5811 IF (ntimerange >= 0) THEN
5812 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
5813 ALLOCATE(this%timerange(ntimerange))
5814 IF (linit) THEN
5815 DO i = 1, ntimerange
5817 ENDDO
5818 ENDIF
5819 ENDIF
5820ENDIF
5821IF (PRESENT(nnetwork)) THEN
5822 IF (nnetwork >= 0) THEN
5823 IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
5824 ALLOCATE(this%network(nnetwork))
5825 IF (linit) THEN
5826 DO i = 1, nnetwork
5828 ENDDO
5829 ENDIF
5830 ENDIF
5831ENDIF
5832! Dimensioni dei tipi delle variabili
5833CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
5834 nanavari, nanavarb, nanavarc, ini)
5835CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
5836 nanaattri, nanaattrb, nanaattrc, ini)
5837CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
5838 nanavarattri, nanavarattrb, nanavarattrc, ini)
5839CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
5840 ndativari, ndativarb, ndativarc, ini)
5841CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
5842 ndatiattri, ndatiattrb, ndatiattrc, ini)
5843CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
5844 ndativarattri, ndativarattrb, ndativarattrc, ini)
5845
5846END SUBROUTINE vol7d_alloc
5847
5848
5849FUNCTION vol7d_check_alloc_ana(this)
5850TYPE(vol7d),INTENT(in) :: this
5851LOGICAL :: vol7d_check_alloc_ana
5852
5853vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
5854
5855END FUNCTION vol7d_check_alloc_ana
5856
5857SUBROUTINE vol7d_force_alloc_ana(this, ini)
5858TYPE(vol7d),INTENT(inout) :: this
5859LOGICAL,INTENT(in),OPTIONAL :: ini
5860
5861! Alloco i descrittori minimi per avere un volume di anagrafica
5862IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
5863IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
5864
5865END SUBROUTINE vol7d_force_alloc_ana
5866
5867
5868FUNCTION vol7d_check_alloc_dati(this)
5869TYPE(vol7d),INTENT(in) :: this
5870LOGICAL :: vol7d_check_alloc_dati
5871
5872vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
5873 ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
5874 ASSOCIATED(this%timerange)
5875
5876END FUNCTION vol7d_check_alloc_dati
5877
5878SUBROUTINE vol7d_force_alloc_dati(this, ini)
5879TYPE(vol7d),INTENT(inout) :: this
5880LOGICAL,INTENT(in),OPTIONAL :: ini
5881
5882! Alloco i descrittori minimi per avere un volume di dati
5883CALL vol7d_force_alloc_ana(this, ini)
5884IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
5885IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
5886IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
5887
5888END SUBROUTINE vol7d_force_alloc_dati
5889
5890
5891SUBROUTINE vol7d_force_alloc(this)
5892TYPE(vol7d),INTENT(inout) :: this
5893
5894! If anything really not allocated yet, allocate with size 0
5895IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
5896IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
5897IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
5898IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
5899IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
5900
5901END SUBROUTINE vol7d_force_alloc
5902
5903
5904FUNCTION vol7d_check_vol(this)
5905TYPE(vol7d),INTENT(in) :: this
5906LOGICAL :: vol7d_check_vol
5907
5908vol7d_check_vol = c_e(this)
5909
5910! Anagrafica
5911IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
5912 vol7d_check_vol = .false.
5913ENDIF
5914
5915IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
5916 vol7d_check_vol = .false.
5917ENDIF
5918
5919IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
5920 vol7d_check_vol = .false.
5921ENDIF
5922
5923IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
5924 vol7d_check_vol = .false.
5925ENDIF
5926
5927IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
5928 vol7d_check_vol = .false.
5929ENDIF
5930IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
5931 ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
5932 ASSOCIATED(this%anavar%c)) THEN
5933 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
5934ENDIF
5935
5936! Attributi dell'anagrafica
5937IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
5938 .NOT.ASSOCIATED(this%volanaattrr)) THEN
5939 vol7d_check_vol = .false.
5940ENDIF
5941
5942IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
5943 .NOT.ASSOCIATED(this%volanaattrd)) THEN
5944 vol7d_check_vol = .false.
5945ENDIF
5946
5947IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
5948 .NOT.ASSOCIATED(this%volanaattri)) THEN
5949 vol7d_check_vol = .false.
5950ENDIF
5951
5952IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
5953 .NOT.ASSOCIATED(this%volanaattrb)) THEN
5954 vol7d_check_vol = .false.
5955ENDIF
5956
5957IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
5958 .NOT.ASSOCIATED(this%volanaattrc)) THEN
5959 vol7d_check_vol = .false.
5960ENDIF
5961
5962! Dati
5963IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
5964 vol7d_check_vol = .false.
5965ENDIF
5966
5967IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
5968 vol7d_check_vol = .false.
5969ENDIF
5970
5971IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
5972 vol7d_check_vol = .false.
5973ENDIF
5974
5975IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
5976 vol7d_check_vol = .false.
5977ENDIF
5978
5979IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
5980 vol7d_check_vol = .false.
5981ENDIF
5982
5983! Attributi dei dati
5984IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
5985 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
5986 vol7d_check_vol = .false.
5987ENDIF
5988
5989IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
5990 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
5991 vol7d_check_vol = .false.
5992ENDIF
5993
5994IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
5995 .NOT.ASSOCIATED(this%voldatiattri)) THEN
5996 vol7d_check_vol = .false.
5997ENDIF
5998
5999IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6000 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6001 vol7d_check_vol = .false.
6002ENDIF
6003
6004IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6005 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6006 vol7d_check_vol = .false.
6007ENDIF
6008IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
6009 ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
6010 ASSOCIATED(this%dativar%c)) THEN
6011 vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
6012ENDIF
6013
6014END FUNCTION vol7d_check_vol
6015
6016
6031SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
6032TYPE(vol7d),INTENT(inout) :: this
6033LOGICAL,INTENT(in),OPTIONAL :: ini
6034LOGICAL,INTENT(in),OPTIONAL :: inivol
6035
6036LOGICAL :: linivol
6037
6038IF (PRESENT(inivol)) THEN
6039 linivol = inivol
6040ELSE
6041 linivol = .true.
6042ENDIF
6043
6044! Anagrafica
6045IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
6046 CALL vol7d_force_alloc_ana(this, ini)
6047 ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
6048 IF (linivol) this%volanar(:,:,:) = rmiss
6049ENDIF
6050
6051IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
6052 CALL vol7d_force_alloc_ana(this, ini)
6053 ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
6054 IF (linivol) this%volanad(:,:,:) = rdmiss
6055ENDIF
6056
6057IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
6058 CALL vol7d_force_alloc_ana(this, ini)
6059 ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
6060 IF (linivol) this%volanai(:,:,:) = imiss
6061ENDIF
6062
6063IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
6064 CALL vol7d_force_alloc_ana(this, ini)
6065 ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
6066 IF (linivol) this%volanab(:,:,:) = ibmiss
6067ENDIF
6068
6069IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
6070 CALL vol7d_force_alloc_ana(this, ini)
6071 ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
6072 IF (linivol) this%volanac(:,:,:) = cmiss
6073ENDIF
6074
6075! Attributi dell'anagrafica
6076IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
6077 .NOT.ASSOCIATED(this%volanaattrr)) THEN
6078 CALL vol7d_force_alloc_ana(this, ini)
6079 ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
6080 SIZE(this%network), SIZE(this%anaattr%r)))
6081 IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
6082ENDIF
6083
6084IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
6085 .NOT.ASSOCIATED(this%volanaattrd)) THEN
6086 CALL vol7d_force_alloc_ana(this, ini)
6087 ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
6088 SIZE(this%network), SIZE(this%anaattr%d)))
6089 IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
6090ENDIF
6091
6092IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
6093 .NOT.ASSOCIATED(this%volanaattri)) THEN
6094 CALL vol7d_force_alloc_ana(this, ini)
6095 ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
6096 SIZE(this%network), SIZE(this%anaattr%i)))
6097 IF (linivol) this%volanaattri(:,:,:,:) = imiss
6098ENDIF
6099
6100IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
6101 .NOT.ASSOCIATED(this%volanaattrb)) THEN
6102 CALL vol7d_force_alloc_ana(this, ini)
6103 ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
6104 SIZE(this%network), SIZE(this%anaattr%b)))
6105 IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
6106ENDIF
6107
6108IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
6109 .NOT.ASSOCIATED(this%volanaattrc)) THEN
6110 CALL vol7d_force_alloc_ana(this, ini)
6111 ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
6112 SIZE(this%network), SIZE(this%anaattr%c)))
6113 IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
6114ENDIF
6115
6116! Dati
6117IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
6118 CALL vol7d_force_alloc_dati(this, ini)
6119 ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6120 SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
6121 IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
6122ENDIF
6123
6124IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
6125 CALL vol7d_force_alloc_dati(this, ini)
6126 ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6127 SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
6128 IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
6129ENDIF
6130
6131IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
6132 CALL vol7d_force_alloc_dati(this, ini)
6133 ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6134 SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
6135 IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
6136ENDIF
6137
6138IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
6139 CALL vol7d_force_alloc_dati(this, ini)
6140 ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6141 SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
6142 IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
6143ENDIF
6144
6145IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
6146 CALL vol7d_force_alloc_dati(this, ini)
6147 ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6148 SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
6149 IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
6150ENDIF
6151
6152! Attributi dei dati
6153IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
6154 .NOT.ASSOCIATED(this%voldatiattrr)) THEN
6155 CALL vol7d_force_alloc_dati(this, ini)
6156 ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6157 SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
6158 SIZE(this%datiattr%r)))
6159 IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
6160ENDIF
6161
6162IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
6163 .NOT.ASSOCIATED(this%voldatiattrd)) THEN
6164 CALL vol7d_force_alloc_dati(this, ini)
6165 ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6166 SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
6167 SIZE(this%datiattr%d)))
6168 IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
6169ENDIF
6170
6171IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
6172 .NOT.ASSOCIATED(this%voldatiattri)) THEN
6173 CALL vol7d_force_alloc_dati(this, ini)
6174 ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6175 SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
6176 SIZE(this%datiattr%i)))
6177 IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
6178ENDIF
6179
6180IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
6181 .NOT.ASSOCIATED(this%voldatiattrb)) THEN
6182 CALL vol7d_force_alloc_dati(this, ini)
6183 ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6184 SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
6185 SIZE(this%datiattr%b)))
6186 IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
6187ENDIF
6188
6189IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
6190 .NOT.ASSOCIATED(this%voldatiattrc)) THEN
6191 CALL vol7d_force_alloc_dati(this, ini)
6192 ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
6193 SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
6194 SIZE(this%datiattr%c)))
6195 IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
6196ENDIF
6197
6198! Catch-all method
6199CALL vol7d_force_alloc(this)
6200
6201! Creo gli indici var-attr
6202
6203#ifdef DEBUG
6204CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
6205#endif
6206
6207CALL vol7d_set_attr_ind(this)
6208
6209
6210
6211END SUBROUTINE vol7d_alloc_vol
6212
6213
6220SUBROUTINE vol7d_set_attr_ind(this)
6221TYPE(vol7d),INTENT(inout) :: this
6222
6223INTEGER :: i
6224
6225! real
6226IF (ASSOCIATED(this%dativar%r)) THEN
6227 IF (ASSOCIATED(this%dativarattr%r)) THEN
6228 DO i = 1, SIZE(this%dativar%r)
6229 this%dativar%r(i)%r = &
6230 firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
6231 ENDDO
6232 ENDIF
6233
6234 IF (ASSOCIATED(this%dativarattr%d)) THEN
6235 DO i = 1, SIZE(this%dativar%r)
6236 this%dativar%r(i)%d = &
6237 firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
6238 ENDDO
6239 ENDIF
6240
6241 IF (ASSOCIATED(this%dativarattr%i)) THEN
6242 DO i = 1, SIZE(this%dativar%r)
6243 this%dativar%r(i)%i = &
6244 firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
6245 ENDDO
6246 ENDIF
6247
6248 IF (ASSOCIATED(this%dativarattr%b)) THEN
6249 DO i = 1, SIZE(this%dativar%r)
6250 this%dativar%r(i)%b = &
6251 firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
6252 ENDDO
6253 ENDIF
6254
6255 IF (ASSOCIATED(this%dativarattr%c)) THEN
6256 DO i = 1, SIZE(this%dativar%r)
6257 this%dativar%r(i)%c = &
6258 firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
6259 ENDDO
6260 ENDIF
6261ENDIF
6262! double
6263IF (ASSOCIATED(this%dativar%d)) THEN
6264 IF (ASSOCIATED(this%dativarattr%r)) THEN
6265 DO i = 1, SIZE(this%dativar%d)
6266 this%dativar%d(i)%r = &
6267 firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
6268 ENDDO
6269 ENDIF
6270
6271 IF (ASSOCIATED(this%dativarattr%d)) THEN
6272 DO i = 1, SIZE(this%dativar%d)
6273 this%dativar%d(i)%d = &
6274 firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
6275 ENDDO
6276 ENDIF
6277
6278 IF (ASSOCIATED(this%dativarattr%i)) THEN
6279 DO i = 1, SIZE(this%dativar%d)
6280 this%dativar%d(i)%i = &
6281 firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
6282 ENDDO
6283 ENDIF
6284
6285 IF (ASSOCIATED(this%dativarattr%b)) THEN
6286 DO i = 1, SIZE(this%dativar%d)
6287 this%dativar%d(i)%b = &
6288 firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
6289 ENDDO
6290 ENDIF
6291
6292 IF (ASSOCIATED(this%dativarattr%c)) THEN
6293 DO i = 1, SIZE(this%dativar%d)
6294 this%dativar%d(i)%c = &
6295 firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
6296 ENDDO
6297 ENDIF
6298ENDIF
6299! integer
6300IF (ASSOCIATED(this%dativar%i)) THEN
6301 IF (ASSOCIATED(this%dativarattr%r)) THEN
6302 DO i = 1, SIZE(this%dativar%i)
6303 this%dativar%i(i)%r = &
6304 firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
6305 ENDDO
6306 ENDIF
6307
6308 IF (ASSOCIATED(this%dativarattr%d)) THEN
6309 DO i = 1, SIZE(this%dativar%i)
6310 this%dativar%i(i)%d = &
6311 firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
6312 ENDDO
6313 ENDIF
6314
6315 IF (ASSOCIATED(this%dativarattr%i)) THEN
6316 DO i = 1, SIZE(this%dativar%i)
6317 this%dativar%i(i)%i = &
6318 firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
6319 ENDDO
6320 ENDIF
6321
6322 IF (ASSOCIATED(this%dativarattr%b)) THEN
6323 DO i = 1, SIZE(this%dativar%i)
6324 this%dativar%i(i)%b = &
6325 firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
6326 ENDDO
6327 ENDIF
6328
6329 IF (ASSOCIATED(this%dativarattr%c)) THEN
6330 DO i = 1, SIZE(this%dativar%i)
6331 this%dativar%i(i)%c = &
6332 firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
6333 ENDDO
6334 ENDIF
6335ENDIF
6336! byte
6337IF (ASSOCIATED(this%dativar%b)) THEN
6338 IF (ASSOCIATED(this%dativarattr%r)) THEN
6339 DO i = 1, SIZE(this%dativar%b)
6340 this%dativar%b(i)%r = &
6341 firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
6342 ENDDO
6343 ENDIF
6344
6345 IF (ASSOCIATED(this%dativarattr%d)) THEN
6346 DO i = 1, SIZE(this%dativar%b)
6347 this%dativar%b(i)%d = &
6348 firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
6349 ENDDO
6350 ENDIF
6351
6352 IF (ASSOCIATED(this%dativarattr%i)) THEN
6353 DO i = 1, SIZE(this%dativar%b)
6354 this%dativar%b(i)%i = &
6355 firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
6356 ENDDO
6357 ENDIF
6358
6359 IF (ASSOCIATED(this%dativarattr%b)) THEN
6360 DO i = 1, SIZE(this%dativar%b)
6361 this%dativar%b(i)%b = &
6362 firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
6363 ENDDO
6364 ENDIF
6365
6366 IF (ASSOCIATED(this%dativarattr%c)) THEN
6367 DO i = 1, SIZE(this%dativar%b)
6368 this%dativar%b(i)%c = &
6369 firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
6370 ENDDO
6371 ENDIF
6372ENDIF
6373! character
6374IF (ASSOCIATED(this%dativar%c)) THEN
6375 IF (ASSOCIATED(this%dativarattr%r)) THEN
6376 DO i = 1, SIZE(this%dativar%c)
6377 this%dativar%c(i)%r = &
6378 firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
6379 ENDDO
6380 ENDIF
6381
6382 IF (ASSOCIATED(this%dativarattr%d)) THEN
6383 DO i = 1, SIZE(this%dativar%c)
6384 this%dativar%c(i)%d = &
6385 firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
6386 ENDDO
6387 ENDIF
6388
6389 IF (ASSOCIATED(this%dativarattr%i)) THEN
6390 DO i = 1, SIZE(this%dativar%c)
6391 this%dativar%c(i)%i = &
6392 firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
6393 ENDDO
6394 ENDIF
6395
6396 IF (ASSOCIATED(this%dativarattr%b)) THEN
6397 DO i = 1, SIZE(this%dativar%c)
6398 this%dativar%c(i)%b = &
6399 firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
6400 ENDDO
6401 ENDIF
6402
6403 IF (ASSOCIATED(this%dativarattr%c)) THEN
6404 DO i = 1, SIZE(this%dativar%c)
6405 this%dativar%c(i)%c = &
6406 firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
6407 ENDDO
6408 ENDIF
6409ENDIF
6410
6411END SUBROUTINE vol7d_set_attr_ind
6412
6413
6418SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
6419 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6420TYPE(vol7d),INTENT(INOUT) :: this
6421TYPE(vol7d),INTENT(INOUT) :: that
6422LOGICAL,INTENT(IN),OPTIONAL :: sort
6423LOGICAL,INTENT(in),OPTIONAL :: bestdata
6424LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
6425
6426TYPE(vol7d) :: v7d_clean
6427
6428
6430 this = that
6432 that = v7d_clean ! destroy that without deallocating
6433ELSE ! Append that to this and destroy that
6435 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
6437ENDIF
6438
6439END SUBROUTINE vol7d_merge
6440
6441
6470SUBROUTINE vol7d_append(this, that, sort, bestdata, &
6471 ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
6472TYPE(vol7d),INTENT(INOUT) :: this
6473TYPE(vol7d),INTENT(IN) :: that
6474LOGICAL,INTENT(IN),OPTIONAL :: sort
6475! experimental, please do not use outside the library now, they force the use
6476! of a simplified mapping algorithm which is valid only whene the dimension
6477! content is the same in both volumes , or when one of them is empty
6478LOGICAL,INTENT(in),OPTIONAL :: bestdata
6479LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
6480
6481
6482TYPE(vol7d) :: v7dtmp
6483LOGICAL :: lsort, lbestdata
6484INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
6485 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
6486
6488IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
6491 RETURN
6492ENDIF
6493
6494IF (this%time_definition /= that%time_definition) THEN
6495 CALL l4f_log(l4f_fatal, &
6496 'in vol7d_append, cannot append volumes with different &
6497 &time definition')
6498 CALL raise_fatal_error()
6499ENDIF
6500
6501! Completo l'allocazione per avere volumi a norma
6502CALL vol7d_alloc_vol(this)
6503
6507
6508! Calcolo le mappature tra volumi vecchi e volume nuovo
6509! I puntatori remap* vengono tutti o allocati o nullificati
6510IF (optio_log(ltimesimple)) THEN
6511 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
6512 lsort, remapt1, remapt2)
6513ELSE
6514 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
6515 lsort, remapt1, remapt2)
6516ENDIF
6517IF (optio_log(ltimerangesimple)) THEN
6518 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
6519 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6520ELSE
6521 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
6522 v7dtmp%timerange, lsort, remaptr1, remaptr2)
6523ENDIF
6524IF (optio_log(llevelsimple)) THEN
6525 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
6526 lsort, remapl1, remapl2)
6527ELSE
6528 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
6529 lsort, remapl1, remapl2)
6530ENDIF
6531IF (optio_log(lanasimple)) THEN
6532 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6533 .false., remapa1, remapa2)
6534ELSE
6535 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
6536 .false., remapa1, remapa2)
6537ENDIF
6538IF (optio_log(lnetworksimple)) THEN
6539 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
6540 .false., remapn1, remapn2)
6541ELSE
6542 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
6543 .false., remapn1, remapn2)
6544ENDIF
6545
6546! Faccio la fusione fisica dei volumi
6547CALL vol7d_merge_finalr(this, that, v7dtmp, &
6548 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6549 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6550CALL vol7d_merge_finald(this, that, v7dtmp, &
6551 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6552 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6553CALL vol7d_merge_finali(this, that, v7dtmp, &
6554 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6555 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6556CALL vol7d_merge_finalb(this, that, v7dtmp, &
6557 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6558 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6559CALL vol7d_merge_finalc(this, that, v7dtmp, &
6560 remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
6561 remaptr1, remaptr2, remapn1, remapn2, lbestdata)
6562
6563! Dealloco i vettori di rimappatura
6564IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
6565IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
6566IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
6567IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
6568IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
6569IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
6570IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
6571IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
6572IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
6573IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
6574
6575! Distruggo il vecchio volume e assegno il nuovo a this
6577this = v7dtmp
6578! Ricreo gli indici var-attr
6579CALL vol7d_set_attr_ind(this)
6580
6581END SUBROUTINE vol7d_append
6582
6583
6616SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
6617 lsort_time, lsort_timerange, lsort_level, &
6618 ltime, ltimerange, llevel, lana, lnetwork, &
6619 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6620 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6621 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6622 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6623 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6624 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6625TYPE(vol7d),INTENT(IN) :: this
6626TYPE(vol7d),INTENT(INOUT) :: that
6627LOGICAL,INTENT(IN),OPTIONAL :: sort
6628LOGICAL,INTENT(IN),OPTIONAL :: unique
6629LOGICAL,INTENT(IN),OPTIONAL :: miss
6630LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6631LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6632LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6640LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6642LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6644LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6646LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6648LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6650LOGICAL,INTENT(in),OPTIONAL :: &
6651 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6652 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6653 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6654 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6655 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6656 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6657
6658LOGICAL :: lsort, lunique, lmiss
6659INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
6660
6663IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
6664
6668
6669! Calcolo le mappature tra volume vecchio e volume nuovo
6670! I puntatori remap* vengono tutti o allocati o nullificati
6671CALL vol7d_remap1_datetime(this%time, that%time, &
6672 lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
6673CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
6674 lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
6675CALL vol7d_remap1_vol7d_level(this%level, that%level, &
6676 lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
6677CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
6678 lsort, lunique, lmiss, remapa, lana)
6679CALL vol7d_remap1_vol7d_network(this%network, that%network, &
6680 lsort, lunique, lmiss, remapn, lnetwork)
6681
6682! lanavari, lanavarb, lanavarc, &
6683! lanaattri, lanaattrb, lanaattrc, &
6684! lanavarattri, lanavarattrb, lanavarattrc, &
6685! ldativari, ldativarb, ldativarc, &
6686! ldatiattri, ldatiattrb, ldatiattrc, &
6687! ldativarattri, ldativarattrb, ldativarattrc
6688! Faccio la riforma fisica dei volumi
6689CALL vol7d_reform_finalr(this, that, &
6690 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6691 lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
6692CALL vol7d_reform_finald(this, that, &
6693 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6694 lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
6695CALL vol7d_reform_finali(this, that, &
6696 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6697 lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
6698CALL vol7d_reform_finalb(this, that, &
6699 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6700 lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
6701CALL vol7d_reform_finalc(this, that, &
6702 remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
6703 lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
6704
6705! Dealloco i vettori di rimappatura
6706IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
6707IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
6708IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
6709IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
6710IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
6711
6712! Ricreo gli indici var-attr
6713CALL vol7d_set_attr_ind(that)
6714that%time_definition = this%time_definition
6715
6716END SUBROUTINE vol7d_copy
6717
6718
6729SUBROUTINE vol7d_reform(this, sort, unique, miss, &
6730 lsort_time, lsort_timerange, lsort_level, &
6731 ltime, ltimerange, llevel, lana, lnetwork, &
6732 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6733 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6734 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6735 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6736 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6737 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
6738 ,purgeana)
6739TYPE(vol7d),INTENT(INOUT) :: this
6740LOGICAL,INTENT(IN),OPTIONAL :: sort
6741LOGICAL,INTENT(IN),OPTIONAL :: unique
6742LOGICAL,INTENT(IN),OPTIONAL :: miss
6743LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
6744LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
6745LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
6753LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
6754LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
6755LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
6756LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
6757LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
6759LOGICAL,INTENT(in),OPTIONAL :: &
6760 lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
6761 lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
6762 lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
6763 ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
6764 ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
6765 ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
6766LOGICAL,INTENT(IN),OPTIONAL :: purgeana
6767
6768TYPE(vol7d) :: v7dtmp
6769logical,allocatable :: llana(:)
6770integer :: i
6771
6773 lsort_time, lsort_timerange, lsort_level, &
6774 ltime, ltimerange, llevel, lana, lnetwork, &
6775 lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
6776 lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
6777 lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
6778 ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
6779 ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
6780 ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
6781
6782! destroy old volume
6784
6785if (optio_log(purgeana)) then
6786 allocate(llana(size(v7dtmp%ana)))
6787 llana =.false.
6788 do i =1,size(v7dtmp%ana)
6789 if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
6790 if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
6791 if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
6792 if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
6793 if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
6794 end do
6795 CALL vol7d_copy(v7dtmp, this,lana=llana)
6797 deallocate(llana)
6798else
6799 this=v7dtmp
6800end if
6801
6802END SUBROUTINE vol7d_reform
6803
6804
6812SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
6813TYPE(vol7d),INTENT(INOUT) :: this
6814LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
6815LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
6816LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
6817
6818INTEGER :: i
6819LOGICAL :: to_be_sorted
6820
6821to_be_sorted = .false.
6822CALL vol7d_alloc_vol(this) ! usual safety check
6823
6824IF (optio_log(lsort_time)) THEN
6825 DO i = 2, SIZE(this%time)
6826 IF (this%time(i) < this%time(i-1)) THEN
6827 to_be_sorted = .true.
6828 EXIT
6829 ENDIF
6830 ENDDO
6831ENDIF
6832IF (optio_log(lsort_timerange)) THEN
6833 DO i = 2, SIZE(this%timerange)
6834 IF (this%timerange(i) < this%timerange(i-1)) THEN
6835 to_be_sorted = .true.
6836 EXIT
6837 ENDIF
6838 ENDDO
6839ENDIF
6840IF (optio_log(lsort_level)) THEN
6841 DO i = 2, SIZE(this%level)
6842 IF (this%level(i) < this%level(i-1)) THEN
6843 to_be_sorted = .true.
6844 EXIT
6845 ENDIF
6846 ENDDO
6847ENDIF
6848
6849IF (to_be_sorted) CALL vol7d_reform(this, &
6850 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
6851
6852END SUBROUTINE vol7d_smart_sort
6853
6861SUBROUTINE vol7d_filter(this, avl, vl, nl, s_d, e_d)
6862TYPE(vol7d),INTENT(inout) :: this
6863CHARACTER(len=*),INTENT(in),OPTIONAL :: avl(:)
6864CHARACTER(len=*),INTENT(in),OPTIONAL :: vl(:)
6865TYPE(vol7d_network),OPTIONAL :: nl(:)
6866TYPE(datetime),INTENT(in),OPTIONAL :: s_d
6867TYPE(datetime),INTENT(in),OPTIONAL :: e_d
6868
6869INTEGER :: i
6870
6871IF (PRESENT(avl)) THEN
6872 IF (SIZE(avl) > 0) THEN
6873
6874 IF (ASSOCIATED(this%anavar%r)) THEN
6875 DO i = 1, SIZE(this%anavar%r)
6876 IF (all(this%anavar%r(i)%btable /= avl)) this%anavar%r(i) = vol7d_var_miss
6877 ENDDO
6878 ENDIF
6879
6880 IF (ASSOCIATED(this%anavar%i)) THEN
6881 DO i = 1, SIZE(this%anavar%i)
6882 IF (all(this%anavar%i(i)%btable /= avl)) this%anavar%i(i) = vol7d_var_miss
6883 ENDDO
6884 ENDIF
6885
6886 IF (ASSOCIATED(this%anavar%b)) THEN
6887 DO i = 1, SIZE(this%anavar%b)
6888 IF (all(this%anavar%b(i)%btable /= avl)) this%anavar%b(i) = vol7d_var_miss
6889 ENDDO
6890 ENDIF
6891
6892 IF (ASSOCIATED(this%anavar%d)) THEN
6893 DO i = 1, SIZE(this%anavar%d)
6894 IF (all(this%anavar%d(i)%btable /= avl)) this%anavar%d(i) = vol7d_var_miss
6895 ENDDO
6896 ENDIF
6897
6898 IF (ASSOCIATED(this%anavar%c)) THEN
6899 DO i = 1, SIZE(this%anavar%c)
6900 IF (all(this%anavar%c(i)%btable /= avl)) this%anavar%c(i) = vol7d_var_miss
6901 ENDDO
6902 ENDIF
6903
6904 ENDIF
6905ENDIF
6906
6907
6908IF (PRESENT(vl)) THEN
6909 IF (size(vl) > 0) THEN
6910 IF (ASSOCIATED(this%dativar%r)) THEN
6911 DO i = 1, SIZE(this%dativar%r)
6912 IF (all(this%dativar%r(i)%btable /= vl)) this%dativar%r(i) = vol7d_var_miss
6913 ENDDO
6914 ENDIF
6915
6916 IF (ASSOCIATED(this%dativar%i)) THEN
6917 DO i = 1, SIZE(this%dativar%i)
6918 IF (all(this%dativar%i(i)%btable /= vl)) this%dativar%i(i) = vol7d_var_miss
6919 ENDDO
6920 ENDIF
6921
6922 IF (ASSOCIATED(this%dativar%b)) THEN
6923 DO i = 1, SIZE(this%dativar%b)
6924 IF (all(this%dativar%b(i)%btable /= vl)) this%dativar%b(i) = vol7d_var_miss
6925 ENDDO
6926 ENDIF
6927
6928 IF (ASSOCIATED(this%dativar%d)) THEN
6929 DO i = 1, SIZE(this%dativar%d)
6930 IF (all(this%dativar%d(i)%btable /= vl)) this%dativar%d(i) = vol7d_var_miss
6931 ENDDO
6932 ENDIF
6933
6934 IF (ASSOCIATED(this%dativar%c)) THEN
6935 DO i = 1, SIZE(this%dativar%c)
6936 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6937 ENDDO
6938 ENDIF
6939
6940 IF (ASSOCIATED(this%dativar%c)) THEN
6941 DO i = 1, SIZE(this%dativar%c)
6942 IF (all(this%dativar%c(i)%btable /= vl)) this%dativar%c(i) = vol7d_var_miss
6943 ENDDO
6944 ENDIF
6945
6946 ENDIF
6947ENDIF
6948
6949IF (PRESENT(nl)) THEN
6950 IF (SIZE(nl) > 0) THEN
6951 DO i = 1, SIZE(this%network)
6952 IF (all(this%network(i) /= nl)) this%network(i) = vol7d_network_miss
6953 ENDDO
6954 ENDIF
6955ENDIF
6956
6957IF (PRESENT(s_d)) THEN
6959 WHERE (this%time < s_d)
6960 this%time = datetime_miss
6961 END WHERE
6962 ENDIF
6963ENDIF
6964
6965IF (PRESENT(e_d)) THEN
6967 WHERE (this%time > e_d)
6968 this%time = datetime_miss
6969 END WHERE
6970 ENDIF
6971ENDIF
6972
6973CALL vol7d_reform(this, miss=.true.)
6974
6975END SUBROUTINE vol7d_filter
6976
6977
6984SUBROUTINE vol7d_convr(this, that, anaconv)
6985TYPE(vol7d),INTENT(IN) :: this
6986TYPE(vol7d),INTENT(INOUT) :: that
6987LOGICAL,OPTIONAL,INTENT(in) :: anaconv
6988INTEGER :: i
6989LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
6990TYPE(vol7d) :: v7d_tmp
6991
6992IF (optio_log(anaconv)) THEN
6993 acp=fv
6994 acn=tv
6995ELSE
6996 acp=tv
6997 acn=fv
6998ENDIF
6999
7000! Volume con solo i dati reali e tutti gli attributi
7001! l'anagrafica e` copiata interamente se necessario
7002CALL vol7d_copy(this, that, &
7003 lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
7004 ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
7005
7006! Volume solo di dati double
7007CALL vol7d_copy(this, v7d_tmp, &
7008 lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
7009 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7010 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7011 ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
7012 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7013 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7014
7015! converto a dati reali
7016IF (ASSOCIATED(v7d_tmp%anavar%d) .OR. ASSOCIATED(v7d_tmp%dativar%d)) THEN
7017
7018 IF (ASSOCIATED(v7d_tmp%anavar%d)) THEN
7019! alloco i dati reali e vi trasferisco i double
7020 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanad, 1), SIZE(v7d_tmp%volanad, 2), &
7021 SIZE(v7d_tmp%volanad, 3)))
7022 DO i = 1, SIZE(v7d_tmp%anavar%d)
7023 v7d_tmp%volanar(:,i,:) = &
7024 realdat(v7d_tmp%volanad(:,i,:), v7d_tmp%anavar%d(i))
7025 ENDDO
7026 DEALLOCATE(v7d_tmp%volanad)
7027! trasferisco le variabili
7028 v7d_tmp%anavar%r => v7d_tmp%anavar%d
7029 NULLIFY(v7d_tmp%anavar%d)
7030 ENDIF
7031
7032 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN
7033! alloco i dati reali e vi trasferisco i double
7034 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
7035 SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
7036 SIZE(v7d_tmp%voldatid, 6)))
7037 DO i = 1, SIZE(v7d_tmp%dativar%d)
7038 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7039 realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
7040 ENDDO
7041 DEALLOCATE(v7d_tmp%voldatid)
7042! trasferisco le variabili
7043 v7d_tmp%dativar%r => v7d_tmp%dativar%d
7044 NULLIFY(v7d_tmp%dativar%d)
7045 ENDIF
7046
7047! fondo con il volume definitivo
7048 CALL vol7d_merge(that, v7d_tmp)
7049ELSE
7051ENDIF
7052
7053
7054! Volume solo di dati interi
7055CALL vol7d_copy(this, v7d_tmp, &
7056 lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
7057 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7058 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7059 ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
7060 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7061 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7062
7063! converto a dati reali
7064IF (ASSOCIATED(v7d_tmp%anavar%i) .OR. ASSOCIATED(v7d_tmp%dativar%i)) THEN
7065
7066 IF (ASSOCIATED(v7d_tmp%anavar%i)) THEN
7067! alloco i dati reali e vi trasferisco gli interi
7068 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanai, 1), SIZE(v7d_tmp%volanai, 2), &
7069 SIZE(v7d_tmp%volanai, 3)))
7070 DO i = 1, SIZE(v7d_tmp%anavar%i)
7071 v7d_tmp%volanar(:,i,:) = &
7072 realdat(v7d_tmp%volanai(:,i,:), v7d_tmp%anavar%i(i))
7073 ENDDO
7074 DEALLOCATE(v7d_tmp%volanai)
7075! trasferisco le variabili
7076 v7d_tmp%anavar%r => v7d_tmp%anavar%i
7077 NULLIFY(v7d_tmp%anavar%i)
7078 ENDIF
7079
7080 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
7081! alloco i dati reali e vi trasferisco gli interi
7082 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
7083 SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
7084 SIZE(v7d_tmp%voldatii, 6)))
7085 DO i = 1, SIZE(v7d_tmp%dativar%i)
7086 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7087 realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
7088 ENDDO
7089 DEALLOCATE(v7d_tmp%voldatii)
7090! trasferisco le variabili
7091 v7d_tmp%dativar%r => v7d_tmp%dativar%i
7092 NULLIFY(v7d_tmp%dativar%i)
7093 ENDIF
7094
7095! fondo con il volume definitivo
7096 CALL vol7d_merge(that, v7d_tmp)
7097ELSE
7099ENDIF
7100
7101
7102! Volume solo di dati byte
7103CALL vol7d_copy(this, v7d_tmp, &
7104 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
7105 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7106 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7107 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
7108 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7109 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7110
7111! converto a dati reali
7112IF (ASSOCIATED(v7d_tmp%anavar%b) .OR. ASSOCIATED(v7d_tmp%dativar%b)) THEN
7113
7114 IF (ASSOCIATED(v7d_tmp%anavar%b)) THEN
7115! alloco i dati reali e vi trasferisco i byte
7116 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanab, 1), SIZE(v7d_tmp%volanab, 2), &
7117 SIZE(v7d_tmp%volanab, 3)))
7118 DO i = 1, SIZE(v7d_tmp%anavar%b)
7119 v7d_tmp%volanar(:,i,:) = &
7120 realdat(v7d_tmp%volanab(:,i,:), v7d_tmp%anavar%b(i))
7121 ENDDO
7122 DEALLOCATE(v7d_tmp%volanab)
7123! trasferisco le variabili
7124 v7d_tmp%anavar%r => v7d_tmp%anavar%b
7125 NULLIFY(v7d_tmp%anavar%b)
7126 ENDIF
7127
7128 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
7129! alloco i dati reali e vi trasferisco i byte
7130 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
7131 SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
7132 SIZE(v7d_tmp%voldatib, 6)))
7133 DO i = 1, SIZE(v7d_tmp%dativar%b)
7134 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7135 realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
7136 ENDDO
7137 DEALLOCATE(v7d_tmp%voldatib)
7138! trasferisco le variabili
7139 v7d_tmp%dativar%r => v7d_tmp%dativar%b
7140 NULLIFY(v7d_tmp%dativar%b)
7141 ENDIF
7142
7143! fondo con il volume definitivo
7144 CALL vol7d_merge(that, v7d_tmp)
7145ELSE
7147ENDIF
7148
7149
7150! Volume solo di dati character
7151CALL vol7d_copy(this, v7d_tmp, &
7152 lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
7153 lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
7154 lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
7155 ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
7156 ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
7157 ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
7158
7159! converto a dati reali
7160IF (ASSOCIATED(v7d_tmp%anavar%c) .OR. ASSOCIATED(v7d_tmp%dativar%c)) THEN
7161
7162 IF (ASSOCIATED(v7d_tmp%anavar%c)) THEN
7163! alloco i dati reali e vi trasferisco i character
7164 ALLOCATE(v7d_tmp%volanar(SIZE(v7d_tmp%volanac, 1), SIZE(v7d_tmp%volanac, 2), &
7165 SIZE(v7d_tmp%volanac, 3)))
7166 DO i = 1, SIZE(v7d_tmp%anavar%c)
7167 v7d_tmp%volanar(:,i,:) = &
7168 realdat(v7d_tmp%volanac(:,i,:), v7d_tmp%anavar%c(i))
7169 ENDDO
7170 DEALLOCATE(v7d_tmp%volanac)
7171! trasferisco le variabili
7172 v7d_tmp%anavar%r => v7d_tmp%anavar%c
7173 NULLIFY(v7d_tmp%anavar%c)
7174 ENDIF
7175
7176 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
7177! alloco i dati reali e vi trasferisco i character
7178 ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
7179 SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
7180 SIZE(v7d_tmp%voldatic, 6)))
7181 DO i = 1, SIZE(v7d_tmp%dativar%c)
7182 v7d_tmp%voldatir(:,:,:,:,i,:) = &
7183 realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
7184 ENDDO
7185 DEALLOCATE(v7d_tmp%voldatic)
7186! trasferisco le variabili
7187 v7d_tmp%dativar%r => v7d_tmp%dativar%c
7188 NULLIFY(v7d_tmp%dativar%c)
7189 ENDIF
7190
7191! fondo con il volume definitivo
7192 CALL vol7d_merge(that, v7d_tmp)
7193ELSE
7195ENDIF
7196
7197END SUBROUTINE vol7d_convr
7198
7199
7203SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
7204TYPE(vol7d),INTENT(IN) :: this
7205TYPE(vol7d),INTENT(OUT) :: that
7206logical , optional, intent(in) :: data_only
7207logical , optional, intent(in) :: ana
7208logical :: ldata_only,lana
7209
7210IF (PRESENT(data_only)) THEN
7211 ldata_only = data_only
7212ELSE
7213 ldata_only = .false.
7214ENDIF
7215
7216IF (PRESENT(ana)) THEN
7217 lana = ana
7218ELSE
7219 lana = .false.
7220ENDIF
7221
7222
7223#undef VOL7D_POLY_ARRAY
7224#define VOL7D_POLY_ARRAY voldati
7225#include "vol7d_class_diff.F90"
7226#undef VOL7D_POLY_ARRAY
7227#define VOL7D_POLY_ARRAY voldatiattr
7228#include "vol7d_class_diff.F90"
7229#undef VOL7D_POLY_ARRAY
7230
7231if ( .not. ldata_only) then
7232
7233#define VOL7D_POLY_ARRAY volana
7234#include "vol7d_class_diff.F90"
7235#undef VOL7D_POLY_ARRAY
7236#define VOL7D_POLY_ARRAY volanaattr
7237#include "vol7d_class_diff.F90"
7238#undef VOL7D_POLY_ARRAY
7239
7240 if(lana)then
7241 where ( this%ana == that%ana )
7242 that%ana = vol7d_ana_miss
7243 end where
7244 end if
7245
7246end if
7247
7248
7249
7250END SUBROUTINE vol7d_diff_only
7251
7252
7253
7254! Creo le routine da ripetere per i vari tipi di dati di v7d
7255! tramite un template e il preprocessore
7256#undef VOL7D_POLY_TYPE
7257#undef VOL7D_POLY_TYPES
7258#define VOL7D_POLY_TYPE REAL
7259#define VOL7D_POLY_TYPES r
7260#include "vol7d_class_type_templ.F90"
7261#undef VOL7D_POLY_TYPE
7262#undef VOL7D_POLY_TYPES
7263#define VOL7D_POLY_TYPE DOUBLE PRECISION
7264#define VOL7D_POLY_TYPES d
7265#include "vol7d_class_type_templ.F90"
7266#undef VOL7D_POLY_TYPE
7267#undef VOL7D_POLY_TYPES
7268#define VOL7D_POLY_TYPE INTEGER
7269#define VOL7D_POLY_TYPES i
7270#include "vol7d_class_type_templ.F90"
7271#undef VOL7D_POLY_TYPE
7272#undef VOL7D_POLY_TYPES
7273#define VOL7D_POLY_TYPE INTEGER(kind=int_b)
7274#define VOL7D_POLY_TYPES b
7275#include "vol7d_class_type_templ.F90"
7276#undef VOL7D_POLY_TYPE
7277#undef VOL7D_POLY_TYPES
7278#define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
7279#define VOL7D_POLY_TYPES c
7280#include "vol7d_class_type_templ.F90"
7281
7282! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
7283! tramite un template e il preprocessore
7284#define VOL7D_SORT
7285#undef VOL7D_NO_ZERO_ALLOC
7286#undef VOL7D_POLY_TYPE
7287#define VOL7D_POLY_TYPE datetime
7288#include "vol7d_class_desc_templ.F90"
7289#undef VOL7D_POLY_TYPE
7290#define VOL7D_POLY_TYPE vol7d_timerange
7291#include "vol7d_class_desc_templ.F90"
7292#undef VOL7D_POLY_TYPE
7293#define VOL7D_POLY_TYPE vol7d_level
7294#include "vol7d_class_desc_templ.F90"
7295#undef VOL7D_SORT
7296#undef VOL7D_POLY_TYPE
7297#define VOL7D_POLY_TYPE vol7d_network
7298#include "vol7d_class_desc_templ.F90"
7299#undef VOL7D_POLY_TYPE
7300#define VOL7D_POLY_TYPE vol7d_ana
7301#include "vol7d_class_desc_templ.F90"
7302#define VOL7D_NO_ZERO_ALLOC
7303#undef VOL7D_POLY_TYPE
7304#define VOL7D_POLY_TYPE vol7d_var
7305#include "vol7d_class_desc_templ.F90"
7306
7316subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
7317
7318TYPE(vol7d),INTENT(IN) :: this
7319integer,optional,intent(inout) :: unit
7320character(len=*),intent(in),optional :: filename
7321character(len=*),intent(out),optional :: filename_auto
7322character(len=*),INTENT(IN),optional :: description
7323
7324integer :: lunit
7325character(len=254) :: ldescription,arg,lfilename
7326integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7327 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7328 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7329 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7330 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7331 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7332 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7333!integer :: im,id,iy
7334integer :: tarray(8)
7335logical :: opened,exist
7336
7337 nana=0
7338 ntime=0
7339 ntimerange=0
7340 nlevel=0
7341 nnetwork=0
7342 ndativarr=0
7343 ndativari=0
7344 ndativarb=0
7345 ndativard=0
7346 ndativarc=0
7347 ndatiattrr=0
7348 ndatiattri=0
7349 ndatiattrb=0
7350 ndatiattrd=0
7351 ndatiattrc=0
7352 ndativarattrr=0
7353 ndativarattri=0
7354 ndativarattrb=0
7355 ndativarattrd=0
7356 ndativarattrc=0
7357 nanavarr=0
7358 nanavari=0
7359 nanavarb=0
7360 nanavard=0
7361 nanavarc=0
7362 nanaattrr=0
7363 nanaattri=0
7364 nanaattrb=0
7365 nanaattrd=0
7366 nanaattrc=0
7367 nanavarattrr=0
7368 nanavarattri=0
7369 nanavarattrb=0
7370 nanavarattrd=0
7371 nanavarattrc=0
7372
7373
7374!call idate(im,id,iy)
7375call date_and_time(values=tarray)
7376call getarg(0,arg)
7377
7378if (present(description))then
7379 ldescription=description
7380else
7381 ldescription="Vol7d generated by: "//trim(arg)
7382end if
7383
7384if (.not. present(unit))then
7385 lunit=getunit()
7386else
7387 if (unit==0)then
7388 lunit=getunit()
7389 unit=lunit
7390 else
7391 lunit=unit
7392 end if
7393end if
7394
7395lfilename=trim(arg)//".v7d"
7397
7398if (present(filename))then
7399 if (filename /= "")then
7400 lfilename=filename
7401 end if
7402end if
7403
7404if (present(filename_auto))filename_auto=lfilename
7405
7406
7407inquire(unit=lunit,opened=opened)
7408if (.not. opened) then
7409! inquire(file=lfilename, EXIST=exist)
7410! IF (exist) THEN
7411! CALL l4f_log(L4F_FATAL, &
7412! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
7413! CALL raise_fatal_error()
7414! ENDIF
7415 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
7416 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7417end if
7418
7419if (associated(this%ana)) nana=size(this%ana)
7420if (associated(this%time)) ntime=size(this%time)
7421if (associated(this%timerange)) ntimerange=size(this%timerange)
7422if (associated(this%level)) nlevel=size(this%level)
7423if (associated(this%network)) nnetwork=size(this%network)
7424
7425if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
7426if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
7427if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
7428if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
7429if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
7430
7431if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
7432if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
7433if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
7434if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
7435if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
7436
7437if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
7438if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
7439if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
7440if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
7441if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
7442
7443if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
7444if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
7445if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
7446if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
7447if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
7448
7449if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
7450if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
7451if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
7452if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
7453if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
7454
7455if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
7456if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
7457if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
7458if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
7459if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
7460
7461write(unit=lunit)ldescription
7462write(unit=lunit)tarray
7463
7464write(unit=lunit)&
7465 nana, ntime, ntimerange, nlevel, nnetwork, &
7466 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7467 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7468 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7469 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7470 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7471 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7472 this%time_definition
7473
7474
7475!write(unit=lunit)this
7476
7477
7478!! prime 5 dimensioni
7481if (associated(this%level)) write(unit=lunit)this%level
7482if (associated(this%timerange)) write(unit=lunit)this%timerange
7483if (associated(this%network)) write(unit=lunit)this%network
7484
7485 !! 6a dimensione: variabile dell'anagrafica e dei dati
7486 !! con relativi attributi e in 5 tipi diversi
7487
7488if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
7489if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
7490if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
7491if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
7492if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
7493
7494if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
7495if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
7496if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
7497if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
7498if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
7499
7500if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
7501if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
7502if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
7503if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
7504if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
7505
7506if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
7507if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
7508if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
7509if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
7510if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
7511
7512if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
7513if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
7514if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
7515if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
7516if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
7517
7518if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
7519if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
7520if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
7521if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
7522if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
7523
7524!! Volumi di valori e attributi per anagrafica e dati
7525
7526if (associated(this%volanar)) write(unit=lunit)this%volanar
7527if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
7528if (associated(this%voldatir)) write(unit=lunit)this%voldatir
7529if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
7530
7531if (associated(this%volanai)) write(unit=lunit)this%volanai
7532if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
7533if (associated(this%voldatii)) write(unit=lunit)this%voldatii
7534if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
7535
7536if (associated(this%volanab)) write(unit=lunit)this%volanab
7537if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
7538if (associated(this%voldatib)) write(unit=lunit)this%voldatib
7539if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
7540
7541if (associated(this%volanad)) write(unit=lunit)this%volanad
7542if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
7543if (associated(this%voldatid)) write(unit=lunit)this%voldatid
7544if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
7545
7546if (associated(this%volanac)) write(unit=lunit)this%volanac
7547if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
7548if (associated(this%voldatic)) write(unit=lunit)this%voldatic
7549if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
7550
7551if (.not. present(unit)) close(unit=lunit)
7552
7553end subroutine vol7d_write_on_file
7554
7555
7562
7563
7564subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
7565
7566TYPE(vol7d),INTENT(OUT) :: this
7567integer,intent(inout),optional :: unit
7568character(len=*),INTENT(in),optional :: filename
7569character(len=*),intent(out),optional :: filename_auto
7570character(len=*),INTENT(out),optional :: description
7571integer,intent(out),optional :: tarray(8)
7572
7573
7574integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
7575 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7576 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7577 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7578 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7579 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7580 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
7581
7582character(len=254) :: ldescription,lfilename,arg
7583integer :: ltarray(8),lunit,ios
7584logical :: opened,exist
7585
7586
7587call getarg(0,arg)
7588
7589if (.not. present(unit))then
7590 lunit=getunit()
7591else
7592 if (unit==0)then
7593 lunit=getunit()
7594 unit=lunit
7595 else
7596 lunit=unit
7597 end if
7598end if
7599
7600lfilename=trim(arg)//".v7d"
7602
7603if (present(filename))then
7604 if (filename /= "")then
7605 lfilename=filename
7606 end if
7607end if
7608
7609if (present(filename_auto))filename_auto=lfilename
7610
7611
7612inquire(unit=lunit,opened=opened)
7613IF (.NOT. opened) THEN
7614 inquire(file=lfilename,exist=exist)
7615 IF (.NOT.exist) THEN
7616 CALL l4f_log(l4f_fatal, &
7617 'in vol7d_read_from_file, file does not exists, cannot open')
7618 CALL raise_fatal_error()
7619 ENDIF
7620 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
7621 status='OLD', action='READ')
7622 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
7623end if
7624
7625
7627read(unit=lunit,iostat=ios)ldescription
7628
7629if (ios < 0) then ! A negative value indicates that the End of File or End of Record
7630 call vol7d_alloc (this)
7631 call vol7d_alloc_vol (this)
7632 if (present(description))description=ldescription
7633 if (present(tarray))tarray=ltarray
7634 if (.not. present(unit)) close(unit=lunit)
7635end if
7636
7637read(unit=lunit)ltarray
7638
7639CALL l4f_log(l4f_info, 'Reading vol7d from file')
7640CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
7643
7644if (present(description))description=ldescription
7645if (present(tarray))tarray=ltarray
7646
7647read(unit=lunit)&
7648 nana, ntime, ntimerange, nlevel, nnetwork, &
7649 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
7650 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
7651 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
7652 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
7653 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
7654 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
7655 this%time_definition
7656
7657call vol7d_alloc (this, &
7658 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
7659 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
7660 ndativard=ndativard, ndativarc=ndativarc,&
7661 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
7662 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
7663 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
7664 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
7665 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
7666 nanavard=nanavard, nanavarc=nanavarc,&
7667 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
7668 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
7669 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
7670 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
7671
7672
7675if (associated(this%level)) read(unit=lunit)this%level
7676if (associated(this%timerange)) read(unit=lunit)this%timerange
7677if (associated(this%network)) read(unit=lunit)this%network
7678
7679if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
7680if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
7681if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
7682if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
7683if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
7684
7685if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
7686if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
7687if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
7688if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
7689if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
7690
7691if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
7692if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
7693if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
7694if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
7695if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
7696
7697if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
7698if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
7699if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
7700if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
7701if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
7702
7703if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
7704if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
7705if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
7706if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
7707if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
7708
7709if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
7710if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
7711if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
7712if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
7713if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
7714
7715call vol7d_alloc_vol (this)
7716
7717!! Volumi di valori e attributi per anagrafica e dati
7718
7719if (associated(this%volanar)) read(unit=lunit)this%volanar
7720if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
7721if (associated(this%voldatir)) read(unit=lunit)this%voldatir
7722if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
7723
7724if (associated(this%volanai)) read(unit=lunit)this%volanai
7725if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
7726if (associated(this%voldatii)) read(unit=lunit)this%voldatii
7727if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
7728
7729if (associated(this%volanab)) read(unit=lunit)this%volanab
7730if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
7731if (associated(this%voldatib)) read(unit=lunit)this%voldatib
7732if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
7733
7734if (associated(this%volanad)) read(unit=lunit)this%volanad
7735if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
7736if (associated(this%voldatid)) read(unit=lunit)this%voldatid
7737if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
7738
7739if (associated(this%volanac)) read(unit=lunit)this%volanac
7740if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
7741if (associated(this%voldatic)) read(unit=lunit)this%voldatic
7742if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
7743
7744if (.not. present(unit)) close(unit=lunit)
7745
7746end subroutine vol7d_read_from_file
7747
7748
7749! to double precision
7750elemental doubleprecision function doubledatd(voldat,var)
7751doubleprecision,intent(in) :: voldat
7752type(vol7d_var),intent(in) :: var
7753
7754doubledatd=voldat
7755
7756end function doubledatd
7757
7758
7759elemental doubleprecision function doubledatr(voldat,var)
7760real,intent(in) :: voldat
7761type(vol7d_var),intent(in) :: var
7762
7764 doubledatr=dble(voldat)
7765else
7766 doubledatr=dmiss
7767end if
7768
7769end function doubledatr
7770
7771
7772elemental doubleprecision function doubledati(voldat,var)
7773integer,intent(in) :: voldat
7774type(vol7d_var),intent(in) :: var
7775
7778 doubledati=dble(voldat)/10.d0**var%scalefactor
7779 else
7780 doubledati=dble(voldat)
7781 endif
7782else
7783 doubledati=dmiss
7784end if
7785
7786end function doubledati
7787
7788
7789elemental doubleprecision function doubledatb(voldat,var)
7790integer(kind=int_b),intent(in) :: voldat
7791type(vol7d_var),intent(in) :: var
7792
7795 doubledatb=dble(voldat)/10.d0**var%scalefactor
7796 else
7797 doubledatb=dble(voldat)
7798 endif
7799else
7800 doubledatb=dmiss
7801end if
7802
7803end function doubledatb
7804
7805
7806elemental doubleprecision function doubledatc(voldat,var)
7807CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7808type(vol7d_var),intent(in) :: var
7809
7810doubledatc = c2d(voldat)
7812 doubledatc=doubledatc/10.d0**var%scalefactor
7813end if
7814
7815end function doubledatc
7816
7817
7818! to integer
7819elemental integer function integerdatd(voldat,var)
7820doubleprecision,intent(in) :: voldat
7821type(vol7d_var),intent(in) :: var
7822
7825 integerdatd=nint(voldat*10d0**var%scalefactor)
7826 else
7827 integerdatd=nint(voldat)
7828 endif
7829else
7830 integerdatd=imiss
7831end if
7832
7833end function integerdatd
7834
7835
7836elemental integer function integerdatr(voldat,var)
7837real,intent(in) :: voldat
7838type(vol7d_var),intent(in) :: var
7839
7842 integerdatr=nint(voldat*10d0**var%scalefactor)
7843 else
7844 integerdatr=nint(voldat)
7845 endif
7846else
7847 integerdatr=imiss
7848end if
7849
7850end function integerdatr
7851
7852
7853elemental integer function integerdati(voldat,var)
7854integer,intent(in) :: voldat
7855type(vol7d_var),intent(in) :: var
7856
7857integerdati=voldat
7858
7859end function integerdati
7860
7861
7862elemental integer function integerdatb(voldat,var)
7863integer(kind=int_b),intent(in) :: voldat
7864type(vol7d_var),intent(in) :: var
7865
7867 integerdatb=voldat
7868else
7869 integerdatb=imiss
7870end if
7871
7872end function integerdatb
7873
7874
7875elemental integer function integerdatc(voldat,var)
7876CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7877type(vol7d_var),intent(in) :: var
7878
7879integerdatc=c2i(voldat)
7880
7881end function integerdatc
7882
7883
7884! to real
7885elemental real function realdatd(voldat,var)
7886doubleprecision,intent(in) :: voldat
7887type(vol7d_var),intent(in) :: var
7888
7890 realdatd=real(voldat)
7891else
7892 realdatd=rmiss
7893end if
7894
7895end function realdatd
7896
7897
7898elemental real function realdatr(voldat,var)
7899real,intent(in) :: voldat
7900type(vol7d_var),intent(in) :: var
7901
7902realdatr=voldat
7903
7904end function realdatr
7905
7906
7907elemental real function realdati(voldat,var)
7908integer,intent(in) :: voldat
7909type(vol7d_var),intent(in) :: var
7910
7913 realdati=float(voldat)/10.**var%scalefactor
7914 else
7915 realdati=float(voldat)
7916 endif
7917else
7918 realdati=rmiss
7919end if
7920
7921end function realdati
7922
7923
7924elemental real function realdatb(voldat,var)
7925integer(kind=int_b),intent(in) :: voldat
7926type(vol7d_var),intent(in) :: var
7927
7930 realdatb=float(voldat)/10**var%scalefactor
7931 else
7932 realdatb=float(voldat)
7933 endif
7934else
7935 realdatb=rmiss
7936end if
7937
7938end function realdatb
7939
7940
7941elemental real function realdatc(voldat,var)
7942CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
7943type(vol7d_var),intent(in) :: var
7944
7945realdatc=c2r(voldat)
7947 realdatc=realdatc/10.**var%scalefactor
7948end if
7949
7950end function realdatc
7951
7952
7958FUNCTION realanavol(this, var) RESULT(vol)
7959TYPE(vol7d),INTENT(in) :: this
7960TYPE(vol7d_var),INTENT(in) :: var
7961REAL :: vol(SIZE(this%ana),size(this%network))
7962
7963CHARACTER(len=1) :: dtype
7964INTEGER :: indvar
7965
7966dtype = cmiss
7967indvar = index(this%anavar, var, type=dtype)
7968
7969IF (indvar > 0) THEN
7970 SELECT CASE (dtype)
7971 CASE("d")
7972 vol = realdat(this%volanad(:,indvar,:), var)
7973 CASE("r")
7974 vol = this%volanar(:,indvar,:)
7975 CASE("i")
7976 vol = realdat(this%volanai(:,indvar,:), var)
7977 CASE("b")
7978 vol = realdat(this%volanab(:,indvar,:), var)
7979 CASE("c")
7980 vol = realdat(this%volanac(:,indvar,:), var)
7981 CASE default
7982 vol = rmiss
7983 END SELECT
7984ELSE
7985 vol = rmiss
7986ENDIF
7987
7988END FUNCTION realanavol
7989
7990
7996FUNCTION integeranavol(this, var) RESULT(vol)
7997TYPE(vol7d),INTENT(in) :: this
7998TYPE(vol7d_var),INTENT(in) :: var
7999INTEGER :: vol(SIZE(this%ana),size(this%network))
8000
8001CHARACTER(len=1) :: dtype
8002INTEGER :: indvar
8003
8004dtype = cmiss
8005indvar = index(this%anavar, var, type=dtype)
8006
8007IF (indvar > 0) THEN
8008 SELECT CASE (dtype)
8009 CASE("d")
8010 vol = integerdat(this%volanad(:,indvar,:), var)
8011 CASE("r")
8012 vol = integerdat(this%volanar(:,indvar,:), var)
8013 CASE("i")
8014 vol = this%volanai(:,indvar,:)
8015 CASE("b")
8016 vol = integerdat(this%volanab(:,indvar,:), var)
8017 CASE("c")
8018 vol = integerdat(this%volanac(:,indvar,:), var)
8019 CASE default
8020 vol = imiss
8021 END SELECT
8022ELSE
8023 vol = imiss
8024ENDIF
8025
8026END FUNCTION integeranavol
8027
8028
8034subroutine move_datac (v7d,&
8035 indana,indtime,indlevel,indtimerange,indnetwork,&
8036 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8037
8038TYPE(vol7d),intent(inout) :: v7d
8039
8040integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8041integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8042integer :: inddativar,inddativarattr
8043
8044
8045do inddativar=1,size(v7d%dativar%c)
8046
8048 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8049 ) then
8050
8051 ! dati
8052 v7d%voldatic &
8053 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8054 v7d%voldatic &
8055 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8056
8057
8058 ! attributi
8059 if (associated (v7d%dativarattr%i)) then
8060 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
8061 if (inddativarattr > 0 ) then
8062 v7d%voldatiattri &
8063 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8064 v7d%voldatiattri &
8065 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8066 end if
8067 end if
8068
8069 if (associated (v7d%dativarattr%r)) then
8070 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
8071 if (inddativarattr > 0 ) then
8072 v7d%voldatiattrr &
8073 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8074 v7d%voldatiattrr &
8075 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8076 end if
8077 end if
8078
8079 if (associated (v7d%dativarattr%d)) then
8080 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
8081 if (inddativarattr > 0 ) then
8082 v7d%voldatiattrd &
8083 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8084 v7d%voldatiattrd &
8085 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8086 end if
8087 end if
8088
8089 if (associated (v7d%dativarattr%b)) then
8090 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
8091 if (inddativarattr > 0 ) then
8092 v7d%voldatiattrb &
8093 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8094 v7d%voldatiattrb &
8095 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8096 end if
8097 end if
8098
8099 if (associated (v7d%dativarattr%c)) then
8100 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
8101 if (inddativarattr > 0 ) then
8102 v7d%voldatiattrc &
8103 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8104 v7d%voldatiattrc &
8105 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8106 end if
8107 end if
8108
8109 end if
8110
8111end do
8112
8113end subroutine move_datac
8114
8120subroutine move_datar (v7d,&
8121 indana,indtime,indlevel,indtimerange,indnetwork,&
8122 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
8123
8124TYPE(vol7d),intent(inout) :: v7d
8125
8126integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
8127integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
8128integer :: inddativar,inddativarattr
8129
8130
8131do inddativar=1,size(v7d%dativar%r)
8132
8134 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
8135 ) then
8136
8137 ! dati
8138 v7d%voldatir &
8139 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
8140 v7d%voldatir &
8141 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
8142
8143
8144 ! attributi
8145 if (associated (v7d%dativarattr%i)) then
8146 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
8147 if (inddativarattr > 0 ) then
8148 v7d%voldatiattri &
8149 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8150 v7d%voldatiattri &
8151 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8152 end if
8153 end if
8154
8155 if (associated (v7d%dativarattr%r)) then
8156 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
8157 if (inddativarattr > 0 ) then
8158 v7d%voldatiattrr &
8159 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8160 v7d%voldatiattrr &
8161 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8162 end if
8163 end if
8164
8165 if (associated (v7d%dativarattr%d)) then
8166 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
8167 if (inddativarattr > 0 ) then
8168 v7d%voldatiattrd &
8169 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8170 v7d%voldatiattrd &
8171 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8172 end if
8173 end if
8174
8175 if (associated (v7d%dativarattr%b)) then
8176 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
8177 if (inddativarattr > 0 ) then
8178 v7d%voldatiattrb &
8179 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8180 v7d%voldatiattrb &
8181 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8182 end if
8183 end if
8184
8185 if (associated (v7d%dativarattr%c)) then
8186 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
8187 if (inddativarattr > 0 ) then
8188 v7d%voldatiattrc &
8189 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
8190 v7d%voldatiattrc &
8191 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
8192 end if
8193 end if
8194
8195 end if
8196
8197end do
8198
8199end subroutine move_datar
8200
8201
8215subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
8216type(vol7d),intent(inout) :: v7din
8217type(vol7d),intent(out) :: v7dout
8218type(vol7d_level),intent(in),optional :: level(:)
8219type(vol7d_timerange),intent(in),optional :: timerange(:)
8220!logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
8221!! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
8222logical,intent(in),optional :: nostatproc
8223
8224integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
8225integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
8226type(vol7d_level) :: roundlevel(size(v7din%level))
8227type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
8228type(vol7d) :: v7d_tmp
8229
8230
8231nbin=0
8232
8233if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
8234if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
8235if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
8236if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
8237
8239
8240roundlevel=v7din%level
8241
8242if (present(level))then
8243 do ilevel = 1, size(v7din%level)
8244 if ((any(v7din%level(ilevel) .almosteq. level))) then
8245 roundlevel(ilevel)=level(1)
8246 end if
8247 end do
8248end if
8249
8250roundtimerange=v7din%timerange
8251
8252if (present(timerange))then
8253 do itimerange = 1, size(v7din%timerange)
8254 if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
8255 roundtimerange(itimerange)=timerange(1)
8256 end if
8257 end do
8258end if
8259
8260!set istantaneous values everywere
8261!preserve p1 for forecast time
8262if (optio_log(nostatproc)) then
8263 roundtimerange(:)%timerange=254
8264 roundtimerange(:)%p2=0
8265end if
8266
8267
8268nana=size(v7din%ana)
8269nlevel=count_distinct(roundlevel,back=.true.)
8270ntime=size(v7din%time)
8271ntimerange=count_distinct(roundtimerange,back=.true.)
8272nnetwork=size(v7din%network)
8273
8275
8276if (nbin == 0) then
8278else
8279 call vol7d_convr(v7din,v7d_tmp)
8280end if
8281
8282v7d_tmp%level=roundlevel
8283v7d_tmp%timerange=roundtimerange
8284
8285do ilevel=1, size(v7d_tmp%level)
8286 indl=index(v7d_tmp%level,roundlevel(ilevel))
8287 do itimerange=1,size(v7d_tmp%timerange)
8288 indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
8289
8290 if (indl /= ilevel .or. indt /= itimerange) then
8291
8292 do iana=1, nana
8293 do itime=1,ntime
8294 do inetwork=1,nnetwork
8295
8296 if (nbin > 0) then
8297 call move_datar (v7d_tmp,&
8298 iana,itime,ilevel,itimerange,inetwork,&
8299 iana,itime,indl,indt,inetwork)
8300 else
8301 call move_datac (v7d_tmp,&
8302 iana,itime,ilevel,itimerange,inetwork,&
8303 iana,itime,indl,indt,inetwork)
8304 end if
8305
8306 end do
8307 end do
8308 end do
8309
8310 end if
8311
8312 end do
8313end do
8314
8315! set to missing level and time > nlevel
8316do ilevel=nlevel+1,size(v7d_tmp%level)
8318end do
8319
8320do itimerange=ntimerange+1,size(v7d_tmp%timerange)
8322end do
8323
8324!copy with remove
8327
8328!call display(v7dout)
8329
8330end subroutine v7d_rounding
8331
8332
8334
8340
8341
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 |