libsim Versione 7.1.11

◆ vol7d_get_volanaattri()

subroutine vol7d_get_volanaattri ( type(vol7d), intent(in)  this,
integer, dimension(:), intent(in)  dimlist,
integer, dimension(:), optional, pointer  vol1dp,
integer, dimension(:,:), optional, pointer  vol2dp,
integer, dimension(:,:,:), optional, pointer  vol3dp,
integer, dimension(:,:,:,:), optional, pointer  vol4dp 
)

Crea una vista a dimensione ridotta di un volume di attributi 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_volanaattri(v7d1, (/vol7d_ana_d/), vol1d)
IF (ASSOCIATED(vol1d)) THEN
print*,vol1d
...
ENDIF
return
Parametri
[in]thisoggetto di cui creare la vista
[in]dimlistlista delle dimensioni da includere nella vista, attenzione tutte le dimensioni non degeneri (cioè con estensione >1) devono essere incluse nella lista; utilizzare le costanti vol7d_ana_a ... vol7d_attr_a, ecc.
vol1dparray che in uscita conterrà la vista 1d
vol2dparray che in uscita conterrà la vista 2d
vol3dparray che in uscita conterrà la vista 3d
vol4dparray che in uscita conterrà la vista 4d

Definizione alla linea 4950 del file vol7d_class.F90.

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

Generated with Doxygen.