libsim Versione 7.1.11

◆ 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 5059 del file vol7d_class.F90.

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

Generated with Doxygen.