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