libsim Versione 7.2.1

◆ vol7d_get_voldatiattri()

subroutine vol7d_get_voldatiattri ( 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,
integer, dimension(:,:,:,:,:), optional, pointer vol5dp,
integer, dimension(:,:,:,:,:,:), optional, pointer vol6dp,
integer, dimension(:,:,:,:,:,:,:), optional, pointer vol7dp )

Crea una vista a dimensione ridotta di un volume di attributi di dati di tipo INTEGER.

È necessario fornire uno solo dei parametri opzionali vol*dp corrispondente al numero di dimensioni richieste. L'ordine delle dimensioni nella vista è quello prefissato in ::vol7d indipendentemente dall'ordine delle dimensioni fornito in dimlist. In caso di fallimento, in particolare se dimlist non contiene tutte le dimensioni non degeneri del volume richiesto oppure se una delle dimensioni è =0, il puntatore vol*dp è restituito in uno stato disassociato, per cui è opportuno controllare sempre in uscita, lo stato del puntatore per evitare che il programma abortisca con un errore di sistema, ad esempio:

INTEGER, POINTER :: vol2d(:,:)
...
CALL vol7d_get_voldatiattri(v7d1, (/vol7d_ana_d, vol7d_time_d/), vol2d)
IF (ASSOCIATED(vol2d)) THEN
print*,vol2d
...
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_d ... vol7d_attr_d, 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
vol5dparray che in uscita conterrà la vista 5d
vol6dparray che in uscita conterrà la vista 6d
vol7dparray che in uscita conterrà la vista 7d

Definizione alla linea 5053 del file vol7d_class.F90.

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