libsim  Versione6.3.0
vol7d_class.F90
1 ! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2 ! authors:
3 ! Davide Cesari <dcesari@arpa.emr.it>
4 ! Paolo Patruno <ppatruno@arpa.emr.it>
5 
6 ! This program is free software; you can redistribute it and/or
7 ! modify it under the terms of the GNU General Public License as
8 ! published by the Free Software Foundation; either version 2 of
9 ! the License, or (at your option) any later version.
10 
11 ! This program is distributed in the hope that it will be useful,
12 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ! GNU General Public License for more details.
15 
16 ! You should have received a copy of the GNU General Public License
17 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
18 #include "config.h"
19 
31 
85 MODULE vol7d_class
86 USE kinds
90 USE log4fortran
91 USE err_handling
92 USE io_units
99 IMPLICIT NONE
100 
101 
102 INTEGER, PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
103  vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
104 
105 INTEGER, PARAMETER :: vol7d_ana_a=1
106 INTEGER, PARAMETER :: vol7d_var_a=2
107 INTEGER, PARAMETER :: vol7d_network_a=3
108 INTEGER, PARAMETER :: vol7d_attr_a=4
109 INTEGER, PARAMETER :: vol7d_ana_d=1
110 INTEGER, PARAMETER :: vol7d_time_d=2
111 INTEGER, PARAMETER :: vol7d_level_d=3
112 INTEGER, PARAMETER :: vol7d_timerange_d=4
113 INTEGER, PARAMETER :: vol7d_var_d=5
114 INTEGER, PARAMETER :: vol7d_network_d=6
115 INTEGER, PARAMETER :: vol7d_attr_d=7
116 INTEGER, PARAMETER :: vol7d_cdatalen=32
117 
118 TYPE vol7d_varmap
119  INTEGER :: r, d, i, b, c
120 END TYPE vol7d_varmap
121 
124 TYPE vol7d
126  TYPE(vol7d_ana),POINTER :: ana(:)
127 
128  TYPE(datetime),POINTER :: time(:)
129 
130  TYPE(vol7d_level),POINTER :: level(:)
131 
132  TYPE(vol7d_timerange),POINTER :: timerange(:)
133 
134  TYPE(vol7d_network),POINTER :: network(:)
135 
136  TYPE(vol7d_varvect) :: anavar
137 
138  TYPE(vol7d_varvect) :: anaattr
139 
140  TYPE(vol7d_varvect) :: anavarattr
141 
142  TYPE(vol7d_varvect) :: dativar
143 
144  TYPE(vol7d_varvect) :: datiattr
145 
146  TYPE(vol7d_varvect) :: dativarattr
147 
149  REAL,POINTER :: volanar(:,:,:)
150 
151  DOUBLE PRECISION,POINTER :: volanad(:,:,:)
152 
153  INTEGER,POINTER :: volanai(:,:,:)
154 
155  INTEGER(kind=int_b),POINTER :: volanab(:,:,:)
156 
157  CHARACTER(len=vol7d_cdatalen),POINTER :: volanac(:,:,:)
158 
160  REAL,POINTER :: volanaattrr(:,:,:,:)
161 
162  DOUBLE PRECISION,POINTER :: volanaattrd(:,:,:,:)
163 
164  INTEGER,POINTER :: volanaattri(:,:,:,:)
165 
166  INTEGER(kind=int_b),POINTER :: volanaattrb(:,:,:,:)
167 
168  CHARACTER(len=vol7d_cdatalen),POINTER :: volanaattrc(:,:,:,:)
169 
171  REAL,POINTER :: voldatir(:,:,:,:,:,:) ! sono i dati
172 
173  DOUBLE PRECISION,POINTER :: voldatid(:,:,:,:,:,:)
174 
175  INTEGER,POINTER :: voldatii(:,:,:,:,:,:)
176 
177  INTEGER(kind=int_b),POINTER :: voldatib(:,:,:,:,:,:)
178 
179  CHARACTER(len=vol7d_cdatalen),POINTER :: voldatic(:,:,:,:,:,:)
180 
182  REAL,POINTER :: voldatiattrr(:,:,:,:,:,:,:)
183 
184  DOUBLE PRECISION,POINTER :: voldatiattrd(:,:,:,:,:,:,:)
185 
186  INTEGER,POINTER :: voldatiattri(:,:,:,:,:,:,:)
187 
188  INTEGER(kind=int_b),POINTER :: voldatiattrb(:,:,:,:,:,:,:)
189 
190  CHARACTER(len=vol7d_cdatalen),POINTER :: voldatiattrc(:,:,:,:,:,:,:)
191 
193  integer :: time_definition
194 
195 END TYPE vol7d
196 
200 INTERFACE init
201  MODULE PROCEDURE vol7d_init
202 END INTERFACE
203 
205 INTERFACE delete
206  MODULE PROCEDURE vol7d_delete
207 END INTERFACE
208 
210 INTERFACE export
211  MODULE PROCEDURE vol7d_write_on_file
212 END INTERFACE
213 
215 INTERFACE import
216  MODULE PROCEDURE vol7d_read_from_file
217 END INTERFACE
218 
220 INTERFACE display
221  MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
222 END INTERFACE
223 
225 INTERFACE to_char
226  MODULE PROCEDURE to_char_dat
227 END INTERFACE
228 
230 INTERFACE doubledat
231  MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
232 END INTERFACE
233 
235 INTERFACE realdat
236  MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
237 END INTERFACE
238 
240 INTERFACE integerdat
241  MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
242 END INTERFACE
243 
245 INTERFACE copy
246  MODULE PROCEDURE vol7d_copy
247 END INTERFACE
248 
250 INTERFACE c_e
251  MODULE PROCEDURE vol7d_c_e
252 END INTERFACE
253 
257 INTERFACE check
258  MODULE PROCEDURE vol7d_check
259 END INTERFACE
260 
274 INTERFACE rounding
275  MODULE PROCEDURE v7d_rounding
276 END INTERFACE
277 
278 !!$INTERFACE get_volana
279 !!$ MODULE PROCEDURE vol7d_get_volanar, vol7d_get_volanad, vol7d_get_volanai, &
280 !!$ vol7d_get_volanab, vol7d_get_volanac
281 !!$END INTERFACE
282 !!$
283 !!$INTERFACE get_voldati
284 !!$ MODULE PROCEDURE vol7d_get_voldatir, vol7d_get_voldatid, vol7d_get_voldatii, &
285 !!$ vol7d_get_voldatib, vol7d_get_voldatic
286 !!$END INTERFACE
287 !!$
288 !!$INTERFACE get_volanaattr
289 !!$ MODULE PROCEDURE vol7d_get_volanaattrr, vol7d_get_volanaattrd, &
290 !!$ vol7d_get_volanaattri, vol7d_get_volanaattrb, vol7d_get_volanaattrc
291 !!$END INTERFACE
292 !!$
293 !!$INTERFACE get_voldatiattr
294 !!$ MODULE PROCEDURE vol7d_get_voldatiattrr, vol7d_get_voldatiattrd, &
295 !!$ vol7d_get_voldatiattri, vol7d_get_voldatiattrb, vol7d_get_voldatiattrc
296 !!$END INTERFACE
297 
298 PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
299  vol7d_get_volc, &
300  volptr1dr, volptr2dr, volptr3dr, volptr4dr, volptr5dr, volptr6dr, volptr7dr, &
301  volptr1dd, volptr2dd, volptr3dd, volptr4dd, volptr5dd, volptr6dd, volptr7dd, &
302  volptr1di, volptr2di, volptr3di, volptr4di, volptr5di, volptr6di, volptr7di, &
303  volptr1db, volptr2db, volptr3db, volptr4db, volptr5db, volptr6db, volptr7db, &
304  volptr1dc, volptr2dc, volptr3dc, volptr4dc, volptr5dc, volptr6dc, volptr7dc, &
305  vol7d_nullifyr, vol7d_nullifyd, vol7d_nullifyi, vol7d_nullifyb, vol7d_nullifyc, &
306  vol7d_init, vol7d_delete, vol7d_write_on_file, vol7d_read_from_file, &
307  vol7d_check_alloc_ana, vol7d_force_alloc_ana, &
308  vol7d_check_alloc_dati, vol7d_force_alloc_dati, vol7d_force_alloc, &
309  vol7d_display, dat_display, dat_vect_display, &
310  to_char_dat, vol7d_check
311 
312 PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
313 
314 PRIVATE vol7d_c_e
315 
316 CONTAINS
317 
323 SUBROUTINE vol7d_init(this,time_definition)
324 TYPE(vol7d),intent(out) :: this
325 integer,INTENT(IN),OPTIONAL :: time_definition
327 CALL init(this%anavar)
328 CALL init(this%anaattr)
329 CALL init(this%anavarattr)
330 CALL init(this%dativar)
331 CALL init(this%datiattr)
332 CALL init(this%dativarattr)
333 
334 nullify(this%ana, this%time, this%level, this%timerange, this%network)
335 
336 nullify(this%volanar, this%volanaattrr, this%voldatir, this%voldatiattrr)
337 nullify(this%volanad, this%volanaattrd, this%voldatid, this%voldatiattrd)
338 nullify(this%volanai, this%volanaattri, this%voldatii, this%voldatiattri)
339 nullify(this%volanab, this%volanaattrb, this%voldatib, this%voldatiattrb)
340 nullify(this%volanac, this%volanaattrc, this%voldatic, this%voldatiattrc)
341 
342 if(present(time_definition)) then
343  this%time_definition=time_definition
344 else
345  this%time_definition=1 !default to validity time
346 end if
348 END SUBROUTINE vol7d_init
350 
354 ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
355 TYPE(vol7d),intent(inout) :: this
356 LOGICAL, INTENT(in), OPTIONAL :: dataonly
357 
359 IF (.NOT. optio_log(dataonly)) THEN
360  IF (ASSOCIATED(this%volanar)) DEALLOCATE(this%volanar)
361  IF (ASSOCIATED(this%volanad)) DEALLOCATE(this%volanad)
362  IF (ASSOCIATED(this%volanai)) DEALLOCATE(this%volanai)
363  IF (ASSOCIATED(this%volanab)) DEALLOCATE(this%volanab)
364  IF (ASSOCIATED(this%volanac)) DEALLOCATE(this%volanac)
365  IF (ASSOCIATED(this%volanaattrr)) DEALLOCATE(this%volanaattrr)
366  IF (ASSOCIATED(this%volanaattrd)) DEALLOCATE(this%volanaattrd)
367  IF (ASSOCIATED(this%volanaattri)) DEALLOCATE(this%volanaattri)
368  IF (ASSOCIATED(this%volanaattrb)) DEALLOCATE(this%volanaattrb)
369  IF (ASSOCIATED(this%volanaattrc)) DEALLOCATE(this%volanaattrc)
370 ENDIF
371 IF (ASSOCIATED(this%voldatir)) DEALLOCATE(this%voldatir)
372 IF (ASSOCIATED(this%voldatid)) DEALLOCATE(this%voldatid)
373 IF (ASSOCIATED(this%voldatii)) DEALLOCATE(this%voldatii)
374 IF (ASSOCIATED(this%voldatib)) DEALLOCATE(this%voldatib)
375 IF (ASSOCIATED(this%voldatic)) DEALLOCATE(this%voldatic)
376 IF (ASSOCIATED(this%voldatiattrr)) DEALLOCATE(this%voldatiattrr)
377 IF (ASSOCIATED(this%voldatiattrd)) DEALLOCATE(this%voldatiattrd)
378 IF (ASSOCIATED(this%voldatiattri)) DEALLOCATE(this%voldatiattri)
379 IF (ASSOCIATED(this%voldatiattrb)) DEALLOCATE(this%voldatiattrb)
380 IF (ASSOCIATED(this%voldatiattrc)) DEALLOCATE(this%voldatiattrc)
381 
382 IF (.NOT. optio_log(dataonly)) THEN
383  IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
384  IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
385 ENDIF
386 IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
387 IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
388 IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
389 
390 IF (.NOT. optio_log(dataonly)) THEN
391  CALL delete(this%anavar)
392  CALL delete(this%anaattr)
393  CALL delete(this%anavarattr)
394 ENDIF
395 CALL delete(this%dativar)
396 CALL delete(this%datiattr)
397 CALL delete(this%dativarattr)
398 
399 END SUBROUTINE vol7d_delete
400 
401 
402 
403 integer function vol7d_check(this)
404 TYPE(vol7d),intent(in) :: this
405 integer :: i,j,k,l,m,n
406 
407 vol7d_check=0
408 
409 if (associated(this%voldatii)) then
410 do i = 1,size(this%voldatii,1)
411  do j = 1,size(this%voldatii,2)
412  do k = 1,size(this%voldatii,3)
413  do l = 1,size(this%voldatii,4)
414  do m = 1,size(this%voldatii,5)
415  do n = 1,size(this%voldatii,6)
416  if (this%voldatii(i,j,k,l,m,n) /= this%voldatii(i,j,k,l,m,n) ) then
417  CALL l4f_log(l4f_warn,"check: abnormal value at voldatii("&
418  //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
419  vol7d_check=1
420  end if
421  end do
422  end do
423  end do
424  end do
425  end do
426 end do
427 end if
428 
430 if (associated(this%voldatir)) then
431 do i = 1,size(this%voldatir,1)
432  do j = 1,size(this%voldatir,2)
433  do k = 1,size(this%voldatir,3)
434  do l = 1,size(this%voldatir,4)
435  do m = 1,size(this%voldatir,5)
436  do n = 1,size(this%voldatir,6)
437  if (this%voldatir(i,j,k,l,m,n) /= this%voldatir(i,j,k,l,m,n) ) then
438  CALL l4f_log(l4f_warn,"check: abnormal value at voldatir("&
439  //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
440  vol7d_check=2
441  end if
442  end do
443  end do
444  end do
445  end do
446  end do
447 end do
448 end if
449 
450 if (associated(this%voldatid)) then
451 do i = 1,size(this%voldatid,1)
452  do j = 1,size(this%voldatid,2)
453  do k = 1,size(this%voldatid,3)
454  do l = 1,size(this%voldatid,4)
455  do m = 1,size(this%voldatid,5)
456  do n = 1,size(this%voldatid,6)
457  if (this%voldatid(i,j,k,l,m,n) /= this%voldatid(i,j,k,l,m,n) ) then
458  CALL l4f_log(l4f_warn,"check: abnormal value at voldatid("&
459  //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
460  vol7d_check=3
461  end if
462  end do
463  end do
464  end do
465  end do
466  end do
467 end do
468 end if
469 
470 if (associated(this%voldatib)) then
471 do i = 1,size(this%voldatib,1)
472  do j = 1,size(this%voldatib,2)
473  do k = 1,size(this%voldatib,3)
474  do l = 1,size(this%voldatib,4)
475  do m = 1,size(this%voldatib,5)
476  do n = 1,size(this%voldatib,6)
477  if (this%voldatib(i,j,k,l,m,n) /= this%voldatib(i,j,k,l,m,n) ) then
478  CALL l4f_log(l4f_warn,"check: abnormal value at voldatib("&
479  //t2c(i)//","//t2c(j)//","//t2c(k)//","//t2c(l)//","//t2c(m)//","//t2c(n)//",)")
480  vol7d_check=4
481  end if
482  end do
483  end do
484  end do
485  end do
486  end do
487 end do
488 end if
489 
490 end function vol7d_check
491 
492 
493 
494 !TODO da completare ! aborta se i volumi sono allocati a dimensione 0
496 SUBROUTINE vol7d_display(this)
497 TYPE(vol7d),intent(in) :: this
498 integer :: i
499 
500 REAL :: rdat
501 DOUBLE PRECISION :: ddat
502 INTEGER :: idat
503 INTEGER(kind=int_b) :: bdat
504 CHARACTER(len=vol7d_cdatalen) :: cdat
505 
506 
507 print*,"<<<<<<<<<<<<<<<<<<< vol7d object >>>>>>>>>>>>>>>>>>>>"
508 if (this%time_definition == 0) then
509  print*,"TIME DEFINITION: time is reference time"
510 else if (this%time_definition == 1) then
511  print*,"TIME DEFINITION: time is validity time"
512 else
513  print*,"Time definition have a wrong walue:", this%time_definition
514 end if
515 
516 IF (ASSOCIATED(this%network))then
517  print*,"---- network vector ----"
518  print*,"elements=",size(this%network)
519  do i=1, size(this%network)
520  call display(this%network(i))
521  end do
522 end IF
523 
524 IF (ASSOCIATED(this%ana))then
525  print*,"---- ana vector ----"
526  print*,"elements=",size(this%ana)
527  do i=1, size(this%ana)
528  call display(this%ana(i))
529  end do
530 end IF
531 
532 IF (ASSOCIATED(this%time))then
533  print*,"---- time vector ----"
534  print*,"elements=",size(this%time)
535  do i=1, size(this%time)
536  call display(this%time(i))
537  end do
538 end if
539 
540 IF (ASSOCIATED(this%level)) then
541  print*,"---- level vector ----"
542  print*,"elements=",size(this%level)
543  do i =1,size(this%level)
544  call display(this%level(i))
545  end do
546 end if
547 
548 IF (ASSOCIATED(this%timerange))then
549  print*,"---- timerange vector ----"
550  print*,"elements=",size(this%timerange)
551  do i =1,size(this%timerange)
552  call display(this%timerange(i))
553  end do
554 end if
555 
556 
557 print*,"---- ana vector ----"
558 print*,""
559 print*,"->>>>>>>>> anavar -"
560 call display(this%anavar)
561 print*,""
562 print*,"->>>>>>>>> anaattr -"
563 call display(this%anaattr)
564 print*,""
565 print*,"->>>>>>>>> anavarattr -"
566 call display(this%anavarattr)
567 
568 print*,"-- ana data section (first point) --"
569 
570 idat=imiss
571 rdat=rmiss
572 ddat=dmiss
573 bdat=ibmiss
574 cdat=cmiss
575 
576 !ntime = MIN(SIZE(this%time),nprint)
577 !ntimerange = MIN(SIZE(this%timerange),nprint)
578 !nlevel = MIN(SIZE(this%level),nprint)
579 !nnetwork = MIN(SIZE(this%network),nprint)
580 !nana = MIN(SIZE(this%ana),nprint)
581 
582 IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0) THEN
583 if (associated(this%volanai)) then
584  do i=1,size(this%anavar%i)
585  idat=this%volanai(1,i,1)
586  if (associated(this%anavar%i)) call display(this%anavar%i(i),idat,rdat,ddat,bdat,cdat)
587  end do
588 end if
589 idat=imiss
590 
591 if (associated(this%volanar)) then
592  do i=1,size(this%anavar%r)
593  rdat=this%volanar(1,i,1)
594  if (associated(this%anavar%r)) call display(this%anavar%r(i),idat,rdat,ddat,bdat,cdat)
595  end do
596 end if
597 rdat=rmiss
598 
599 if (associated(this%volanad)) then
600  do i=1,size(this%anavar%d)
601  ddat=this%volanad(1,i,1)
602  if (associated(this%anavar%d)) call display(this%anavar%d(i),idat,rdat,ddat,bdat,cdat)
603  end do
604 end if
605 ddat=dmiss
606 
607 if (associated(this%volanab)) then
608  do i=1,size(this%anavar%b)
609  bdat=this%volanab(1,i,1)
610  if (associated(this%anavar%b)) call display(this%anavar%b(i),idat,rdat,ddat,bdat,cdat)
611  end do
612 end if
613 bdat=ibmiss
614 
615 if (associated(this%volanac)) then
616  do i=1,size(this%anavar%c)
617  cdat=this%volanac(1,i,1)
618  if (associated(this%anavar%c)) call display(this%anavar%c(i),idat,rdat,ddat,bdat,cdat)
619  end do
620 end if
621 cdat=cmiss
622 ENDIF
623 
624 print*,"---- data vector ----"
625 print*,""
626 print*,"->>>>>>>>> dativar -"
627 call display(this%dativar)
628 print*,""
629 print*,"->>>>>>>>> datiattr -"
630 call display(this%datiattr)
631 print*,""
632 print*,"->>>>>>>>> dativarattr -"
633 call display(this%dativarattr)
634 
635 print*,"-- data data section (first point) --"
636 
637 idat=imiss
638 rdat=rmiss
639 ddat=dmiss
640 bdat=ibmiss
641 cdat=cmiss
642 
643 IF (SIZE(this%ana) > 0 .AND. SIZE(this%network) > 0 .AND. size(this%time) > 0 &
644  .AND. size(this%level) > 0 .AND. size(this%timerange) > 0) THEN
645 if (associated(this%voldatii)) then
646  do i=1,size(this%dativar%i)
647  idat=this%voldatii(1,1,1,1,i,1)
648  if (associated(this%dativar%i)) call display(this%dativar%i(i),idat,rdat,ddat,bdat,cdat)
649  end do
650 end if
651 idat=imiss
652 
653 if (associated(this%voldatir)) then
654  do i=1,size(this%dativar%r)
655  rdat=this%voldatir(1,1,1,1,i,1)
656  if (associated(this%dativar%r)) call display(this%dativar%r(i),idat,rdat,ddat,bdat,cdat)
657  end do
658 end if
659 rdat=rmiss
660 
661 if (associated(this%voldatid)) then
662  do i=1,size(this%dativar%d)
663  ddat=this%voldatid(1,1,1,1,i,1)
664  if (associated(this%dativar%d)) call display(this%dativar%d(i),idat,rdat,ddat,bdat,cdat)
665  end do
666 end if
667 ddat=dmiss
668 
669 if (associated(this%voldatib)) then
670  do i=1,size(this%dativar%b)
671  bdat=this%voldatib(1,1,1,1,i,1)
672  if (associated(this%dativar%b)) call display(this%dativar%b(i),idat,rdat,ddat,bdat,cdat)
673  end do
674 end if
675 bdat=ibmiss
676 
677 if (associated(this%voldatic)) then
678  do i=1,size(this%dativar%c)
679  cdat=this%voldatic(1,1,1,1,i,1)
680  if (associated(this%dativar%c)) call display(this%dativar%c(i),idat,rdat,ddat,bdat,cdat)
681  end do
682 end if
683 cdat=cmiss
684 ENDIF
685 
686 print*,"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
687 
688 END SUBROUTINE vol7d_display
689 
692 SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
693 TYPE(vol7d_var),intent(in) :: this
695 REAL :: rdat
696 
697 DOUBLE PRECISION :: ddat
698 
699 INTEGER :: idat
700 
701 INTEGER(kind=int_b) :: bdat
702 
703 CHARACTER(len=*) :: cdat
704 
705 print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
706 
707 end SUBROUTINE dat_display
708 
710 SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
711 
712 TYPE(vol7d_var),intent(in) :: this(:)
714 REAL :: rdat(:)
715 
716 DOUBLE PRECISION :: ddat(:)
717 
718 INTEGER :: idat(:)
719 
720 INTEGER(kind=int_b) :: bdat(:)
721 
722 CHARACTER(len=*):: cdat(:)
723 
724 integer :: i
725 
726 do i =1,size(this)
727  call display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
728 end do
729 
730 end SUBROUTINE dat_vect_display
731 
732 
733 FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
734 #ifdef HAVE_DBALLE
735 #ifdef HAVE_DBALLEF_MOD
736 USE dballef
737 #else
738 include 'dballeff.h'
739 #endif
740 #endif
741 TYPE(vol7d_var),INTENT(in) :: this
742 
743 REAL :: rdat
744 
745 DOUBLE PRECISION :: ddat
746 
747 INTEGER :: idat
748 
749 INTEGER(kind=int_b) :: bdat
750 
751 CHARACTER(len=*) :: cdat
752 CHARACTER(len=80) :: to_char_dat
753 
754 CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
755 
756 
757 #ifdef HAVE_DBALLE
758 INTEGER :: handle, ier
759 
760 handle = 0
761 to_char_dat="VALUE: "
762 
763 if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
764 if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
765 if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
766 if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
767 
768 if ( c_e(cdat))then
769  ier = idba_messaggi(handle,"/dev/null", "w", "BUFR")
770  ier = idba_spiegab(handle,this%btable,cdat,to_char_tmp)
771  ier = idba_fatto(handle)
772  to_char_dat=trim(to_char_dat)//" ;char> "//trim(to_char_tmp)
773 endif
774 
775 #else
776 
777 to_char_dat="VALUE: "
778 if (c_e(idat)) to_char_dat=trim(to_char_dat)//" ;int> "//trim(to_char(idat))
779 if (c_e(rdat)) to_char_dat=trim(to_char_dat)//" ;real> "//trim(to_char(rdat))
780 if (c_e(ddat)) to_char_dat=trim(to_char_dat)//" ;double> "//trim(to_char(ddat))
781 if (c_e(bdat)) to_char_dat=trim(to_char_dat)//" ;byte> "//trim(to_char(bdat))
782 if (c_e(cdat)) to_char_dat=trim(to_char_dat)//" ;char> "//trim(cdat)
783 
784 #endif
785 
786 END FUNCTION to_char_dat
787 
788 
791 FUNCTION vol7d_c_e(this) RESULT(c_e)
792 TYPE(vol7d), INTENT(in) :: this
793 
794 LOGICAL :: c_e
795 
796 c_e = ASSOCIATED(this%ana) .OR. ASSOCIATED(this%time) .OR. &
797  ASSOCIATED(this%level) .OR. ASSOCIATED(this%timerange) .OR. &
798  ASSOCIATED(this%network) .OR. &
799  ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
800  ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
801  ASSOCIATED(this%anavar%c) .OR. &
802  ASSOCIATED(this%anaattr%r) .OR. ASSOCIATED(this%anaattr%d) .OR. &
803  ASSOCIATED(this%anaattr%i) .OR. ASSOCIATED(this%anaattr%b) .OR. &
804  ASSOCIATED(this%anaattr%c) .OR. &
805  ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
806  ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
807  ASSOCIATED(this%dativar%c) .OR. &
808  ASSOCIATED(this%datiattr%r) .OR. ASSOCIATED(this%datiattr%d) .OR. &
809  ASSOCIATED(this%datiattr%i) .OR. ASSOCIATED(this%datiattr%b) .OR. &
810  ASSOCIATED(this%datiattr%c)
811 
812 END FUNCTION vol7d_c_e
813 
814 
853 SUBROUTINE vol7d_alloc(this, nana, ntime, nlevel, ntimerange, nnetwork, &
854  nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
855  nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
856  nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
857  ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
858  ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
859  ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc, &
860  ini)
861 TYPE(vol7d),INTENT(inout) :: this
862 INTEGER,INTENT(in),OPTIONAL :: nana
863 INTEGER,INTENT(in),OPTIONAL :: ntime
864 INTEGER,INTENT(in),OPTIONAL :: nlevel
865 INTEGER,INTENT(in),OPTIONAL :: ntimerange
866 INTEGER,INTENT(in),OPTIONAL :: nnetwork
868 INTEGER,INTENT(in),OPTIONAL :: &
869  nanavarr, nanavard, nanavari, nanavarb, nanavarc, &
870  nanaattrr, nanaattrd, nanaattri, nanaattrb, nanaattrc, &
871  nanavarattrr, nanavarattrd, nanavarattri, nanavarattrb, nanavarattrc, &
872  ndativarr, ndativard, ndativari, ndativarb, ndativarc, &
873  ndatiattrr, ndatiattrd, ndatiattri, ndatiattrb, ndatiattrc, &
874  ndativarattrr, ndativarattrd, ndativarattri, ndativarattrb, ndativarattrc
875 LOGICAL,INTENT(in),OPTIONAL :: ini
876 
877 INTEGER :: i
878 LOGICAL :: linit
879 
880 IF (present(ini)) THEN
881  linit = ini
882 ELSE
883  linit = .false.
884 ENDIF
885 
886 ! Dimensioni principali
887 IF (present(nana)) THEN
888  IF (nana >= 0) THEN
889  IF (ASSOCIATED(this%ana)) DEALLOCATE(this%ana)
890  ALLOCATE(this%ana(nana))
891  IF (linit) THEN
892  DO i = 1, nana
893  CALL init(this%ana(i))
894  ENDDO
895  ENDIF
896  ENDIF
897 ENDIF
898 IF (present(ntime)) THEN
899  IF (ntime >= 0) THEN
900  IF (ASSOCIATED(this%time)) DEALLOCATE(this%time)
901  ALLOCATE(this%time(ntime))
902  IF (linit) THEN
903  DO i = 1, ntime
904  CALL init(this%time(i))
905  ENDDO
906  ENDIF
907  ENDIF
908 ENDIF
909 IF (present(nlevel)) THEN
910  IF (nlevel >= 0) THEN
911  IF (ASSOCIATED(this%level)) DEALLOCATE(this%level)
912  ALLOCATE(this%level(nlevel))
913  IF (linit) THEN
914  DO i = 1, nlevel
915  CALL init(this%level(i))
916  ENDDO
917  ENDIF
918  ENDIF
919 ENDIF
920 IF (present(ntimerange)) THEN
921  IF (ntimerange >= 0) THEN
922  IF (ASSOCIATED(this%timerange)) DEALLOCATE(this%timerange)
923  ALLOCATE(this%timerange(ntimerange))
924  IF (linit) THEN
925  DO i = 1, ntimerange
926  CALL init(this%timerange(i))
927  ENDDO
928  ENDIF
929  ENDIF
930 ENDIF
931 IF (present(nnetwork)) THEN
932  IF (nnetwork >= 0) THEN
933  IF (ASSOCIATED(this%network)) DEALLOCATE(this%network)
934  ALLOCATE(this%network(nnetwork))
935  IF (linit) THEN
936  DO i = 1, nnetwork
937  CALL init(this%network(i))
938  ENDDO
939  ENDIF
940  ENDIF
941 ENDIF
942 ! Dimensioni dei tipi delle variabili
943 CALL vol7d_varvect_alloc(this%anavar, nanavarr, nanavard, &
944  nanavari, nanavarb, nanavarc, ini)
945 CALL vol7d_varvect_alloc(this%anaattr, nanaattrr, nanaattrd, &
946  nanaattri, nanaattrb, nanaattrc, ini)
947 CALL vol7d_varvect_alloc(this%anavarattr, nanavarattrr, nanavarattrd, &
948  nanavarattri, nanavarattrb, nanavarattrc, ini)
949 CALL vol7d_varvect_alloc(this%dativar, ndativarr, ndativard, &
950  ndativari, ndativarb, ndativarc, ini)
951 CALL vol7d_varvect_alloc(this%datiattr, ndatiattrr, ndatiattrd, &
952  ndatiattri, ndatiattrb, ndatiattrc, ini)
953 CALL vol7d_varvect_alloc(this%dativarattr, ndativarattrr, ndativarattrd, &
954  ndativarattri, ndativarattrb, ndativarattrc, ini)
955 
956 END SUBROUTINE vol7d_alloc
957 
958 
959 FUNCTION vol7d_check_alloc_ana(this)
960 TYPE(vol7d),INTENT(in) :: this
961 LOGICAL :: vol7d_check_alloc_ana
962 
963 vol7d_check_alloc_ana = ASSOCIATED(this%ana) .AND. ASSOCIATED(this%network)
964 
965 END FUNCTION vol7d_check_alloc_ana
966 
967 SUBROUTINE vol7d_force_alloc_ana(this, ini)
968 TYPE(vol7d),INTENT(inout) :: this
969 LOGICAL,INTENT(in),OPTIONAL :: ini
970 
971 ! Alloco i descrittori minimi per avere un volume di anagrafica
972 IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=1, ini=ini)
973 IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=1, ini=ini)
974 
975 END SUBROUTINE vol7d_force_alloc_ana
977 
978 FUNCTION vol7d_check_alloc_dati(this)
979 TYPE(vol7d),INTENT(in) :: this
980 LOGICAL :: vol7d_check_alloc_dati
981 
982 vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
983  ASSOCIATED(this%time) .AND. ASSOCIATED(this%level) .AND. &
984  ASSOCIATED(this%timerange)
985 
986 END FUNCTION vol7d_check_alloc_dati
987 
988 SUBROUTINE vol7d_force_alloc_dati(this, ini)
989 TYPE(vol7d),INTENT(inout) :: this
990 LOGICAL,INTENT(in),OPTIONAL :: ini
991 
992 ! Alloco i descrittori minimi per avere un volume di dati
993 CALL vol7d_force_alloc_ana(this, ini)
994 IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=1, ini=ini)
995 IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=1, ini=ini)
996 IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=1, ini=ini)
997 
998 END SUBROUTINE vol7d_force_alloc_dati
999 
1000 
1001 SUBROUTINE vol7d_force_alloc(this)
1002 TYPE(vol7d),INTENT(inout) :: this
1003 
1004 ! If anything really not allocated yet, allocate with size 0
1005 IF (.NOT. ASSOCIATED(this%ana)) CALL vol7d_alloc(this, nana=0)
1006 IF (.NOT. ASSOCIATED(this%network)) CALL vol7d_alloc(this, nnetwork=0)
1007 IF (.NOT. ASSOCIATED(this%time)) CALL vol7d_alloc(this, ntime=0)
1008 IF (.NOT. ASSOCIATED(this%level)) CALL vol7d_alloc(this, nlevel=0)
1009 IF (.NOT. ASSOCIATED(this%timerange)) CALL vol7d_alloc(this, ntimerange=0)
1010 
1011 END SUBROUTINE vol7d_force_alloc
1012 
1013 
1014 FUNCTION vol7d_check_vol(this)
1015 TYPE(vol7d),INTENT(in) :: this
1016 LOGICAL :: vol7d_check_vol
1017 
1018 vol7d_check_vol = c_e(this)
1019 
1020 ! Anagrafica
1021 IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
1022  vol7d_check_vol = .false.
1023 ENDIF
1024 
1025 IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
1026  vol7d_check_vol = .false.
1027 ENDIF
1028 
1029 IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
1030  vol7d_check_vol = .false.
1031 ENDIF
1032 
1033 IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
1034  vol7d_check_vol = .false.
1035 ENDIF
1036 
1037 IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
1038  vol7d_check_vol = .false.
1039 ENDIF
1040 IF (ASSOCIATED(this%anavar%r) .OR. ASSOCIATED(this%anavar%d) .OR. &
1041  ASSOCIATED(this%anavar%i) .OR. ASSOCIATED(this%anavar%b) .OR. &
1042  ASSOCIATED(this%anavar%c)) THEN
1043  vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_ana(this)
1044 ENDIF
1045 
1046 ! Attributi dell'anagrafica
1047 IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
1048  .NOT.ASSOCIATED(this%volanaattrr)) THEN
1049  vol7d_check_vol = .false.
1050 ENDIF
1051 
1052 IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
1053  .NOT.ASSOCIATED(this%volanaattrd)) THEN
1054  vol7d_check_vol = .false.
1055 ENDIF
1056 
1057 IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
1058  .NOT.ASSOCIATED(this%volanaattri)) THEN
1059  vol7d_check_vol = .false.
1060 ENDIF
1061 
1062 IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
1063  .NOT.ASSOCIATED(this%volanaattrb)) THEN
1064  vol7d_check_vol = .false.
1065 ENDIF
1066 
1067 IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
1068  .NOT.ASSOCIATED(this%volanaattrc)) THEN
1069  vol7d_check_vol = .false.
1070 ENDIF
1071 
1072 ! Dati
1073 IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
1074  vol7d_check_vol = .false.
1075 ENDIF
1076 
1077 IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
1078  vol7d_check_vol = .false.
1079 ENDIF
1080 
1081 IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
1082  vol7d_check_vol = .false.
1083 ENDIF
1084 
1085 IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
1086  vol7d_check_vol = .false.
1087 ENDIF
1088 
1089 IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
1090  vol7d_check_vol = .false.
1091 ENDIF
1092 
1093 ! Attributi dei dati
1094 IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
1095  .NOT.ASSOCIATED(this%voldatiattrr)) THEN
1096  vol7d_check_vol = .false.
1097 ENDIF
1098 
1099 IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
1100  .NOT.ASSOCIATED(this%voldatiattrd)) THEN
1101  vol7d_check_vol = .false.
1102 ENDIF
1103 
1104 IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
1105  .NOT.ASSOCIATED(this%voldatiattri)) THEN
1106  vol7d_check_vol = .false.
1107 ENDIF
1108 
1109 IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
1110  .NOT.ASSOCIATED(this%voldatiattrb)) THEN
1111  vol7d_check_vol = .false.
1112 ENDIF
1113 
1114 IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
1115  .NOT.ASSOCIATED(this%voldatiattrc)) THEN
1116  vol7d_check_vol = .false.
1117 ENDIF
1118 IF (ASSOCIATED(this%dativar%r) .OR. ASSOCIATED(this%dativar%d) .OR. &
1119  ASSOCIATED(this%dativar%i) .OR. ASSOCIATED(this%dativar%b) .OR. &
1120  ASSOCIATED(this%dativar%c)) THEN
1121  vol7d_check_vol = vol7d_check_vol .AND. vol7d_check_alloc_dati(this)
1122 ENDIF
1123 
1124 END FUNCTION vol7d_check_vol
1125 
1126 
1141 SUBROUTINE vol7d_alloc_vol(this, ini, inivol)
1142 TYPE(vol7d),INTENT(inout) :: this
1143 LOGICAL,INTENT(in),OPTIONAL :: ini
1144 LOGICAL,INTENT(in),OPTIONAL :: inivol
1145 
1146 LOGICAL :: linivol
1147 
1148 IF (present(inivol)) THEN
1149  linivol = inivol
1150 ELSE
1151  linivol = .true.
1152 ENDIF
1153 
1154 ! Anagrafica
1155 IF (ASSOCIATED(this%anavar%r) .AND. .NOT.ASSOCIATED(this%volanar)) THEN
1156  CALL vol7d_force_alloc_ana(this, ini)
1157  ALLOCATE(this%volanar(SIZE(this%ana), SIZE(this%anavar%r), SIZE(this%network)))
1158  IF (linivol) this%volanar(:,:,:) = rmiss
1159 ENDIF
1160 
1161 IF (ASSOCIATED(this%anavar%d) .AND. .NOT.ASSOCIATED(this%volanad)) THEN
1162  CALL vol7d_force_alloc_ana(this, ini)
1163  ALLOCATE(this%volanad(SIZE(this%ana), SIZE(this%anavar%d), SIZE(this%network)))
1164  IF (linivol) this%volanad(:,:,:) = rdmiss
1165 ENDIF
1166 
1167 IF (ASSOCIATED(this%anavar%i) .AND. .NOT.ASSOCIATED(this%volanai)) THEN
1168  CALL vol7d_force_alloc_ana(this, ini)
1169  ALLOCATE(this%volanai(SIZE(this%ana), SIZE(this%anavar%i), SIZE(this%network)))
1170  IF (linivol) this%volanai(:,:,:) = imiss
1171 ENDIF
1172 
1173 IF (ASSOCIATED(this%anavar%b) .AND. .NOT.ASSOCIATED(this%volanab)) THEN
1174  CALL vol7d_force_alloc_ana(this, ini)
1175  ALLOCATE(this%volanab(SIZE(this%ana), SIZE(this%anavar%b), SIZE(this%network)))
1176  IF (linivol) this%volanab(:,:,:) = ibmiss
1177 ENDIF
1178 
1179 IF (ASSOCIATED(this%anavar%c) .AND. .NOT.ASSOCIATED(this%volanac)) THEN
1180  CALL vol7d_force_alloc_ana(this, ini)
1181  ALLOCATE(this%volanac(SIZE(this%ana), SIZE(this%anavar%c), SIZE(this%network)))
1182  IF (linivol) this%volanac(:,:,:) = cmiss
1183 ENDIF
1184 
1185 ! Attributi dell'anagrafica
1186 IF (ASSOCIATED(this%anaattr%r) .AND. ASSOCIATED(this%anavarattr%r) .AND. &
1187  .NOT.ASSOCIATED(this%volanaattrr)) THEN
1188  CALL vol7d_force_alloc_ana(this, ini)
1189  ALLOCATE(this%volanaattrr(SIZE(this%ana), SIZE(this%anavarattr%r), &
1190  SIZE(this%network), SIZE(this%anaattr%r)))
1191  IF (linivol) this%volanaattrr(:,:,:,:) = rmiss
1192 ENDIF
1193 
1194 IF (ASSOCIATED(this%anaattr%d) .AND. ASSOCIATED(this%anavarattr%d) .AND. &
1195  .NOT.ASSOCIATED(this%volanaattrd)) THEN
1196  CALL vol7d_force_alloc_ana(this, ini)
1197  ALLOCATE(this%volanaattrd(SIZE(this%ana), SIZE(this%anavarattr%d), &
1198  SIZE(this%network), SIZE(this%anaattr%d)))
1199  IF (linivol) this%volanaattrd(:,:,:,:) = rdmiss
1200 ENDIF
1201 
1202 IF (ASSOCIATED(this%anaattr%i) .AND. ASSOCIATED(this%anavarattr%i) .AND. &
1203  .NOT.ASSOCIATED(this%volanaattri)) THEN
1204  CALL vol7d_force_alloc_ana(this, ini)
1205  ALLOCATE(this%volanaattri(SIZE(this%ana), SIZE(this%anavarattr%i), &
1206  SIZE(this%network), SIZE(this%anaattr%i)))
1207  IF (linivol) this%volanaattri(:,:,:,:) = imiss
1208 ENDIF
1209 
1210 IF (ASSOCIATED(this%anaattr%b) .AND. ASSOCIATED(this%anavarattr%b) .AND. &
1211  .NOT.ASSOCIATED(this%volanaattrb)) THEN
1212  CALL vol7d_force_alloc_ana(this, ini)
1213  ALLOCATE(this%volanaattrb(SIZE(this%ana), SIZE(this%anavarattr%b), &
1214  SIZE(this%network), SIZE(this%anaattr%b)))
1215  IF (linivol) this%volanaattrb(:,:,:,:) = ibmiss
1216 ENDIF
1217 
1218 IF (ASSOCIATED(this%anaattr%c) .AND. ASSOCIATED(this%anavarattr%c) .AND. &
1219  .NOT.ASSOCIATED(this%volanaattrc)) THEN
1220  CALL vol7d_force_alloc_ana(this, ini)
1221  ALLOCATE(this%volanaattrc(SIZE(this%ana), SIZE(this%anavarattr%c), &
1222  SIZE(this%network), SIZE(this%anaattr%c)))
1223  IF (linivol) this%volanaattrc(:,:,:,:) = cmiss
1224 ENDIF
1225 
1226 ! Dati
1227 IF (ASSOCIATED(this%dativar%r) .AND. .NOT.ASSOCIATED(this%voldatir)) THEN
1228  CALL vol7d_force_alloc_dati(this, ini)
1229  ALLOCATE(this%voldatir(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1230  SIZE(this%timerange), SIZE(this%dativar%r), SIZE(this%network)))
1231  IF (linivol) this%voldatir(:,:,:,:,:,:) = rmiss
1232 ENDIF
1233 
1234 IF (ASSOCIATED(this%dativar%d) .AND. .NOT.ASSOCIATED(this%voldatid)) THEN
1235  CALL vol7d_force_alloc_dati(this, ini)
1236  ALLOCATE(this%voldatid(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1237  SIZE(this%timerange), SIZE(this%dativar%d), SIZE(this%network)))
1238  IF (linivol) this%voldatid(:,:,:,:,:,:) = rdmiss
1239 ENDIF
1240 
1241 IF (ASSOCIATED(this%dativar%i) .AND. .NOT.ASSOCIATED(this%voldatii)) THEN
1242  CALL vol7d_force_alloc_dati(this, ini)
1243  ALLOCATE(this%voldatii(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1244  SIZE(this%timerange), SIZE(this%dativar%i), SIZE(this%network)))
1245  IF (linivol) this%voldatii(:,:,:,:,:,:) = imiss
1246 ENDIF
1247 
1248 IF (ASSOCIATED(this%dativar%b) .AND. .NOT.ASSOCIATED(this%voldatib)) THEN
1249  CALL vol7d_force_alloc_dati(this, ini)
1250  ALLOCATE(this%voldatib(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1251  SIZE(this%timerange), SIZE(this%dativar%b), SIZE(this%network)))
1252  IF (linivol) this%voldatib(:,:,:,:,:,:) = ibmiss
1253 ENDIF
1254 
1255 IF (ASSOCIATED(this%dativar%c) .AND. .NOT.ASSOCIATED(this%voldatic)) THEN
1256  CALL vol7d_force_alloc_dati(this, ini)
1257  ALLOCATE(this%voldatic(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1258  SIZE(this%timerange), SIZE(this%dativar%c), SIZE(this%network)))
1259  IF (linivol) this%voldatic(:,:,:,:,:,:) = cmiss
1260 ENDIF
1261 
1262 ! Attributi dei dati
1263 IF (ASSOCIATED(this%datiattr%r) .AND. ASSOCIATED(this%dativarattr%r) .AND. &
1264  .NOT.ASSOCIATED(this%voldatiattrr)) THEN
1265  CALL vol7d_force_alloc_dati(this, ini)
1266  ALLOCATE(this%voldatiattrr(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1267  SIZE(this%timerange), SIZE(this%dativarattr%r), SIZE(this%network), &
1268  SIZE(this%datiattr%r)))
1269  IF (linivol) this%voldatiattrr(:,:,:,:,:,:,:) = rmiss
1270 ENDIF
1271 
1272 IF (ASSOCIATED(this%datiattr%d) .AND. ASSOCIATED(this%dativarattr%d) .AND. &
1273  .NOT.ASSOCIATED(this%voldatiattrd)) THEN
1274  CALL vol7d_force_alloc_dati(this, ini)
1275  ALLOCATE(this%voldatiattrd(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1276  SIZE(this%timerange), SIZE(this%dativarattr%d), SIZE(this%network), &
1277  SIZE(this%datiattr%d)))
1278  IF (linivol) this%voldatiattrd(:,:,:,:,:,:,:) = rdmiss
1279 ENDIF
1280 
1281 IF (ASSOCIATED(this%datiattr%i) .AND. ASSOCIATED(this%dativarattr%i) .AND. &
1282  .NOT.ASSOCIATED(this%voldatiattri)) THEN
1283  CALL vol7d_force_alloc_dati(this, ini)
1284  ALLOCATE(this%voldatiattri(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1285  SIZE(this%timerange), SIZE(this%dativarattr%i), SIZE(this%network), &
1286  SIZE(this%datiattr%i)))
1287  IF (linivol) this%voldatiattri(:,:,:,:,:,:,:) = imiss
1288 ENDIF
1289 
1290 IF (ASSOCIATED(this%datiattr%b) .AND. ASSOCIATED(this%dativarattr%b) .AND. &
1291  .NOT.ASSOCIATED(this%voldatiattrb)) THEN
1292  CALL vol7d_force_alloc_dati(this, ini)
1293  ALLOCATE(this%voldatiattrb(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1294  SIZE(this%timerange), SIZE(this%dativarattr%b), SIZE(this%network), &
1295  SIZE(this%datiattr%b)))
1296  IF (linivol) this%voldatiattrb(:,:,:,:,:,:,:) = ibmiss
1297 ENDIF
1298 
1299 IF (ASSOCIATED(this%datiattr%c) .AND. ASSOCIATED(this%dativarattr%c) .AND. &
1300  .NOT.ASSOCIATED(this%voldatiattrc)) THEN
1301  CALL vol7d_force_alloc_dati(this, ini)
1302  ALLOCATE(this%voldatiattrc(SIZE(this%ana), SIZE(this%time), SIZE(this%level), &
1303  SIZE(this%timerange), SIZE(this%dativarattr%c), SIZE(this%network), &
1304  SIZE(this%datiattr%c)))
1305  IF (linivol) this%voldatiattrc(:,:,:,:,:,:,:) = cmiss
1306 ENDIF
1307 
1308 ! Catch-all method
1309 CALL vol7d_force_alloc(this)
1310 
1311 ! Creo gli indici var-attr
1312 
1313 #ifdef DEBUG
1314 CALL l4f_log(l4f_debug,"calling: vol7d_set_attr_ind")
1315 #endif
1316 
1317 CALL vol7d_set_attr_ind(this)
1318 
1319 
1320 
1321 END SUBROUTINE vol7d_alloc_vol
1322 
1323 
1330 SUBROUTINE vol7d_set_attr_ind(this)
1331 TYPE(vol7d),INTENT(inout) :: this
1332 
1333 INTEGER :: i
1334 
1335 ! real
1336 IF (ASSOCIATED(this%dativar%r)) THEN
1337  IF (ASSOCIATED(this%dativarattr%r)) THEN
1338  DO i = 1, SIZE(this%dativar%r)
1339  this%dativar%r(i)%r = &
1340  firsttrue(this%dativar%r(i)%btable == this%dativarattr%r(:)%btable)
1341  ENDDO
1342  ENDIF
1343 
1344  IF (ASSOCIATED(this%dativarattr%d)) THEN
1345  DO i = 1, SIZE(this%dativar%r)
1346  this%dativar%r(i)%d = &
1347  firsttrue(this%dativar%r(i)%btable == this%dativarattr%d(:)%btable)
1348  ENDDO
1349  ENDIF
1350 
1351  IF (ASSOCIATED(this%dativarattr%i)) THEN
1352  DO i = 1, SIZE(this%dativar%r)
1353  this%dativar%r(i)%i = &
1354  firsttrue(this%dativar%r(i)%btable == this%dativarattr%i(:)%btable)
1355  ENDDO
1356  ENDIF
1357 
1358  IF (ASSOCIATED(this%dativarattr%b)) THEN
1359  DO i = 1, SIZE(this%dativar%r)
1360  this%dativar%r(i)%b = &
1361  firsttrue(this%dativar%r(i)%btable == this%dativarattr%b(:)%btable)
1362  ENDDO
1363  ENDIF
1364 
1365  IF (ASSOCIATED(this%dativarattr%c)) THEN
1366  DO i = 1, SIZE(this%dativar%r)
1367  this%dativar%r(i)%c = &
1368  firsttrue(this%dativar%r(i)%btable == this%dativarattr%c(:)%btable)
1369  ENDDO
1370  ENDIF
1371 ENDIF
1372 ! double
1373 IF (ASSOCIATED(this%dativar%d)) THEN
1374  IF (ASSOCIATED(this%dativarattr%r)) THEN
1375  DO i = 1, SIZE(this%dativar%d)
1376  this%dativar%d(i)%r = &
1377  firsttrue(this%dativar%d(i)%btable == this%dativarattr%r(:)%btable)
1378  ENDDO
1379  ENDIF
1380 
1381  IF (ASSOCIATED(this%dativarattr%d)) THEN
1382  DO i = 1, SIZE(this%dativar%d)
1383  this%dativar%d(i)%d = &
1384  firsttrue(this%dativar%d(i)%btable == this%dativarattr%d(:)%btable)
1385  ENDDO
1386  ENDIF
1387 
1388  IF (ASSOCIATED(this%dativarattr%i)) THEN
1389  DO i = 1, SIZE(this%dativar%d)
1390  this%dativar%d(i)%i = &
1391  firsttrue(this%dativar%d(i)%btable == this%dativarattr%i(:)%btable)
1392  ENDDO
1393  ENDIF
1394 
1395  IF (ASSOCIATED(this%dativarattr%b)) THEN
1396  DO i = 1, SIZE(this%dativar%d)
1397  this%dativar%d(i)%b = &
1398  firsttrue(this%dativar%d(i)%btable == this%dativarattr%b(:)%btable)
1399  ENDDO
1400  ENDIF
1401 
1402  IF (ASSOCIATED(this%dativarattr%c)) THEN
1403  DO i = 1, SIZE(this%dativar%d)
1404  this%dativar%d(i)%c = &
1405  firsttrue(this%dativar%d(i)%btable == this%dativarattr%c(:)%btable)
1406  ENDDO
1407  ENDIF
1408 ENDIF
1409 ! integer
1410 IF (ASSOCIATED(this%dativar%i)) THEN
1411  IF (ASSOCIATED(this%dativarattr%r)) THEN
1412  DO i = 1, SIZE(this%dativar%i)
1413  this%dativar%i(i)%r = &
1414  firsttrue(this%dativar%i(i)%btable == this%dativarattr%r(:)%btable)
1415  ENDDO
1416  ENDIF
1417 
1418  IF (ASSOCIATED(this%dativarattr%d)) THEN
1419  DO i = 1, SIZE(this%dativar%i)
1420  this%dativar%i(i)%d = &
1421  firsttrue(this%dativar%i(i)%btable == this%dativarattr%d(:)%btable)
1422  ENDDO
1423  ENDIF
1424 
1425  IF (ASSOCIATED(this%dativarattr%i)) THEN
1426  DO i = 1, SIZE(this%dativar%i)
1427  this%dativar%i(i)%i = &
1428  firsttrue(this%dativar%i(i)%btable == this%dativarattr%i(:)%btable)
1429  ENDDO
1430  ENDIF
1431 
1432  IF (ASSOCIATED(this%dativarattr%b)) THEN
1433  DO i = 1, SIZE(this%dativar%i)
1434  this%dativar%i(i)%b = &
1435  firsttrue(this%dativar%i(i)%btable == this%dativarattr%b(:)%btable)
1436  ENDDO
1437  ENDIF
1438 
1439  IF (ASSOCIATED(this%dativarattr%c)) THEN
1440  DO i = 1, SIZE(this%dativar%i)
1441  this%dativar%i(i)%c = &
1442  firsttrue(this%dativar%i(i)%btable == this%dativarattr%c(:)%btable)
1443  ENDDO
1444  ENDIF
1445 ENDIF
1446 ! byte
1447 IF (ASSOCIATED(this%dativar%b)) THEN
1448  IF (ASSOCIATED(this%dativarattr%r)) THEN
1449  DO i = 1, SIZE(this%dativar%b)
1450  this%dativar%b(i)%r = &
1451  firsttrue(this%dativar%b(i)%btable == this%dativarattr%r(:)%btable)
1452  ENDDO
1453  ENDIF
1454 
1455  IF (ASSOCIATED(this%dativarattr%d)) THEN
1456  DO i = 1, SIZE(this%dativar%b)
1457  this%dativar%b(i)%d = &
1458  firsttrue(this%dativar%b(i)%btable == this%dativarattr%d(:)%btable)
1459  ENDDO
1460  ENDIF
1461 
1462  IF (ASSOCIATED(this%dativarattr%i)) THEN
1463  DO i = 1, SIZE(this%dativar%b)
1464  this%dativar%b(i)%i = &
1465  firsttrue(this%dativar%b(i)%btable == this%dativarattr%i(:)%btable)
1466  ENDDO
1467  ENDIF
1468 
1469  IF (ASSOCIATED(this%dativarattr%b)) THEN
1470  DO i = 1, SIZE(this%dativar%b)
1471  this%dativar%b(i)%b = &
1472  firsttrue(this%dativar%b(i)%btable == this%dativarattr%b(:)%btable)
1473  ENDDO
1474  ENDIF
1475 
1476  IF (ASSOCIATED(this%dativarattr%c)) THEN
1477  DO i = 1, SIZE(this%dativar%b)
1478  this%dativar%b(i)%c = &
1479  firsttrue(this%dativar%b(i)%btable == this%dativarattr%c(:)%btable)
1480  ENDDO
1481  ENDIF
1482 ENDIF
1483 ! character
1484 IF (ASSOCIATED(this%dativar%c)) THEN
1485  IF (ASSOCIATED(this%dativarattr%r)) THEN
1486  DO i = 1, SIZE(this%dativar%c)
1487  this%dativar%c(i)%r = &
1488  firsttrue(this%dativar%c(i)%btable == this%dativarattr%r(:)%btable)
1489  ENDDO
1490  ENDIF
1491 
1492  IF (ASSOCIATED(this%dativarattr%d)) THEN
1493  DO i = 1, SIZE(this%dativar%c)
1494  this%dativar%c(i)%d = &
1495  firsttrue(this%dativar%c(i)%btable == this%dativarattr%d(:)%btable)
1496  ENDDO
1497  ENDIF
1498 
1499  IF (ASSOCIATED(this%dativarattr%i)) THEN
1500  DO i = 1, SIZE(this%dativar%c)
1501  this%dativar%c(i)%i = &
1502  firsttrue(this%dativar%c(i)%btable == this%dativarattr%i(:)%btable)
1503  ENDDO
1504  ENDIF
1505 
1506  IF (ASSOCIATED(this%dativarattr%b)) THEN
1507  DO i = 1, SIZE(this%dativar%c)
1508  this%dativar%c(i)%b = &
1509  firsttrue(this%dativar%c(i)%btable == this%dativarattr%b(:)%btable)
1510  ENDDO
1511  ENDIF
1512 
1513  IF (ASSOCIATED(this%dativarattr%c)) THEN
1514  DO i = 1, SIZE(this%dativar%c)
1515  this%dativar%c(i)%c = &
1516  firsttrue(this%dativar%c(i)%btable == this%dativarattr%c(:)%btable)
1517  ENDDO
1518  ENDIF
1519 ENDIF
1520 
1521 END SUBROUTINE vol7d_set_attr_ind
1522 
1523 
1528 SUBROUTINE vol7d_merge(this, that, sort, bestdata, &
1529  ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
1530 TYPE(vol7d),INTENT(INOUT) :: this
1531 type(vol7d),INTENT(INOUT) :: that
1532 LOGICAL,INTENT(IN),OPTIONAL :: sort
1533 LOGICAL,INTENT(in),OPTIONAL :: bestdata
1534 LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple ! experimental, please do not use outside the library now
1535 
1536 TYPE(vol7d) :: v7d_clean
1537 
1538 
1539 IF (.NOT.c_e(this)) THEN ! speedup
1540  this = that
1541  CALL init(v7d_clean)
1542  that = v7d_clean ! destroy that without deallocating
1543 ELSE ! Append that to this and destroy that
1544  CALL vol7d_append(this, that, sort, bestdata, &
1545  ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
1546  CALL delete(that)
1547 ENDIF
1548 
1549 END SUBROUTINE vol7d_merge
1550 
1551 
1580 SUBROUTINE vol7d_append(this, that, sort, bestdata, &
1581  ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple)
1582 TYPE(vol7d),INTENT(INOUT) :: this
1583 type(vol7d),INTENT(IN) :: that
1584 LOGICAL,INTENT(IN),OPTIONAL :: sort
1585 ! experimental, please do not use outside the library now, they force the use
1586 ! of a simplified mapping algorithm which is valid only whene the dimension
1587 ! content is the same in both volumes , or when one of them is empty
1588 LOGICAL,INTENT(in),OPTIONAL :: bestdata
1589 LOGICAL,INTENT(IN),OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
1590 
1591 
1592 TYPE(vol7d) :: v7dtmp
1593 LOGICAL :: lsort, lbestdata
1594 INTEGER,POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
1595  remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
1596 
1597 IF (.NOT.c_e(that)) RETURN ! speedup, nothing to do
1598 IF (.NOT.vol7d_check_vol(that)) RETURN ! be safe
1599 IF (.NOT.c_e(this)) THEN ! this case is like a vol7d_copy, more efficient to copy?
1600  CALL vol7d_copy(that, this, sort=sort)
1601  RETURN
1602 ENDIF
1603 
1604 IF (this%time_definition /= that%time_definition) THEN
1605  CALL l4f_log(l4f_fatal, &
1606  'in vol7d_append, cannot append volumes with different &
1607  &time definition')
1608  CALL raise_fatal_error()
1609 ENDIF
1610 
1611 ! Completo l'allocazione per avere volumi a norma
1612 CALL vol7d_alloc_vol(this)
1613 
1614 CALL init(v7dtmp, time_definition=this%time_definition)
1615 CALL optio(sort, lsort)
1616 CALL optio(bestdata, lbestdata)
1617 
1618 ! Calcolo le mappature tra volumi vecchi e volume nuovo
1619 ! I puntatori remap* vengono tutti o allocati o nullificati
1620 IF (optio_log(ltimesimple)) THEN
1621  CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
1622  lsort, remapt1, remapt2)
1623 ELSE
1624  CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
1625  lsort, remapt1, remapt2)
1626 ENDIF
1627 IF (optio_log(ltimerangesimple)) THEN
1628  CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
1629  v7dtmp%timerange, lsort, remaptr1, remaptr2)
1630 ELSE
1631  CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
1632  v7dtmp%timerange, lsort, remaptr1, remaptr2)
1633 ENDIF
1634 IF (optio_log(llevelsimple)) THEN
1635  CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
1636  lsort, remapl1, remapl2)
1637 ELSE
1638  CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
1639  lsort, remapl1, remapl2)
1640 ENDIF
1641 IF (optio_log(lanasimple)) THEN
1642  CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
1643  .false., remapa1, remapa2)
1644 ELSE
1645  CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
1646  .false., remapa1, remapa2)
1647 ENDIF
1648 IF (optio_log(lnetworksimple)) THEN
1649  CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
1650  .false., remapn1, remapn2)
1651 ELSE
1652  CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
1653  .false., remapn1, remapn2)
1654 ENDIF
1655 
1656 ! Faccio la fusione fisica dei volumi
1657 CALL vol7d_merge_finalr(this, that, v7dtmp, &
1658  remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
1659  remaptr1, remaptr2, remapn1, remapn2, lbestdata)
1660 CALL vol7d_merge_finald(this, that, v7dtmp, &
1661  remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
1662  remaptr1, remaptr2, remapn1, remapn2, lbestdata)
1663 CALL vol7d_merge_finali(this, that, v7dtmp, &
1664  remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
1665  remaptr1, remaptr2, remapn1, remapn2, lbestdata)
1666 CALL vol7d_merge_finalb(this, that, v7dtmp, &
1667  remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
1668  remaptr1, remaptr2, remapn1, remapn2, lbestdata)
1669 CALL vol7d_merge_finalc(this, that, v7dtmp, &
1670  remapa1, remapa2, remapt1, remapt2, remapl1, remapl2, &
1671  remaptr1, remaptr2, remapn1, remapn2, lbestdata)
1672 
1673 ! Dealloco i vettori di rimappatura
1674 IF (ASSOCIATED(remapt1)) DEALLOCATE(remapt1)
1675 IF (ASSOCIATED(remapt2)) DEALLOCATE(remapt2)
1676 IF (ASSOCIATED(remaptr1)) DEALLOCATE(remaptr1)
1677 IF (ASSOCIATED(remaptr2)) DEALLOCATE(remaptr2)
1678 IF (ASSOCIATED(remapl1)) DEALLOCATE(remapl1)
1679 IF (ASSOCIATED(remapl2)) DEALLOCATE(remapl2)
1680 IF (ASSOCIATED(remapa1)) DEALLOCATE(remapa1)
1681 IF (ASSOCIATED(remapa2)) DEALLOCATE(remapa2)
1682 IF (ASSOCIATED(remapn1)) DEALLOCATE(remapn1)
1683 IF (ASSOCIATED(remapn2)) DEALLOCATE(remapn2)
1684 
1685 ! Distruggo il vecchio volume e assegno il nuovo a this
1686 CALL delete(this)
1687 this = v7dtmp
1688 ! Ricreo gli indici var-attr
1689 CALL vol7d_set_attr_ind(this)
1690 
1691 END SUBROUTINE vol7d_append
1692 
1693 
1726 SUBROUTINE vol7d_copy(this, that, sort, unique, miss, &
1727  lsort_time, lsort_timerange, lsort_level, &
1728  ltime, ltimerange, llevel, lana, lnetwork, &
1729  lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
1730  lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
1731  lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
1732  ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
1733  ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
1734  ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
1735 TYPE(vol7d),INTENT(IN) :: this
1736 type(vol7d),INTENT(INOUT) :: that
1737 LOGICAL,INTENT(IN),OPTIONAL :: sort
1738 LOGICAL,INTENT(IN),OPTIONAL :: unique
1739 LOGICAL,INTENT(IN),OPTIONAL :: miss
1740 LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
1741 LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
1742 LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
1750 LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
1751 
1752 LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
1753 
1754 LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
1755 
1756 LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
1757 
1758 LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
1759 
1760 LOGICAL,INTENT(in),OPTIONAL :: &
1761  lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
1762  lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
1763  lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
1764  ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
1765  ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
1766  ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
1767 
1768 LOGICAL :: lsort, lunique, lmiss
1769 INTEGER,POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
1770 
1771 CALL init(that)
1772 IF (.NOT.c_e(this)) RETURN ! speedup, nothing to do
1773 IF (.NOT.vol7d_check_vol(this)) RETURN ! be safe
1774 
1775 CALL optio(sort, lsort)
1776 CALL optio(unique, lunique)
1777 CALL optio(miss, lmiss)
1778 
1779 ! Calcolo le mappature tra volume vecchio e volume nuovo
1780 ! I puntatori remap* vengono tutti o allocati o nullificati
1781 CALL vol7d_remap1_datetime(this%time, that%time, &
1782  lsort.OR.optio_log(lsort_time), lunique, lmiss, remapt, ltime)
1783 CALL vol7d_remap1_vol7d_timerange(this%timerange, that%timerange, &
1784  lsort.OR.optio_log(lsort_timerange), lunique, lmiss, remaptr, ltimerange)
1785 CALL vol7d_remap1_vol7d_level(this%level, that%level, &
1786  lsort.OR.optio_log(lsort_level), lunique, lmiss, remapl, llevel)
1787 CALL vol7d_remap1_vol7d_ana(this%ana, that%ana, &
1788  lsort, lunique, lmiss, remapa, lana)
1789 CALL vol7d_remap1_vol7d_network(this%network, that%network, &
1790  lsort, lunique, lmiss, remapn, lnetwork)
1791 
1792 ! lanavari, lanavarb, lanavarc, &
1793 ! lanaattri, lanaattrb, lanaattrc, &
1794 ! lanavarattri, lanavarattrb, lanavarattrc, &
1795 ! ldativari, ldativarb, ldativarc, &
1796 ! ldatiattri, ldatiattrb, ldatiattrc, &
1797 ! ldativarattri, ldativarattrb, ldativarattrc
1798 ! Faccio la riforma fisica dei volumi
1799 CALL vol7d_reform_finalr(this, that, &
1800  remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
1801  lanavarr, lanaattrr, lanavarattrr, ldativarr, ldatiattrr, ldativarattrr)
1802 CALL vol7d_reform_finald(this, that, &
1803  remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
1804  lanavard, lanaattrd, lanavarattrd, ldativard, ldatiattrd, ldativarattrd)
1805 CALL vol7d_reform_finali(this, that, &
1806  remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
1807  lanavari, lanaattri, lanavarattri, ldativari, ldatiattri, ldativarattri)
1808 CALL vol7d_reform_finalb(this, that, &
1809  remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
1810  lanavarb, lanaattrb, lanavarattrb, ldativarb, ldatiattrb, ldativarattrb)
1811 CALL vol7d_reform_finalc(this, that, &
1812  remapa, remapt, remapl, remaptr, remapn, lsort, lunique, lmiss, &
1813  lanavarc, lanaattrc, lanavarattrc, ldativarc, ldatiattrc, ldativarattrc)
1814 
1815 ! Dealloco i vettori di rimappatura
1816 IF (ASSOCIATED(remapt)) DEALLOCATE(remapt)
1817 IF (ASSOCIATED(remaptr)) DEALLOCATE(remaptr)
1818 IF (ASSOCIATED(remapl)) DEALLOCATE(remapl)
1819 IF (ASSOCIATED(remapa)) DEALLOCATE(remapa)
1820 IF (ASSOCIATED(remapn)) DEALLOCATE(remapn)
1821 
1822 ! Ricreo gli indici var-attr
1823 CALL vol7d_set_attr_ind(that)
1824 that%time_definition = this%time_definition
1825 
1826 END SUBROUTINE vol7d_copy
1827 
1828 
1839 SUBROUTINE vol7d_reform(this, sort, unique, miss, &
1840  lsort_time, lsort_timerange, lsort_level, &
1841  ltime, ltimerange, llevel, lana, lnetwork, &
1842  lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
1843  lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
1844  lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
1845  ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
1846  ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
1847  ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc&
1848  ,purgeana)
1849 TYPE(vol7d),INTENT(INOUT) :: this
1850 LOGICAL,INTENT(IN),OPTIONAL :: sort
1851 LOGICAL,INTENT(IN),OPTIONAL :: unique
1852 LOGICAL,INTENT(IN),OPTIONAL :: miss
1853 LOGICAL,INTENT(IN),OPTIONAL :: lsort_time
1854 LOGICAL,INTENT(IN),OPTIONAL :: lsort_timerange
1855 LOGICAL,INTENT(IN),OPTIONAL :: lsort_level
1863 LOGICAL,INTENT(IN),OPTIONAL :: ltime(:)
1864 LOGICAL,INTENT(IN),OPTIONAL :: ltimerange(:)
1865 LOGICAL,INTENT(IN),OPTIONAL :: llevel(:)
1866 LOGICAL,INTENT(IN),OPTIONAL :: lana(:)
1867 LOGICAL,INTENT(IN),OPTIONAL :: lnetwork(:)
1869 LOGICAL,INTENT(in),OPTIONAL :: &
1870  lanavarr(:), lanavard(:), lanavari(:), lanavarb(:), lanavarc(:), &
1871  lanaattrr(:), lanaattrd(:), lanaattri(:), lanaattrb(:), lanaattrc(:), &
1872  lanavarattrr(:), lanavarattrd(:), lanavarattri(:), lanavarattrb(:), lanavarattrc(:), &
1873  ldativarr(:), ldativard(:), ldativari(:), ldativarb(:), ldativarc(:), &
1874  ldatiattrr(:), ldatiattrd(:), ldatiattri(:), ldatiattrb(:), ldatiattrc(:), &
1875  ldativarattrr(:), ldativarattrd(:), ldativarattri(:), ldativarattrb(:), ldativarattrc(:)
1876 LOGICAL,INTENT(IN),OPTIONAL :: purgeana
1877 
1878 TYPE(vol7d) :: v7dtmp
1879 logical,allocatable :: llana(:)
1880 integer :: i
1881 
1882 CALL vol7d_copy(this, v7dtmp, sort, unique, miss, &
1883  lsort_time, lsort_timerange, lsort_level, &
1884  ltime, ltimerange, llevel, lana, lnetwork, &
1885  lanavarr, lanavard, lanavari, lanavarb, lanavarc, &
1886  lanaattrr, lanaattrd, lanaattri, lanaattrb, lanaattrc, &
1887  lanavarattrr, lanavarattrd, lanavarattri, lanavarattrb, lanavarattrc, &
1888  ldativarr, ldativard, ldativari, ldativarb, ldativarc, &
1889  ldatiattrr, ldatiattrd, ldatiattri, ldatiattrb, ldatiattrc, &
1890  ldativarattrr, ldativarattrd, ldativarattri, ldativarattrb, ldativarattrc)
1891 
1892 ! destroy old volume
1893 CALL delete(this)
1894 
1895 if (optio_log(purgeana)) then
1896  allocate(llana(size(v7dtmp%ana)))
1897  llana =.false.
1898  do i =1,size(v7dtmp%ana)
1899  if (associated(v7dtmp%voldatii)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatii(i,:,:,:,:,:)))
1900  if (associated(v7dtmp%voldatir)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatir(i,:,:,:,:,:)))
1901  if (associated(v7dtmp%voldatid)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatid(i,:,:,:,:,:)))
1902  if (associated(v7dtmp%voldatib)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatib(i,:,:,:,:,:)))
1903  if (associated(v7dtmp%voldatic)) llana(i)= llana(i) .or. any(c_e(v7dtmp%voldatic(i,:,:,:,:,:)))
1904  end do
1905  CALL vol7d_copy(v7dtmp, this,lana=llana)
1906  CALL delete(v7dtmp)
1907  deallocate(llana)
1908 else
1909  this=v7dtmp
1910 end if
1912 END SUBROUTINE vol7d_reform
1913 
1914 
1922 SUBROUTINE vol7d_smart_sort(this, lsort_time, lsort_timerange, lsort_level)
1923 TYPE(vol7d),INTENT(INOUT) :: this
1924 LOGICAL,OPTIONAL,INTENT(in) :: lsort_time
1925 LOGICAL,OPTIONAL,INTENT(in) :: lsort_timerange
1926 LOGICAL,OPTIONAL,INTENT(in) :: lsort_level
1927 
1928 INTEGER :: i
1929 LOGICAL :: to_be_sorted
1930 
1931 to_be_sorted = .false.
1932 CALL vol7d_alloc_vol(this) ! usual safety check
1933 
1934 IF (optio_log(lsort_time)) THEN
1935  DO i = 2, SIZE(this%time)
1936  IF (this%time(i) < this%time(i-1)) THEN
1937  to_be_sorted = .true.
1938  EXIT
1939  ENDIF
1940  ENDDO
1941 ENDIF
1942 IF (optio_log(lsort_timerange)) THEN
1943  DO i = 2, SIZE(this%timerange)
1944  IF (this%timerange(i) < this%timerange(i-1)) THEN
1945  to_be_sorted = .true.
1946  EXIT
1947  ENDIF
1948  ENDDO
1949 ENDIF
1950 IF (optio_log(lsort_level)) THEN
1951  DO i = 2, SIZE(this%level)
1952  IF (this%level(i) < this%level(i-1)) THEN
1953  to_be_sorted = .true.
1954  EXIT
1955  ENDIF
1956  ENDDO
1957 ENDIF
1958 
1959 IF (to_be_sorted) CALL vol7d_reform(this, &
1960  lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
1961 
1962 END SUBROUTINE vol7d_smart_sort
1963 
1964 
1970 SUBROUTINE vol7d_convr(this, that)
1971 TYPE(vol7d),INTENT(IN) :: this
1972 type(vol7d),INTENT(INOUT) :: that
1973 LOGICAL :: anaconv ! dovra` diventare un parametro
1974 INTEGER :: i
1975 LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
1976 TYPE(vol7d) :: v7d_tmp
1977 
1978 ! richiede modifiche per convertirte i dati di anagrafica
1979 ! per ora sempre disabilitato
1980 anaconv = .false.
1981 IF (anaconv) THEN
1982  acp=fv
1983  acn=tv
1984 ELSE
1985  acp=tv
1986  acn=fv
1987 ENDIF
1988 
1989 ! Volume con solo i dati reali e tutti gli attributi
1990 ! l'anagrafica e` copiata interamente se necessario
1991 CALL vol7d_copy(this, that, &
1992  lanavarr=tv, lanavard=acp, lanavari=acp, lanavarb=acp, lanavarc=acp, &
1993  ldativarr=tv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=fv)
1994 
1995 ! Volume solo di dati double
1996 CALL vol7d_copy(this, v7d_tmp, &
1997  lanavarr=fv, lanavard=acn, lanavari=fv, lanavarb=fv, lanavarc=fv, &
1998  lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
1999  lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
2000  ldativarr=fv, ldativard=tv, ldativari=fv, ldativarb=fv, ldativarc=fv, &
2001  ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
2002  ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
2003 
2004 ! converto a dati reali
2005 IF (ASSOCIATED(v7d_tmp%dativar%d)) THEN ! .and. associated(v7d_tmp%voldatid) ?
2006 ! alloco i dati reali e vi trasferisco i double
2007  ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatid, 1), SIZE(v7d_tmp%voldatid, 2), &
2008  SIZE(v7d_tmp%voldatid, 3), SIZE(v7d_tmp%voldatid, 4), SIZE(v7d_tmp%voldatid, 5), &
2009  SIZE(v7d_tmp%voldatid, 6)))
2010  DO i = 1, SIZE(v7d_tmp%dativar%d)
2011  v7d_tmp%voldatir(:,:,:,:,i,:) = &
2012  realdat(v7d_tmp%voldatid(:,:,:,:,i,:), v7d_tmp%dativar%d(i))
2013  ENDDO
2014  DEALLOCATE(v7d_tmp%voldatid)
2015 ! trasferisco le variabili
2016  v7d_tmp%dativar%r => v7d_tmp%dativar%d
2017  nullify(v7d_tmp%dativar%d)
2018 
2019 ! fondo con il volume definitivo
2020  CALL vol7d_merge(that, v7d_tmp)
2021 ELSE
2022  CALL delete(v7d_tmp)
2023 ENDIF
2025 
2026 ! Volume solo di dati interi
2027 CALL vol7d_copy(this, v7d_tmp, &
2028  lanavarr=fv, lanavard=fv, lanavari=acn, lanavarb=fv, lanavarc=fv, &
2029  lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
2030  lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
2031  ldativarr=fv, ldativard=fv, ldativari=tv, ldativarb=fv, ldativarc=fv, &
2032  ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
2033  ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
2034 
2035 ! converto a dati reali
2036 IF (ASSOCIATED(v7d_tmp%dativar%i)) THEN
2037 ! alloco i dati reali e vi trasferisco gli interi
2038  ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatii, 1), SIZE(v7d_tmp%voldatii, 2), &
2039  SIZE(v7d_tmp%voldatii, 3), SIZE(v7d_tmp%voldatii, 4), SIZE(v7d_tmp%voldatii, 5), &
2040  SIZE(v7d_tmp%voldatii, 6)))
2041  DO i = 1, SIZE(v7d_tmp%dativar%i)
2042  v7d_tmp%voldatir(:,:,:,:,i,:) = &
2043  realdat(v7d_tmp%voldatii(:,:,:,:,i,:), v7d_tmp%dativar%i(i))
2044  ENDDO
2045  DEALLOCATE(v7d_tmp%voldatii)
2046 ! trasferisco le variabili
2047  v7d_tmp%dativar%r => v7d_tmp%dativar%i
2048  nullify(v7d_tmp%dativar%i)
2049 
2050 ! fondo con il volume definitivo
2051  CALL vol7d_merge(that, v7d_tmp)
2052 ELSE
2053  CALL delete(v7d_tmp)
2054 ENDIF
2055 
2056 
2057 ! Volume solo di dati byte
2058 call vol7d_copy(this, v7d_tmp, &
2059  lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=acn, lanavarc=fv, &
2060  lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
2061  lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
2062  ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=tv, ldativarc=fv, &
2063  ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
2064  ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
2065 
2066 ! converto a dati reali
2067 IF (ASSOCIATED(v7d_tmp%dativar%b)) THEN
2068 ! alloco i dati reali e vi trasferisco i byte
2069  ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatib, 1), SIZE(v7d_tmp%voldatib, 2), &
2070  SIZE(v7d_tmp%voldatib, 3), SIZE(v7d_tmp%voldatib, 4), SIZE(v7d_tmp%voldatib, 5), &
2071  SIZE(v7d_tmp%voldatib, 6)))
2072  DO i = 1, SIZE(v7d_tmp%dativar%b)
2073  v7d_tmp%voldatir(:,:,:,:,i,:) = &
2074  realdat(v7d_tmp%voldatib(:,:,:,:,i,:), v7d_tmp%dativar%b(i))
2075  ENDDO
2076  DEALLOCATE(v7d_tmp%voldatib)
2077 ! trasferisco le variabili
2078  v7d_tmp%dativar%r => v7d_tmp%dativar%b
2079  nullify(v7d_tmp%dativar%b)
2080 
2081 ! fondo con il volume definitivo
2082  CALL vol7d_merge(that, v7d_tmp)
2083 ELSE
2084  CALL delete(v7d_tmp)
2085 ENDIF
2086 
2087 
2088 ! Volume solo di dati character
2089 call vol7d_copy(this, v7d_tmp, &
2090  lanavarr=fv, lanavard=fv, lanavari=fv, lanavarb=fv, lanavarc=acn, &
2091  lanaattrr=fv, lanaattrd=fv, lanaattri=fv, lanaattrb=fv, lanaattrc=fv, &
2092  lanavarattrr=fv, lanavarattrd=fv, lanavarattri=fv, lanavarattrb=fv, lanavarattrc=fv, &
2093  ldativarr=fv, ldativard=fv, ldativari=fv, ldativarb=fv, ldativarc=tv, &
2094  ldatiattrr=fv, ldatiattrd=fv, ldatiattri=fv, ldatiattrb=fv, ldatiattrc=fv, &
2095  ldativarattrr=fv, ldativarattrd=fv, ldativarattri=fv, ldativarattrb=fv, ldativarattrc=fv)
2096 
2097 ! converto a dati reali
2098 IF (ASSOCIATED(v7d_tmp%dativar%c)) THEN
2099 ! alloco i dati reali e vi trasferisco i character
2100  ALLOCATE(v7d_tmp%voldatir(SIZE(v7d_tmp%voldatic, 1), SIZE(v7d_tmp%voldatic, 2), &
2101  SIZE(v7d_tmp%voldatic, 3), SIZE(v7d_tmp%voldatic, 4), SIZE(v7d_tmp%voldatic, 5), &
2102  SIZE(v7d_tmp%voldatic, 6)))
2103  DO i = 1, SIZE(v7d_tmp%dativar%c)
2104  v7d_tmp%voldatir(:,:,:,:,i,:) = &
2105  realdat(v7d_tmp%voldatic(:,:,:,:,i,:), v7d_tmp%dativar%c(i))
2106  ENDDO
2107  DEALLOCATE(v7d_tmp%voldatic)
2108 ! trasferisco le variabili
2109  v7d_tmp%dativar%r => v7d_tmp%dativar%c
2110  nullify(v7d_tmp%dativar%c)
2111 
2112 ! fondo con il volume definitivo
2113  CALL vol7d_merge(that, v7d_tmp)
2114 ELSE
2115  CALL delete(v7d_tmp)
2116 ENDIF
2117 
2118 
2119 
2120 END SUBROUTINE vol7d_convr
2121 
2122 
2126 SUBROUTINE vol7d_diff_only (this, that, data_only,ana)
2127 TYPE(vol7d),INTENT(IN) :: this
2128 type(vol7d),INTENT(OUT) :: that
2129 logical , optional, intent(in) :: data_only
2130 logical , optional, intent(in) :: ana
2131 logical :: ldata_only,lana
2132 
2133 IF (present(data_only)) THEN
2134  ldata_only = data_only
2135 ELSE
2136  ldata_only = .false.
2137 ENDIF
2138 
2139 IF (present(ana)) THEN
2140  lana = ana
2141 ELSE
2142  lana = .false.
2143 ENDIF
2144 
2145 
2146 #undef VOL7D_POLY_ARRAY
2147 #define VOL7D_POLY_ARRAY voldati
2148 #include "vol7d_class_diff.F90"
2149 #undef VOL7D_POLY_ARRAY
2150 #define VOL7D_POLY_ARRAY voldatiattr
2151 #include "vol7d_class_diff.F90"
2152 #undef VOL7D_POLY_ARRAY
2153 
2154 if ( .not. ldata_only) then
2156 #define VOL7D_POLY_ARRAY volana
2157 #include "vol7d_class_diff.F90"
2158 #undef VOL7D_POLY_ARRAY
2159 #define VOL7D_POLY_ARRAY volanaattr
2160 #include "vol7d_class_diff.F90"
2161 #undef VOL7D_POLY_ARRAY
2162 
2163  if(lana)then
2164  where ( this%ana == that%ana )
2165  that%ana = vol7d_ana_miss
2166  end where
2167  end if
2168 
2169 end if
2170 
2171 
2172 
2173 END SUBROUTINE vol7d_diff_only
2174 
2175 
2176 
2177 ! Creo le routine da ripetere per i vari tipi di dati di v7d
2178 ! tramite un template e il preprocessore
2179 #undef VOL7D_POLY_TYPE
2180 #undef VOL7D_POLY_TYPES
2181 #define VOL7D_POLY_TYPE REAL
2182 #define VOL7D_POLY_TYPES r
2183 #include "vol7d_class_type_templ.F90"
2184 #undef VOL7D_POLY_TYPE
2185 #undef VOL7D_POLY_TYPES
2186 #define VOL7D_POLY_TYPE DOUBLE PRECISION
2187 #define VOL7D_POLY_TYPES d
2188 #include "vol7d_class_type_templ.F90"
2189 #undef VOL7D_POLY_TYPE
2190 #undef VOL7D_POLY_TYPES
2191 #define VOL7D_POLY_TYPE INTEGER
2192 #define VOL7D_POLY_TYPES i
2193 #include "vol7d_class_type_templ.F90"
2194 #undef VOL7D_POLY_TYPE
2195 #undef VOL7D_POLY_TYPES
2196 #define VOL7D_POLY_TYPE INTEGER(kind=int_b)
2197 #define VOL7D_POLY_TYPES b
2198 #include "vol7d_class_type_templ.F90"
2199 #undef VOL7D_POLY_TYPE
2200 #undef VOL7D_POLY_TYPES
2201 #define VOL7D_POLY_TYPE CHARACTER(len=vol7d_cdatalen)
2202 #define VOL7D_POLY_TYPES c
2203 #include "vol7d_class_type_templ.F90"
2204 
2205 ! Creo le routine da ripetere per i vari descrittori di dimensioni di v7d
2206 ! tramite un template e il preprocessore
2207 #define VOL7D_SORT
2208 #undef VOL7D_NO_ZERO_ALLOC
2209 #undef VOL7D_POLY_TYPE
2210 #define VOL7D_POLY_TYPE datetime
2211 #include "vol7d_class_desc_templ.F90"
2212 #undef VOL7D_POLY_TYPE
2213 #define VOL7D_POLY_TYPE vol7d_timerange
2214 #include "vol7d_class_desc_templ.F90"
2215 #undef VOL7D_POLY_TYPE
2216 #define VOL7D_POLY_TYPE vol7d_level
2217 #include "vol7d_class_desc_templ.F90"
2218 #undef VOL7D_SORT
2219 #undef VOL7D_POLY_TYPE
2220 #define VOL7D_POLY_TYPE vol7d_network
2221 #include "vol7d_class_desc_templ.F90"
2222 #undef VOL7D_POLY_TYPE
2223 #define VOL7D_POLY_TYPE vol7d_ana
2224 #include "vol7d_class_desc_templ.F90"
2225 #define VOL7D_NO_ZERO_ALLOC
2226 #undef VOL7D_POLY_TYPE
2227 #define VOL7D_POLY_TYPE vol7d_var
2228 #include "vol7d_class_desc_templ.F90"
2229 
2239 subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
2240 
2241 TYPE(vol7d),INTENT(IN) :: this
2242 integer,optional,intent(inout) :: unit
2243 character(len=*),intent(in),optional :: filename
2244 character(len=*),intent(out),optional :: filename_auto
2245 character(len=*),INTENT(IN),optional :: description
2246 
2247 integer :: lunit
2248 character(len=254) :: ldescription,arg,lfilename
2249 integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
2250  ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2251  ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2252  ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2253  nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2254  nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2255  nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
2256 !integer :: im,id,iy
2257 integer :: tarray(8)
2258 logical :: opened,exist
2259 
2260  nana=0
2261  ntime=0
2262  ntimerange=0
2263  nlevel=0
2264  nnetwork=0
2265  ndativarr=0
2266  ndativari=0
2267  ndativarb=0
2268  ndativard=0
2269  ndativarc=0
2270  ndatiattrr=0
2271  ndatiattri=0
2272  ndatiattrb=0
2273  ndatiattrd=0
2274  ndatiattrc=0
2275  ndativarattrr=0
2276  ndativarattri=0
2277  ndativarattrb=0
2278  ndativarattrd=0
2279  ndativarattrc=0
2280  nanavarr=0
2281  nanavari=0
2282  nanavarb=0
2283  nanavard=0
2284  nanavarc=0
2285  nanaattrr=0
2286  nanaattri=0
2287  nanaattrb=0
2288  nanaattrd=0
2289  nanaattrc=0
2290  nanavarattrr=0
2291  nanavarattri=0
2292  nanavarattrb=0
2293  nanavarattrd=0
2294  nanavarattrc=0
2295 
2296 
2297 !call idate(im,id,iy)
2298 call date_and_time(values=tarray)
2299 call getarg(0,arg)
2300 
2301 if (present(description))then
2302  ldescription=description
2303 else
2304  ldescription="Vol7d generated by: "//trim(arg)
2305 end if
2306 
2307 if (.not. present(unit))then
2308  lunit=getunit()
2309 else
2310  if (unit==0)then
2311  lunit=getunit()
2312  unit=lunit
2313  else
2314  lunit=unit
2315  end if
2316 end if
2317 
2318 lfilename=trim(arg)//".v7d"
2319 if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
2320 
2321 if (present(filename))then
2322  if (filename /= "")then
2323  lfilename=filename
2324  end if
2325 end if
2326 
2327 if (present(filename_auto))filename_auto=lfilename
2328 
2329 
2330 inquire(unit=lunit,opened=opened)
2331 if (.not. opened) then
2332 ! inquire(file=lfilename, EXIST=exist)
2333 ! IF (exist) THEN
2334 ! CALL l4f_log(L4F_FATAL, &
2335 ! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
2336 ! CALL raise_fatal_error()
2337 ! ENDIF
2338  OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access=stream_if_possible)
2339  CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
2340 end if
2341 
2342 if (associated(this%ana)) nana=size(this%ana)
2343 if (associated(this%time)) ntime=size(this%time)
2344 if (associated(this%timerange)) ntimerange=size(this%timerange)
2345 if (associated(this%level)) nlevel=size(this%level)
2346 if (associated(this%network)) nnetwork=size(this%network)
2347 
2348 if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
2349 if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
2350 if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
2351 if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
2352 if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
2353 
2354 if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
2355 if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
2356 if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
2357 if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
2358 if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
2359 
2360 if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
2361 if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
2362 if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
2363 if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
2364 if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
2365 
2366 if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
2367 if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
2368 if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
2369 if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
2370 if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
2371 
2372 if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
2373 if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
2374 if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
2375 if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
2376 if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
2377 
2378 if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
2379 if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
2380 if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
2381 if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
2382 if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
2383 
2384 write(unit=lunit)ldescription
2385 write(unit=lunit)tarray
2386 
2387 write(unit=lunit)&
2388  nana, ntime, ntimerange, nlevel, nnetwork, &
2389  ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2390  ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2391  ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2392  nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2393  nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2394  nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
2395  this%time_definition
2396 
2397 
2398 !write(unit=lunit)this
2399 
2400 
2401 !! prime 5 dimensioni
2402 if (associated(this%ana)) call write_unit(this%ana, lunit)
2403 if (associated(this%time)) call write_unit(this%time, lunit)
2404 if (associated(this%level)) write(unit=lunit)this%level
2405 if (associated(this%timerange)) write(unit=lunit)this%timerange
2406 if (associated(this%network)) write(unit=lunit)this%network
2407 
2408  !! 6a dimensione: variabile dell'anagrafica e dei dati
2409  !! con relativi attributi e in 5 tipi diversi
2410 
2411 if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
2412 if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
2413 if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
2414 if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
2415 if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
2416 
2417 if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
2418 if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
2419 if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
2420 if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
2421 if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
2422 
2423 if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
2424 if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
2425 if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
2426 if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
2427 if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
2428 
2429 if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
2430 if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
2431 if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
2432 if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
2433 if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
2434 
2435 if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
2436 if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
2437 if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
2438 if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
2439 if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
2440 
2441 if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
2442 if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
2443 if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
2444 if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
2445 if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
2446 
2447 !! Volumi di valori e attributi per anagrafica e dati
2448 
2449 if (associated(this%volanar)) write(unit=lunit)this%volanar
2450 if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
2451 if (associated(this%voldatir)) write(unit=lunit)this%voldatir
2452 if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
2453 
2454 if (associated(this%volanai)) write(unit=lunit)this%volanai
2455 if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
2456 if (associated(this%voldatii)) write(unit=lunit)this%voldatii
2457 if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
2458 
2459 if (associated(this%volanab)) write(unit=lunit)this%volanab
2460 if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
2461 if (associated(this%voldatib)) write(unit=lunit)this%voldatib
2462 if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
2463 
2464 if (associated(this%volanad)) write(unit=lunit)this%volanad
2465 if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
2466 if (associated(this%voldatid)) write(unit=lunit)this%voldatid
2467 if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
2468 
2469 if (associated(this%volanac)) write(unit=lunit)this%volanac
2470 if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
2471 if (associated(this%voldatic)) write(unit=lunit)this%voldatic
2472 if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
2473 
2474 if (.not. present(unit)) close(unit=lunit)
2475 
2476 end subroutine vol7d_write_on_file
2477 
2478 
2485 
2486 
2487 subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
2488 
2489 TYPE(vol7d),INTENT(OUT) :: this
2490 integer,intent(inout),optional :: unit
2491 character(len=*),INTENT(in),optional :: filename
2492 character(len=*),intent(out),optional :: filename_auto
2493 character(len=*),INTENT(out),optional :: description
2494 integer,intent(out),optional :: tarray(8)
2495 
2496 
2497 integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
2498  ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2499  ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2500  ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2501  nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2502  nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2503  nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
2504 
2505 character(len=254) :: ldescription,lfilename,arg
2506 integer :: ltarray(8),lunit,ios
2507 logical :: opened,exist
2508 
2509 
2510 call getarg(0,arg)
2511 
2512 if (.not. present(unit))then
2513  lunit=getunit()
2514 else
2515  if (unit==0)then
2516  lunit=getunit()
2517  unit=lunit
2518  else
2519  lunit=unit
2520  end if
2521 end if
2522 
2523 lfilename=trim(arg)//".v7d"
2524 if (index(arg,'/',back=.true.) > 0) lfilename=lfilename(index(arg,'/',back=.true.)+1 : )
2525 
2526 if (present(filename))then
2527  if (filename /= "")then
2528  lfilename=filename
2529  end if
2530 end if
2531 
2532 if (present(filename_auto))filename_auto=lfilename
2533 
2534 
2535 inquire(unit=lunit,opened=opened)
2536 IF (.NOT. opened) THEN
2537  inquire(file=lfilename,exist=exist)
2538  IF (.NOT.exist) THEN
2539  CALL l4f_log(l4f_fatal, &
2540  'in vol7d_read_from_file, file does not exists, cannot open')
2541  CALL raise_fatal_error()
2542  ENDIF
2543  OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access=stream_if_possible, &
2544  status='OLD', action='READ')
2545  CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
2546 end if
2547 
2548 
2549 call init(this)
2550 read(unit=lunit,iostat=ios)ldescription
2551 
2552 if (ios < 0) then ! A negative value indicates that the End of File or End of Record
2553  call vol7d_alloc(this)
2554  call vol7d_alloc_vol(this)
2555  if (present(description))description=ldescription
2556  if (present(tarray))tarray=ltarray
2557  if (.not. present(unit)) close(unit=lunit)
2558 end if
2559 
2560 read(unit=lunit)ltarray
2561 
2562 CALL l4f_log(l4f_info, 'Reading vol7d from file')
2563 CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
2564 CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
2565  trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
2566 
2567 if (present(description))description=ldescription
2568 if (present(tarray))tarray=ltarray
2569 
2570 read(unit=lunit)&
2571  nana, ntime, ntimerange, nlevel, nnetwork, &
2572  ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2573  ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2574  ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2575  nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2576  nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2577  nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
2578  this%time_definition
2579 
2580 call vol7d_alloc(this, &
2581  nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
2582  ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
2583  ndativard=ndativard, ndativarc=ndativarc,&
2584  ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
2585  ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
2586  ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
2587  ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
2588  nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
2589  nanavard=nanavard, nanavarc=nanavarc,&
2590  nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
2591  nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
2592  nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
2593  nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
2594 
2595 
2596 if (associated(this%ana)) call read_unit(this%ana, lunit)
2597 if (associated(this%time)) call read_unit(this%time, lunit)
2598 if (associated(this%level)) read(unit=lunit)this%level
2599 if (associated(this%timerange)) read(unit=lunit)this%timerange
2600 if (associated(this%network)) read(unit=lunit)this%network
2601 
2602 if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
2603 if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
2604 if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
2605 if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
2606 if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
2607 
2608 if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
2609 if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
2610 if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
2611 if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
2612 if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
2613 
2614 if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
2615 if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
2616 if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
2617 if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
2618 if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
2619 
2620 if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
2621 if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
2622 if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
2623 if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
2624 if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
2625 
2626 if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
2627 if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
2628 if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
2629 if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
2630 if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
2631 
2632 if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
2633 if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
2634 if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
2635 if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
2636 if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
2637 
2638 call vol7d_alloc_vol(this)
2639 
2640 !! Volumi di valori e attributi per anagrafica e dati
2641 
2642 if (associated(this%volanar)) read(unit=lunit)this%volanar
2643 if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
2644 if (associated(this%voldatir)) read(unit=lunit)this%voldatir
2645 if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
2646 
2647 if (associated(this%volanai)) read(unit=lunit)this%volanai
2648 if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
2649 if (associated(this%voldatii)) read(unit=lunit)this%voldatii
2650 if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
2651 
2652 if (associated(this%volanab)) read(unit=lunit)this%volanab
2653 if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
2654 if (associated(this%voldatib)) read(unit=lunit)this%voldatib
2655 if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
2656 
2657 if (associated(this%volanad)) read(unit=lunit)this%volanad
2658 if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
2659 if (associated(this%voldatid)) read(unit=lunit)this%voldatid
2660 if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
2661 
2662 if (associated(this%volanac)) read(unit=lunit)this%volanac
2663 if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
2664 if (associated(this%voldatic)) read(unit=lunit)this%voldatic
2665 if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
2666 
2667 if (.not. present(unit)) close(unit=lunit)
2668 
2669 end subroutine vol7d_read_from_file
2670 
2671 
2672 ! to double precision
2673 elemental doubleprecision function doubledatd(voldat,var)
2674 doubleprecision,intent(in) :: voldat
2675 type(vol7d_var),intent(in) :: var
2676 
2677 doubledatd=voldat
2678 
2679 end function doubledatd
2680 
2681 
2682 elemental doubleprecision function doubledatr(voldat,var)
2683 real,intent(in) :: voldat
2684 type(vol7d_var),intent(in) :: var
2685 
2686 if (c_e(voldat))then
2687  doubledatr=dble(voldat)
2688 else
2689  doubledatr=dmiss
2690 end if
2691 
2692 end function doubledatr
2693 
2694 
2695 elemental doubleprecision function doubledati(voldat,var)
2696 integer,intent(in) :: voldat
2697 type(vol7d_var),intent(in) :: var
2698 
2699 if (c_e(voldat)) then
2700  if (c_e(var%scalefactor))then
2701  doubledati=dble(voldat)/10.d0**var%scalefactor
2702  else
2703  doubledati=dble(voldat)
2704  endif
2705 else
2706  doubledati=dmiss
2707 end if
2708 
2709 end function doubledati
2710 
2711 
2712 elemental doubleprecision function doubledatb(voldat,var)
2713 integer(kind=int_b),intent(in) :: voldat
2714 type(vol7d_var),intent(in) :: var
2715 
2716 if (c_e(voldat)) then
2717  if (c_e(var%scalefactor))then
2718  doubledatb=dble(voldat)/10.d0**var%scalefactor
2719  else
2720  doubledatb=dble(voldat)
2721  endif
2722 else
2723  doubledatb=dmiss
2724 end if
2725 
2726 end function doubledatb
2727 
2728 
2729 elemental doubleprecision function doubledatc(voldat,var)
2730 CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
2731 type(vol7d_var),intent(in) :: var
2732 
2733 doubledatc = c2d(voldat)
2734 if (c_e(doubledatc) .and. c_e(var%scalefactor))then
2735  doubledatc=doubledatc/10.d0**var%scalefactor
2736 end if
2737 
2738 end function doubledatc
2739 
2740 
2741 ! to integer
2742 elemental integer function integerdatd(voldat,var)
2743 doubleprecision,intent(in) :: voldat
2744 type(vol7d_var),intent(in) :: var
2745 
2746 if (c_e(voldat))then
2747  if (c_e(var%scalefactor)) then
2748  integerdatd=nint(voldat*10d0**var%scalefactor)
2749  else
2750  integerdatd=nint(voldat)
2751  endif
2752 else
2753  integerdatd=imiss
2754 end if
2755 
2756 end function integerdatd
2757 
2758 
2759 elemental integer function integerdatr(voldat,var)
2760 real,intent(in) :: voldat
2761 type(vol7d_var),intent(in) :: var
2762 
2763 if (c_e(voldat))then
2764  if (c_e(var%scalefactor)) then
2765  integerdatr=nint(voldat*10d0**var%scalefactor)
2766  else
2767  integerdatr=nint(voldat)
2768  endif
2769 else
2770  integerdatr=imiss
2771 end if
2772 
2773 end function integerdatr
2774 
2775 
2776 elemental integer function integerdati(voldat,var)
2777 integer,intent(in) :: voldat
2778 type(vol7d_var),intent(in) :: var
2779 
2780 integerdati=voldat
2781 
2782 end function integerdati
2783 
2784 
2785 elemental integer function integerdatb(voldat,var)
2786 integer(kind=int_b),intent(in) :: voldat
2787 type(vol7d_var),intent(in) :: var
2788 
2789 if (c_e(voldat))then
2790  integerdatb=voldat
2791 else
2792  integerdatb=imiss
2793 end if
2794 
2795 end function integerdatb
2796 
2797 
2798 elemental integer function integerdatc(voldat,var)
2799 CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
2800 type(vol7d_var),intent(in) :: var
2801 
2802 integerdatc=c2i(voldat)
2803 
2804 end function integerdatc
2805 
2806 
2807 ! to real
2808 elemental real function realdatd(voldat,var)
2809 doubleprecision,intent(in) :: voldat
2810 type(vol7d_var),intent(in) :: var
2811 
2812 if (c_e(voldat))then
2813  realdatd=real(voldat)
2814 else
2815  realdatd=rmiss
2816 end if
2817 
2818 end function realdatd
2819 
2820 
2821 elemental real function realdatr(voldat,var)
2822 real,intent(in) :: voldat
2823 type(vol7d_var),intent(in) :: var
2824 
2825 realdatr=voldat
2826 
2827 end function realdatr
2828 
2829 
2830 elemental real function realdati(voldat,var)
2831 integer,intent(in) :: voldat
2832 type(vol7d_var),intent(in) :: var
2833 
2834 if (c_e(voldat)) then
2835  if (c_e(var%scalefactor))then
2836  realdati=float(voldat)/10.**var%scalefactor
2837  else
2838  realdati=float(voldat)
2839  endif
2840 else
2841  realdati=rmiss
2842 end if
2843 
2844 end function realdati
2845 
2846 
2847 elemental real function realdatb(voldat,var)
2848 integer(kind=int_b),intent(in) :: voldat
2849 type(vol7d_var),intent(in) :: var
2850 
2851 if (c_e(voldat)) then
2852  if (c_e(var%scalefactor))then
2853  realdatb=float(voldat)/10**var%scalefactor
2854  else
2855  realdatb=float(voldat)
2856  endif
2857 else
2858  realdatb=rmiss
2859 end if
2860 
2861 end function realdatb
2862 
2863 
2864 elemental real function realdatc(voldat,var)
2865 CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
2866 type(vol7d_var),intent(in) :: var
2867 
2868 realdatc=c2r(voldat)
2869 if (c_e(realdatc) .and. c_e(var%scalefactor))then
2870  realdatc=realdatc/10.**var%scalefactor
2871 end if
2872 
2873 end function realdatc
2874 
2875 
2881 FUNCTION realanavol(this, var) RESULT(vol)
2882 TYPE(vol7d),INTENT(in) :: this
2883 type(vol7d_var),INTENT(in) :: var
2884 REAL :: vol(size(this%ana),size(this%network))
2885 
2886 CHARACTER(len=1) :: dtype
2887 INTEGER :: indvar
2888 
2889 dtype = cmiss
2890 indvar = index(this%anavar, var, type=dtype)
2891 
2892 IF (indvar > 0) THEN
2893  SELECT CASE (dtype)
2894  CASE("d")
2895  vol = realdat(this%volanad(:,indvar,:), var)
2896  CASE("r")
2897  vol = this%volanar(:,indvar,:)
2898  CASE("i")
2899  vol = realdat(this%volanai(:,indvar,:), var)
2900  CASE("b")
2901  vol = realdat(this%volanab(:,indvar,:), var)
2902  CASE("c")
2903  vol = realdat(this%volanac(:,indvar,:), var)
2904  CASE default
2905  vol = rmiss
2906  END SELECT
2907 ELSE
2908  vol = rmiss
2909 ENDIF
2910 
2911 END FUNCTION realanavol
2912 
2913 
2919 FUNCTION integeranavol(this, var) RESULT(vol)
2920 TYPE(vol7d),INTENT(in) :: this
2921 type(vol7d_var),INTENT(in) :: var
2922 INTEGER :: vol(size(this%ana),size(this%network))
2923 
2924 CHARACTER(len=1) :: dtype
2925 INTEGER :: indvar
2926 
2927 dtype = cmiss
2928 indvar = index(this%anavar, var, type=dtype)
2929 
2930 IF (indvar > 0) THEN
2931  SELECT CASE (dtype)
2932  CASE("d")
2933  vol = integerdat(this%volanad(:,indvar,:), var)
2934  CASE("r")
2935  vol = integerdat(this%volanar(:,indvar,:), var)
2936  CASE("i")
2937  vol = this%volanai(:,indvar,:)
2938  CASE("b")
2939  vol = integerdat(this%volanab(:,indvar,:), var)
2940  CASE("c")
2941  vol = integerdat(this%volanac(:,indvar,:), var)
2942  CASE default
2943  vol = imiss
2944  END SELECT
2945 ELSE
2946  vol = imiss
2947 ENDIF
2948 
2949 END FUNCTION integeranavol
2950 
2951 
2957 subroutine move_datac (v7d,&
2958  indana,indtime,indlevel,indtimerange,indnetwork,&
2959  indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
2960 
2961 TYPE(vol7d),intent(inout) :: v7d
2962 
2963 integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
2964 integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
2965 integer :: inddativar,inddativarattr
2966 
2967 
2968 do inddativar=1,size(v7d%dativar%c)
2969 
2970  if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
2971  .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
2972  ) then
2973 
2974  ! dati
2975  v7d%voldatic &
2976  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
2977  v7d%voldatic &
2978  (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
2979 
2980 
2981  ! attributi
2982  if (associated (v7d%dativarattr%i)) then
2983  inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
2984  if (inddativarattr > 0 ) then
2985  v7d%voldatiattri &
2986  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
2987  v7d%voldatiattri &
2988  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
2989  end if
2990  end if
2991 
2992  if (associated (v7d%dativarattr%r)) then
2993  inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
2994  if (inddativarattr > 0 ) then
2995  v7d%voldatiattrr &
2996  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
2997  v7d%voldatiattrr &
2998  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
2999  end if
3000  end if
3001 
3002  if (associated (v7d%dativarattr%d)) then
3003  inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
3004  if (inddativarattr > 0 ) then
3005  v7d%voldatiattrd &
3006  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3007  v7d%voldatiattrd &
3008  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3009  end if
3010  end if
3011 
3012  if (associated (v7d%dativarattr%b)) then
3013  inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
3014  if (inddativarattr > 0 ) then
3015  v7d%voldatiattrb &
3016  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3017  v7d%voldatiattrb &
3018  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3019  end if
3020  end if
3021 
3022  if (associated (v7d%dativarattr%c)) then
3023  inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
3024  if (inddativarattr > 0 ) then
3025  v7d%voldatiattrc &
3026  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3027  v7d%voldatiattrc &
3028  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3029  end if
3030  end if
3031 
3032  end if
3033 
3034 end do
3035 
3036 end subroutine move_datac
3037 
3043 subroutine move_datar (v7d,&
3044  indana,indtime,indlevel,indtimerange,indnetwork,&
3045  indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
3046 
3047 TYPE(vol7d),intent(inout) :: v7d
3048 
3049 integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
3050 integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
3051 integer :: inddativar,inddativarattr
3052 
3053 
3054 do inddativar=1,size(v7d%dativar%r)
3055 
3056  if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
3057  .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
3058  ) then
3059 
3060  ! dati
3061  v7d%voldatir &
3062  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
3063  v7d%voldatir &
3064  (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
3065 
3066 
3067  ! attributi
3068  if (associated (v7d%dativarattr%i)) then
3069  inddativarattr = index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
3070  if (inddativarattr > 0 ) then
3071  v7d%voldatiattri &
3072  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3073  v7d%voldatiattri &
3074  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3075  end if
3076  end if
3077 
3078  if (associated (v7d%dativarattr%r)) then
3079  inddativarattr = index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
3080  if (inddativarattr > 0 ) then
3081  v7d%voldatiattrr &
3082  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3083  v7d%voldatiattrr &
3084  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3085  end if
3086  end if
3087 
3088  if (associated (v7d%dativarattr%d)) then
3089  inddativarattr = index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
3090  if (inddativarattr > 0 ) then
3091  v7d%voldatiattrd &
3092  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3093  v7d%voldatiattrd &
3094  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3095  end if
3096  end if
3097 
3098  if (associated (v7d%dativarattr%b)) then
3099  inddativarattr = index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
3100  if (inddativarattr > 0 ) then
3101  v7d%voldatiattrb &
3102  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3103  v7d%voldatiattrb &
3104  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3105  end if
3106  end if
3107 
3108  if (associated (v7d%dativarattr%c)) then
3109  inddativarattr = index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
3110  if (inddativarattr > 0 ) then
3111  v7d%voldatiattrc &
3112  (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3113  v7d%voldatiattrc &
3114  (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3115  end if
3116  end if
3117 
3118  end if
3119 
3120 end do
3121 
3122 end subroutine move_datar
3123 
3124 
3138 subroutine v7d_rounding(v7din,v7dout,level,timerange,nostatproc)
3139 type(vol7d),intent(inout) :: v7din
3140 type(vol7d),intent(out) :: v7dout !> output volume
3141 type(vol7d_level),intent(in),optional :: level(:)
3142 type(vol7d_timerange),intent(in),optional :: timerange(:)
3143 !logical,intent(in),optional :: merge !< if there are data on more then one almost equal levels or timeranges
3144 !! will be merged POINT BY POINT with priority for the fird data found ordered by icreasing var index
3145 logical,intent(in),optional :: nostatproc
3146 
3147 integer :: nana,nlevel,ntime,ntimerange,nnetwork,nbin
3148 integer :: iana,ilevel,itimerange,indl,indt,itime,inetwork
3149 type(vol7d_level) :: roundlevel(size(v7din%level))
3150 type(vol7d_timerange) :: roundtimerange(size(v7din%timerange))
3151 type(vol7d) :: v7d_tmp
3152 
3153 
3154 nbin=0
3155 
3156 if (associated(v7din%dativar%r)) nbin = nbin + size(v7din%dativar%r)
3157 if (associated(v7din%dativar%i)) nbin = nbin + size(v7din%dativar%i)
3158 if (associated(v7din%dativar%d)) nbin = nbin + size(v7din%dativar%d)
3159 if (associated(v7din%dativar%b)) nbin = nbin + size(v7din%dativar%b)
3160 
3161 call init(v7d_tmp)
3162 
3163 roundlevel=v7din%level
3164 
3165 if (present(level))then
3166  do ilevel = 1, size(v7din%level)
3167  if ((any(v7din%level(ilevel) .almosteq. level))) then
3168  roundlevel(ilevel)=level(1)
3169  end if
3170  end do
3171 end if
3172 
3173 roundtimerange=v7din%timerange
3174 
3175 if (present(timerange))then
3176  do itimerange = 1, size(v7din%timerange)
3177  if ((any(v7din%timerange(itimerange) .almosteq. timerange))) then
3178  roundtimerange(itimerange)=timerange(1)
3179  end if
3180  end do
3181 end if
3182 
3183 !set istantaneous values everywere
3184 !preserve p1 for forecast time
3185 if (optio_log(nostatproc)) then
3186  roundtimerange(:)%timerange=254
3187  roundtimerange(:)%p2=0
3188 end if
3189 
3190 
3191 nana=size(v7din%ana)
3192 nlevel=count_distinct(roundlevel,back=.true.)
3193 ntime=size(v7din%time)
3194 ntimerange=count_distinct(roundtimerange,back=.true.)
3195 nnetwork=size(v7din%network)
3196 
3197 call init(v7d_tmp)
3198 
3199 if (nbin == 0) then
3200  call copy(v7din,v7d_tmp)
3201 else
3202  call vol7d_convr(v7din,v7d_tmp)
3203 end if
3204 
3205 v7d_tmp%level=roundlevel
3206 v7d_tmp%timerange=roundtimerange
3207 
3208 do ilevel=1, size(v7d_tmp%level)
3209  indl=index(v7d_tmp%level,roundlevel(ilevel))
3210  do itimerange=1,size(v7d_tmp%timerange)
3211  indt=index(v7d_tmp%timerange,roundtimerange(itimerange))
3212 
3213  if (indl /= ilevel .or. indt /= itimerange) then
3214 
3215  do iana=1, nana
3216  do itime=1,ntime
3217  do inetwork=1,nnetwork
3218 
3219  if (nbin > 0) then
3220  call move_datar(v7d_tmp,&
3221  iana,itime,ilevel,itimerange,inetwork,&
3222  iana,itime,indl,indt,inetwork)
3223  else
3224  call move_datac(v7d_tmp,&
3225  iana,itime,ilevel,itimerange,inetwork,&
3226  iana,itime,indl,indt,inetwork)
3227  end if
3228 
3229  end do
3230  end do
3231  end do
3232 
3233  end if
3234 
3235  end do
3236 end do
3237 
3238 ! set to missing level and time > nlevel
3239 do ilevel=nlevel+1,size(v7d_tmp%level)
3240  call init(v7d_tmp%level(ilevel))
3241 end do
3242 
3243 do itimerange=ntimerange+1,size(v7d_tmp%timerange)
3244  call init(v7d_tmp%timerange(itimerange))
3245 end do
3246 
3247 !copy with remove
3248 CALL copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
3249 CALL delete(v7d_tmp)
3250 
3251 !call display(v7dout)
3252 
3253 end subroutine v7d_rounding
3254 
3255 
3256 END MODULE vol7d_class
3257 
3263 
3264 
Classi per la gestione delle coordinate temporali.
Lettura da file.
Functions that return a trimmed CHARACTER representation of the input variable.
Gestione degli errori.
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Distruttore per la classe vol7d.
copy object
Represent data in a pretty string.
Definition of constants related to I/O units.
Definition: io_units.F90:231
doubleprecision data conversion
Scrittura su file.
Classe per la gestione delle reti di stazioni per osservazioni meteo e affini.
Definisce un vettore di vol7d_var_class::vol7d_var per ogni tipo di dato supportato.
Costruttore per la classe vol7d.
Classe per la gestione dei livelli verticali in osservazioni meteo e affini.
Reduce some dimensions (level and timerage) for semplification (rounding).
Scrive un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta su un file FORMATTED ...
Generic subroutine for checking OPTIONAL parameters.
Print object.
Classe per gestire un vettore di oggetti di tipo vol7d_var_class::vol7d_var.
Classe per la gestione di un volume completo di dati osservati.
Test for a missing volume.
Index method.
Classe per la gestione degli intervalli temporali di osservazioni meteo e affini. ...
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...
Classe per la gestione dell&#39;anagrafica di stazioni meteo e affini.
classe per la gestione del logging
Utilities for CHARACTER variables.
Definition of constants to be used for declaring variables of a desired type.
Definition: kinds.F90:251
real data conversion
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
integer data conversion
Check for problems return 0 if all check passed print diagnostics with log4f.
This module defines usefull general purpose function and subroutine.

Generated with Doxygen.