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