102 INTEGER,
PARAMETER :: vol7d_maxdim_a = 3, vol7d_maxdim_aa = 4, &
103 vol7d_maxdim_d = 6, vol7d_maxdim_ad = 7
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
119 INTEGER :: r, d, i, b, c
120 END TYPE vol7d_varmap
126 TYPE(vol7d_ana
),
POINTER :: ana(:)
128 TYPE(datetime
),
POINTER :: time(:)
130 TYPE(vol7d_level
),
POINTER :: level(:)
132 TYPE(vol7d_timerange
),
POINTER :: timerange(:)
134 TYPE(vol7d_network
),
POINTER :: network(:)
149 REAL,
POINTER :: volanar(:,:,:)
151 DOUBLE PRECISION,
POINTER :: volanad(:,:,:)
153 INTEGER,
POINTER :: volanai(:,:,:)
155 INTEGER(kind=int_b),
POINTER :: volanab(:,:,:)
157 CHARACTER(len=vol7d_cdatalen),
POINTER :: volanac(:,:,:)
160 REAL,
POINTER :: volanaattrr(:,:,:,:)
162 DOUBLE PRECISION,
POINTER :: volanaattrd(:,:,:,:)
164 INTEGER,
POINTER :: volanaattri(:,:,:,:)
166 INTEGER(kind=int_b),
POINTER :: volanaattrb(:,:,:,:)
168 CHARACTER(len=vol7d_cdatalen),
POINTER :: volanaattrc(:,:,:,:)
171 REAL,
POINTER :: voldatir(:,:,:,:,:,:)
173 DOUBLE PRECISION,
POINTER :: voldatid(:,:,:,:,:,:)
175 INTEGER,
POINTER :: voldatii(:,:,:,:,:,:)
177 INTEGER(kind=int_b),
POINTER :: voldatib(:,:,:,:,:,:)
179 CHARACTER(len=vol7d_cdatalen),
POINTER :: voldatic(:,:,:,:,:,:)
182 REAL,
POINTER :: voldatiattrr(:,:,:,:,:,:,:)
184 DOUBLE PRECISION,
POINTER :: voldatiattrd(:,:,:,:,:,:,:)
186 INTEGER,
POINTER :: voldatiattri(:,:,:,:,:,:,:)
188 INTEGER(kind=int_b),
POINTER :: voldatiattrb(:,:,:,:,:,:,:)
190 CHARACTER(len=vol7d_cdatalen),
POINTER :: voldatiattrc(:,:,:,:,:,:,:)
193 integer :: time_definition
201 MODULE PROCEDURE vol7d_init
206 MODULE PROCEDURE vol7d_delete
211 MODULE PROCEDURE vol7d_write_on_file
216 MODULE PROCEDURE vol7d_read_from_file
221 MODULE PROCEDURE vol7d_display, dat_display, dat_vect_display
226 MODULE PROCEDURE to_char_dat
231 MODULE PROCEDURE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
236 MODULE PROCEDURE realdatd,realdatr,realdati,realdatb,realdatc
241 MODULE PROCEDURE integerdatd,integerdatr,integerdati,integerdatb,integerdatc
246 MODULE PROCEDURE vol7d_copy
251 MODULE PROCEDURE vol7d_c_e
258 MODULE PROCEDURE vol7d_check
275 MODULE PROCEDURE v7d_rounding
298 PRIVATE vol7d_get_volr, vol7d_get_vold, vol7d_get_voli, vol7d_get_volb, &
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
312 PRIVATE doubledatd,doubledatr,doubledati,doubledatb,doubledatc
323 SUBROUTINE vol7d_init(this,time_definition)
325 integer,
INTENT(IN),
OPTIONAL :: time_definition
327 CALL
init(this%anavar)
329 CALL
init(this%anavarattr)
331 CALL
init(this%datiattr)
334 nullify(this%ana, this%time, this%level, this%timerange, this%network)
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)
342 if(present(time_definition))
then
343 this%time_definition=time_definition
345 this%time_definition=1
348 END SUBROUTINE vol7d_init
354 ELEMENTAL SUBROUTINE vol7d_delete(this, dataonly)
355 TYPE(vol7d),
intent(inout) :: this
356 LOGICAL,
INTENT(in),
OPTIONAL :: dataonly
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)
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)
382 IF (.NOT. optio_log(dataonly))
THEN
383 IF (
ASSOCIATED(this%ana))
DEALLOCATE(this%ana)
384 IF (
ASSOCIATED(this%network))
DEALLOCATE(this%network)
386 IF (
ASSOCIATED(this%time))
DEALLOCATE(this%time)
387 IF (
ASSOCIATED(this%level))
DEALLOCATE(this%level)
388 IF (
ASSOCIATED(this%timerange))
DEALLOCATE(this%timerange)
390 IF (.NOT. optio_log(dataonly))
THEN
393 CALL
delete(this%anavarattr)
396 CALL
delete(this%datiattr)
397 CALL
delete(this%dativarattr)
399 END SUBROUTINE vol7d_delete
403 integer function vol7d_check(this)
405 integer :: i,j,k,l,m,n
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("&
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("&
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("&
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("&
490 end function vol7d_check
496 SUBROUTINE vol7d_display(this)
497 TYPE(vol7d),
intent(in) :: this
501 DOUBLE PRECISION :: ddat
503 INTEGER(kind=int_b) :: bdat
504 CHARACTER(len=vol7d_cdatalen) :: cdat
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"
513 print*,
"Time definition have a wrong walue:", this%time_definition
516 IF (
ASSOCIATED(this%network))
then
517 print*,
"---- network vector ----"
518 print*,
"elements=",
size(this%network)
519 do i=1,
size(this%network)
524 IF (
ASSOCIATED(this%ana))
then
525 print*,
"---- ana vector ----"
526 print*,
"elements=",
size(this%ana)
527 do i=1,
size(this%ana)
532 IF (
ASSOCIATED(this%time))
then
533 print*,
"---- time vector ----"
534 print*,
"elements=",
size(this%time)
535 do i=1,
size(this%time)
540 IF (
ASSOCIATED(this%level))
then
541 print*,
"---- level vector ----"
542 print*,
"elements=",
size(this%level)
543 do i =1,
size(this%level)
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))
557 print*,
"---- ana vector ----"
559 print*,
"->>>>>>>>> anavar -"
562 print*,
"->>>>>>>>> anaattr -"
565 print*,
"->>>>>>>>> anavarattr -"
568 print*,
"-- ana data section (first point) --"
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)
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)
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)
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)
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)
624 print*,
"---- data vector ----"
626 print*,
"->>>>>>>>> dativar -"
629 print*,
"->>>>>>>>> datiattr -"
632 print*,
"->>>>>>>>> dativarattr -"
635 print*,
"-- data data section (first point) --"
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)
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)
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)
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)
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)
686 print*,
"<<<<<<<<<<<<<<<<<<< END vol7d object >>>>>>>>>>>>>>>>>>>>"
688 END SUBROUTINE vol7d_display
692 SUBROUTINE dat_display(this,idat,rdat,ddat,bdat,cdat)
693 TYPE(vol7d_var
),
intent(in) :: this
697 DOUBLE PRECISION :: ddat
701 INTEGER(kind=int_b) :: bdat
703 CHARACTER(len=*) :: cdat
705 print *, to_char_dat(this,idat,rdat,ddat,bdat,cdat)
707 end SUBROUTINE dat_display
710 SUBROUTINE dat_vect_display(this,idat,rdat,ddat,bdat,cdat)
712 TYPE(vol7d_var
),
intent(in) :: this(:)
716 DOUBLE PRECISION :: ddat(:)
720 INTEGER(kind=int_b) :: bdat(:)
722 CHARACTER(len=*):: cdat(:)
727 call
display(this(i),idat(i),rdat(i),ddat(i),bdat(i),cdat(i))
730 end SUBROUTINE dat_vect_display
733 FUNCTION to_char_dat(this,idat,rdat,ddat,bdat,cdat)
735 #ifdef HAVE_DBALLEF_MOD
741 TYPE(vol7d_var
),
INTENT(in) :: this
745 DOUBLE PRECISION :: ddat
749 INTEGER(kind=int_b) :: bdat
751 CHARACTER(len=*) :: cdat
752 CHARACTER(len=80) :: to_char_dat
754 CHARACTER(len=LEN(to_char_dat)) :: to_char_tmp
758 INTEGER :: handle, ier
761 to_char_dat=
"VALUE: "
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))
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)
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)
786 END FUNCTION to_char_dat
791 FUNCTION vol7d_c_e(this) RESULT(c_e)
792 TYPE(vol7d),
INTENT(in) :: this
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)
812 END FUNCTION vol7d_c_e
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, &
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
880 IF (present(ini))
THEN
887 IF (present(nana))
THEN
889 IF (
ASSOCIATED(this%ana))
DEALLOCATE(this%ana)
890 ALLOCATE(this%ana(nana))
893 CALL
init(this%ana(i))
898 IF (present(ntime))
THEN
900 IF (
ASSOCIATED(this%time))
DEALLOCATE(this%time)
901 ALLOCATE(this%time(ntime))
909 IF (present(nlevel))
THEN
910 IF (nlevel >= 0)
THEN
911 IF (
ASSOCIATED(this%level))
DEALLOCATE(this%level)
912 ALLOCATE(this%level(nlevel))
915 CALL
init(this%level(i))
920 IF (present(ntimerange))
THEN
921 IF (ntimerange >= 0)
THEN
922 IF (
ASSOCIATED(this%timerange))
DEALLOCATE(this%timerange)
923 ALLOCATE(this%timerange(ntimerange))
926 CALL
init(this%timerange(i))
931 IF (present(nnetwork))
THEN
932 IF (nnetwork >= 0)
THEN
933 IF (
ASSOCIATED(this%network))
DEALLOCATE(this%network)
934 ALLOCATE(this%network(nnetwork))
937 CALL
init(this%network(i))
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)
956 END SUBROUTINE vol7d_alloc
959 FUNCTION vol7d_check_alloc_ana(this)
960 TYPE(vol7d),
INTENT(in) :: this
961 LOGICAL :: vol7d_check_alloc_ana
963 vol7d_check_alloc_ana =
ASSOCIATED(this%ana) .AND.
ASSOCIATED(this%network)
965 END FUNCTION vol7d_check_alloc_ana
967 SUBROUTINE vol7d_force_alloc_ana(this, ini)
968 TYPE(vol7d),
INTENT(inout) :: this
969 LOGICAL,
INTENT(in),
OPTIONAL :: ini
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)
975 END SUBROUTINE vol7d_force_alloc_ana
978 FUNCTION vol7d_check_alloc_dati(this)
979 TYPE(vol7d),
INTENT(in) :: this
980 LOGICAL :: vol7d_check_alloc_dati
982 vol7d_check_alloc_dati = vol7d_check_alloc_ana(this) .AND. &
983 ASSOCIATED(this%time) .AND.
ASSOCIATED(this%level) .AND. &
984 ASSOCIATED(this%timerange)
986 END FUNCTION vol7d_check_alloc_dati
988 SUBROUTINE vol7d_force_alloc_dati(this, ini)
989 TYPE(vol7d),
INTENT(inout) :: this
990 LOGICAL,
INTENT(in),
OPTIONAL :: ini
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)
998 END SUBROUTINE vol7d_force_alloc_dati
1001 SUBROUTINE vol7d_force_alloc(this)
1002 TYPE(vol7d),
INTENT(inout) :: this
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)
1011 END SUBROUTINE vol7d_force_alloc
1014 FUNCTION vol7d_check_vol(this)
1015 TYPE(vol7d),
INTENT(in) :: this
1016 LOGICAL :: vol7d_check_vol
1018 vol7d_check_vol =
c_e(this)
1021 IF (
ASSOCIATED(this%anavar%r) .AND. .NOT.
ASSOCIATED(this%volanar))
THEN
1022 vol7d_check_vol = .false.
1025 IF (
ASSOCIATED(this%anavar%d) .AND. .NOT.
ASSOCIATED(this%volanad))
THEN
1026 vol7d_check_vol = .false.
1029 IF (
ASSOCIATED(this%anavar%i) .AND. .NOT.
ASSOCIATED(this%volanai))
THEN
1030 vol7d_check_vol = .false.
1033 IF (
ASSOCIATED(this%anavar%b) .AND. .NOT.
ASSOCIATED(this%volanab))
THEN
1034 vol7d_check_vol = .false.
1037 IF (
ASSOCIATED(this%anavar%c) .AND. .NOT.
ASSOCIATED(this%volanac))
THEN
1038 vol7d_check_vol = .false.
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)
1047 IF (
ASSOCIATED(this%anaattr%r) .AND.
ASSOCIATED(this%anavarattr%r) .AND. &
1048 .NOT.
ASSOCIATED(this%volanaattrr))
THEN
1049 vol7d_check_vol = .false.
1052 IF (
ASSOCIATED(this%anaattr%d) .AND.
ASSOCIATED(this%anavarattr%d) .AND. &
1053 .NOT.
ASSOCIATED(this%volanaattrd))
THEN
1054 vol7d_check_vol = .false.
1057 IF (
ASSOCIATED(this%anaattr%i) .AND.
ASSOCIATED(this%anavarattr%i) .AND. &
1058 .NOT.
ASSOCIATED(this%volanaattri))
THEN
1059 vol7d_check_vol = .false.
1062 IF (
ASSOCIATED(this%anaattr%b) .AND.
ASSOCIATED(this%anavarattr%b) .AND. &
1063 .NOT.
ASSOCIATED(this%volanaattrb))
THEN
1064 vol7d_check_vol = .false.
1067 IF (
ASSOCIATED(this%anaattr%c) .AND.
ASSOCIATED(this%anavarattr%c) .AND. &
1068 .NOT.
ASSOCIATED(this%volanaattrc))
THEN
1069 vol7d_check_vol = .false.
1073 IF (
ASSOCIATED(this%dativar%r) .AND. .NOT.
ASSOCIATED(this%voldatir))
THEN
1074 vol7d_check_vol = .false.
1077 IF (
ASSOCIATED(this%dativar%d) .AND. .NOT.
ASSOCIATED(this%voldatid))
THEN
1078 vol7d_check_vol = .false.
1081 IF (
ASSOCIATED(this%dativar%i) .AND. .NOT.
ASSOCIATED(this%voldatii))
THEN
1082 vol7d_check_vol = .false.
1085 IF (
ASSOCIATED(this%dativar%b) .AND. .NOT.
ASSOCIATED(this%voldatib))
THEN
1086 vol7d_check_vol = .false.
1089 IF (
ASSOCIATED(this%dativar%c) .AND. .NOT.
ASSOCIATED(this%voldatic))
THEN
1090 vol7d_check_vol = .false.
1094 IF (
ASSOCIATED(this%datiattr%r) .AND.
ASSOCIATED(this%dativarattr%r) .AND. &
1095 .NOT.
ASSOCIATED(this%voldatiattrr))
THEN
1096 vol7d_check_vol = .false.
1099 IF (
ASSOCIATED(this%datiattr%d) .AND.
ASSOCIATED(this%dativarattr%d) .AND. &
1100 .NOT.
ASSOCIATED(this%voldatiattrd))
THEN
1101 vol7d_check_vol = .false.
1104 IF (
ASSOCIATED(this%datiattr%i) .AND.
ASSOCIATED(this%dativarattr%i) .AND. &
1105 .NOT.
ASSOCIATED(this%voldatiattri))
THEN
1106 vol7d_check_vol = .false.
1109 IF (
ASSOCIATED(this%datiattr%b) .AND.
ASSOCIATED(this%dativarattr%b) .AND. &
1110 .NOT.
ASSOCIATED(this%voldatiattrb))
THEN
1111 vol7d_check_vol = .false.
1114 IF (
ASSOCIATED(this%datiattr%c) .AND.
ASSOCIATED(this%dativarattr%c) .AND. &
1115 .NOT.
ASSOCIATED(this%voldatiattrc))
THEN
1116 vol7d_check_vol = .false.
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)
1124 END FUNCTION vol7d_check_vol
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
1148 IF (present(inivol))
THEN
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
1309 CALL vol7d_force_alloc(this)
1314 CALL l4f_log(l4f_debug,
"calling: vol7d_set_attr_ind")
1317 CALL vol7d_set_attr_ind(this)
1321 END SUBROUTINE vol7d_alloc_vol
1330 SUBROUTINE vol7d_set_attr_ind(this)
1331 TYPE(vol7d),
INTENT(inout) :: this
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
1521 END SUBROUTINE vol7d_set_attr_ind
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
1536 TYPE(vol7d) :: v7d_clean
1539 IF (.NOT.
c_e(this))
THEN
1541 CALL
init(v7d_clean)
1544 CALL vol7d_append(this, that,
sort, bestdata, &
1545 ltimesimple, ltimerangesimple, llevelsimple, lanasimple)
1549 END SUBROUTINE vol7d_merge
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
1588 LOGICAL,
INTENT(in),
OPTIONAL :: bestdata
1589 LOGICAL,
INTENT(IN),
OPTIONAL :: ltimesimple, ltimerangesimple, llevelsimple, lanasimple, lnetworksimple
1592 TYPE(vol7d) :: v7dtmp
1593 LOGICAL :: lsort, lbestdata
1594 INTEGER,
POINTER :: remapt1(:), remapt2(:), remaptr1(:), remaptr2(:), &
1595 remapl1(:), remapl2(:), remapa1(:), remapa2(:), remapn1(:), remapn2(:)
1597 IF (.NOT.
c_e(that))
RETURN
1598 IF (.NOT.vol7d_check_vol(that))
RETURN
1599 IF (.NOT.
c_e(this))
THEN
1600 CALL vol7d_copy(that, this,
sort=
sort)
1604 IF (this%time_definition /= that%time_definition)
THEN
1605 CALL l4f_log(l4f_fatal, &
1606 'in vol7d_append, cannot append volumes with different &
1608 CALL raise_fatal_error()
1612 CALL vol7d_alloc_vol(this)
1614 CALL
init(v7dtmp, time_definition=this%time_definition)
1616 CALL
optio(bestdata, lbestdata)
1620 IF (optio_log(ltimesimple))
THEN
1621 CALL vol7d_remap2simple_datetime(this%time, that%time, v7dtmp%time, &
1622 lsort, remapt1, remapt2)
1624 CALL vol7d_remap2_datetime(this%time, that%time, v7dtmp%time, &
1625 lsort, remapt1, remapt2)
1627 IF (optio_log(ltimerangesimple))
THEN
1628 CALL vol7d_remap2simple_vol7d_timerange(this%timerange, that%timerange, &
1629 v7dtmp%timerange, lsort, remaptr1, remaptr2)
1631 CALL vol7d_remap2_vol7d_timerange(this%timerange, that%timerange, &
1632 v7dtmp%timerange, lsort, remaptr1, remaptr2)
1634 IF (optio_log(llevelsimple))
THEN
1635 CALL vol7d_remap2simple_vol7d_level(this%level, that%level, v7dtmp%level, &
1636 lsort, remapl1, remapl2)
1638 CALL vol7d_remap2_vol7d_level(this%level, that%level, v7dtmp%level, &
1639 lsort, remapl1, remapl2)
1641 IF (optio_log(lanasimple))
THEN
1642 CALL vol7d_remap2simple_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
1643 .false., remapa1, remapa2)
1645 CALL vol7d_remap2_vol7d_ana(this%ana, that%ana, v7dtmp%ana, &
1646 .false., remapa1, remapa2)
1648 IF (optio_log(lnetworksimple))
THEN
1649 CALL vol7d_remap2simple_vol7d_network(this%network, that%network, v7dtmp%network, &
1650 .false., remapn1, remapn2)
1652 CALL vol7d_remap2_vol7d_network(this%network, that%network, v7dtmp%network, &
1653 .false., remapn1, remapn2)
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)
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)
1689 CALL vol7d_set_attr_ind(this)
1691 END SUBROUTINE vol7d_append
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(:)
1752 LOGICAL,
INTENT(IN),
OPTIONAL :: ltimerange(:)
1754 LOGICAL,
INTENT(IN),
OPTIONAL :: llevel(:)
1756 LOGICAL,
INTENT(IN),
OPTIONAL :: lana(:)
1758 LOGICAL,
INTENT(IN),
OPTIONAL :: lnetwork(:)
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(:)
1768 LOGICAL :: lsort, lunique, lmiss
1769 INTEGER,
POINTER :: remapt(:), remaptr(:), remapl(:), remapa(:), remapn(:)
1772 IF (.NOT.
c_e(this))
RETURN
1773 IF (.NOT.vol7d_check_vol(this))
RETURN
1776 CALL
optio(unique, lunique)
1777 CALL
optio(miss, lmiss)
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)
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)
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)
1823 CALL vol7d_set_attr_ind(that)
1824 that%time_definition = this%time_definition
1826 END SUBROUTINE vol7d_copy
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&
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
1878 TYPE(vol7d) :: v7dtmp
1879 logical,
allocatable :: llana(:)
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)
1895 if (optio_log(purgeana))
then
1896 allocate(llana(
size(v7dtmp%ana)))
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,:,:,:,:,:)))
1905 CALL vol7d_copy(v7dtmp, this,lana=llana)
1912 END SUBROUTINE vol7d_reform
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
1929 LOGICAL :: to_be_sorted
1931 to_be_sorted = .false.
1932 CALL vol7d_alloc_vol(this)
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.
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.
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.
1959 IF (to_be_sorted) CALL vol7d_reform(this, &
1960 lsort_time=lsort_time, lsort_timerange=lsort_timerange, lsort_level=lsort_level )
1962 END SUBROUTINE vol7d_smart_sort
1970 SUBROUTINE vol7d_convr(this, that)
1971 TYPE(vol7d),
INTENT(IN) :: this
1972 type(
vol7d),
INTENT(INOUT) :: that
1975 LOGICAL :: fv(1)=(/.false./), tv(1)=(/.true./), acp(1), acn(1)
1976 TYPE(vol7d) :: v7d_tmp
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)
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)
2005 IF (
ASSOCIATED(v7d_tmp%dativar%d))
THEN
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))
2014 DEALLOCATE(v7d_tmp%voldatid)
2016 v7d_tmp%dativar%r => v7d_tmp%dativar%d
2017 nullify(v7d_tmp%dativar%d)
2020 CALL vol7d_merge(that, v7d_tmp)
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)
2036 IF (
ASSOCIATED(v7d_tmp%dativar%i))
THEN
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))
2045 DEALLOCATE(v7d_tmp%voldatii)
2047 v7d_tmp%dativar%r => v7d_tmp%dativar%i
2048 nullify(v7d_tmp%dativar%i)
2051 CALL vol7d_merge(that, v7d_tmp)
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)
2067 IF (
ASSOCIATED(v7d_tmp%dativar%b))
THEN
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))
2076 DEALLOCATE(v7d_tmp%voldatib)
2078 v7d_tmp%dativar%r => v7d_tmp%dativar%b
2079 nullify(v7d_tmp%dativar%b)
2082 CALL vol7d_merge(that, v7d_tmp)
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)
2098 IF (
ASSOCIATED(v7d_tmp%dativar%c))
THEN
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))
2107 DEALLOCATE(v7d_tmp%voldatic)
2109 v7d_tmp%dativar%r => v7d_tmp%dativar%c
2110 nullify(v7d_tmp%dativar%c)
2113 CALL vol7d_merge(that, v7d_tmp)
2120 END SUBROUTINE vol7d_convr
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
2133 IF (present(data_only))
THEN
2134 ldata_only = data_only
2136 ldata_only = .false.
2139 IF (present(ana))
THEN
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
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
2164 where ( this%ana == that%ana )
2165 that%ana = vol7d_ana_miss
2173 END SUBROUTINE vol7d_diff_only
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"
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"
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"
2239 subroutine vol7d_write_on_file (this,unit,description,filename,filename_auto)
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
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
2257 integer :: tarray(8)
2258 logical :: opened,exist
2298 call date_and_time(values=tarray)
2301 if (present(description))
then
2302 ldescription=description
2304 ldescription=
"Vol7d generated by: "//trim(arg)
2307 if (.not. present(unit))
then
2318 lfilename=trim(arg)//
".v7d"
2319 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
2321 if (present(filename))
then
2322 if (filename /=
"")
then
2327 if (present(filename_auto))filename_auto=lfilename
2330 inquire(unit=lunit,opened=opened)
2331 if (.not. opened)
then
2338 OPEN(unit=lunit, file=lfilename, form=
'UNFORMATTED', access=stream_if_possible)
2339 CALL l4f_log(l4f_info,
'opened: '//trim(lfilename))
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)
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)
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)
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)
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)
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)
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)
2384 write(unit=lunit)ldescription
2385 write(unit=lunit)tarray
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
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
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
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
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
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
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
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
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
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
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
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
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
2474 if (.not. present(unit))
close(unit=lunit)
2476 end subroutine vol7d_write_on_file
2487 subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
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)
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
2505 character(len=254) :: ldescription,lfilename,arg
2506 integer :: ltarray(8),lunit,ios
2507 logical :: opened,exist
2512 if (.not. present(unit))
then
2523 lfilename=trim(arg)//
".v7d"
2524 if (
index(arg,
'/',back=.true.) > 0) lfilename=lfilename(
index(arg,
'/',back=.true.)+1 : )
2526 if (present(filename))
then
2527 if (filename /=
"")
then
2532 if (present(filename_auto))filename_auto=lfilename
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()
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))
2550 read(unit=lunit,iostat=ios)ldescription
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)
2560 read(unit=lunit)ltarray
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)))//
' '// &
2567 if (present(description))description=ldescription
2568 if (present(tarray))tarray=ltarray
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
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)
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
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
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
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
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
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
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
2638 call vol7d_alloc_vol(this)
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
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
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
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
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
2667 if (.not. present(unit))
close(unit=lunit)
2669 end subroutine vol7d_read_from_file
2673 elemental doubleprecision
function doubledatd(voldat,var)
2674 doubleprecision,
intent(in) :: voldat
2675 type(vol7d_var
),
intent(in) :: var
2679 end function doubledatd
2682 elemental doubleprecision
function doubledatr(voldat,var)
2683 real,
intent(in) :: voldat
2684 type(vol7d_var
),
intent(in) :: var
2686 if (
c_e(voldat))
then
2687 doubledatr=dble(voldat)
2692 end function doubledatr
2695 elemental doubleprecision
function doubledati(voldat,var)
2696 integer,
intent(in) :: voldat
2697 type(vol7d_var
),
intent(in) :: var
2699 if (
c_e(voldat))
then
2700 if (
c_e(var%scalefactor))
then
2701 doubledati=dble(voldat)/10.d0**var%scalefactor
2703 doubledati=dble(voldat)
2709 end function doubledati
2712 elemental doubleprecision
function doubledatb(voldat,var)
2713 integer(kind=int_b),
intent(in) :: voldat
2714 type(vol7d_var
),
intent(in) :: var
2716 if (
c_e(voldat))
then
2717 if (
c_e(var%scalefactor))
then
2718 doubledatb=dble(voldat)/10.d0**var%scalefactor
2720 doubledatb=dble(voldat)
2726 end function doubledatb
2729 elemental doubleprecision
function doubledatc(voldat,var)
2730 CHARACTER(len=vol7d_cdatalen),
intent(in) :: voldat
2731 type(vol7d_var
),
intent(in) :: var
2733 doubledatc = c2d(voldat)
2734 if (
c_e(doubledatc) .and.
c_e(var%scalefactor))
then
2735 doubledatc=doubledatc/10.d0**var%scalefactor
2738 end function doubledatc
2742 elemental integer function integerdatd(voldat,var)
2743 doubleprecision,
intent(in) :: voldat
2744 type(vol7d_var
),
intent(in) :: var
2746 if (
c_e(voldat))
then
2747 if (
c_e(var%scalefactor))
then
2748 integerdatd=nint(voldat*10d0**var%scalefactor)
2750 integerdatd=nint(voldat)
2756 end function integerdatd
2759 elemental integer function integerdatr(voldat,var)
2760 real,
intent(in) :: voldat
2761 type(vol7d_var
),
intent(in) :: var
2763 if (
c_e(voldat))
then
2764 if (
c_e(var%scalefactor))
then
2765 integerdatr=nint(voldat*10d0**var%scalefactor)
2767 integerdatr=nint(voldat)
2773 end function integerdatr
2776 elemental integer function integerdati(voldat,var)
2777 integer,
intent(in) :: voldat
2778 type(vol7d_var
),
intent(in) :: var
2782 end function integerdati
2785 elemental integer function integerdatb(voldat,var)
2786 integer(kind=int_b),
intent(in) :: voldat
2787 type(vol7d_var
),
intent(in) :: var
2789 if (
c_e(voldat))
then
2795 end function integerdatb
2798 elemental integer function integerdatc(voldat,var)
2799 CHARACTER(len=vol7d_cdatalen),
intent(in) :: voldat
2800 type(vol7d_var
),
intent(in) :: var
2802 integerdatc=c2i(voldat)
2804 end function integerdatc
2808 elemental real function realdatd(voldat,var)
2809 doubleprecision,
intent(in) :: voldat
2810 type(vol7d_var
),
intent(in) :: var
2812 if (
c_e(voldat))
then
2813 realdatd=
real(voldat)
2818 end function realdatd
2821 elemental real function realdatr(voldat,var)
2822 real,
intent(in) :: voldat
2823 type(vol7d_var
),
intent(in) :: var
2827 end function realdatr
2830 elemental real function realdati(voldat,var)
2831 integer,
intent(in) :: voldat
2832 type(vol7d_var
),
intent(in) :: var
2834 if (
c_e(voldat))
then
2835 if (
c_e(var%scalefactor))
then
2836 realdati=float(voldat)/10.**var%scalefactor
2838 realdati=float(voldat)
2844 end function realdati
2847 elemental real function realdatb(voldat,var)
2848 integer(kind=int_b),
intent(in) :: voldat
2849 type(vol7d_var
),
intent(in) :: var
2851 if (
c_e(voldat))
then
2852 if (
c_e(var%scalefactor))
then
2853 realdatb=float(voldat)/10**var%scalefactor
2855 realdatb=float(voldat)
2861 end function realdatb
2864 elemental real function realdatc(voldat,var)
2865 CHARACTER(len=vol7d_cdatalen),
intent(in) :: voldat
2866 type(vol7d_var
),
intent(in) :: var
2868 realdatc=c2r(voldat)
2869 if (
c_e(realdatc) .and.
c_e(var%scalefactor))
then
2870 realdatc=realdatc/10.**var%scalefactor
2873 end function realdatc
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))
2886 CHARACTER(len=1) :: dtype
2890 indvar =
index(this%anavar, var, type=dtype)
2892 IF (indvar > 0)
THEN
2895 vol =
realdat(this%volanad(:,indvar,:), var)
2897 vol = this%volanar(:,indvar,:)
2899 vol =
realdat(this%volanai(:,indvar,:), var)
2901 vol =
realdat(this%volanab(:,indvar,:), var)
2903 vol =
realdat(this%volanac(:,indvar,:), var)
2911 END FUNCTION realanavol
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))
2924 CHARACTER(len=1) :: dtype
2928 indvar =
index(this%anavar, var, type=dtype)
2930 IF (indvar > 0)
THEN
2933 vol =
integerdat(this%volanad(:,indvar,:), var)
2935 vol =
integerdat(this%volanar(:,indvar,:), var)
2937 vol = this%volanai(:,indvar,:)
2939 vol =
integerdat(this%volanab(:,indvar,:), var)
2941 vol =
integerdat(this%volanac(:,indvar,:), var)
2949 END FUNCTION integeranavol
2957 subroutine move_datac (v7d,&
2958 indana,indtime,indlevel,indtimerange,indnetwork,&
2959 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
2961 TYPE(vol7d),
intent(inout) :: v7d
2963 integer,
intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
2964 integer,
intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
2965 integer :: inddativar,inddativarattr
2968 do inddativar=1,
size(v7d%dativar%c)
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))&
2976 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
2978 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
2982 if (
associated (v7d%dativarattr%i))
then
2983 inddativarattr =
index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
2984 if (inddativarattr > 0 )
then
2986 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
2988 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
2992 if (
associated (v7d%dativarattr%r))
then
2993 inddativarattr =
index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
2994 if (inddativarattr > 0 )
then
2996 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
2998 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3002 if (
associated (v7d%dativarattr%d))
then
3003 inddativarattr =
index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
3004 if (inddativarattr > 0 )
then
3006 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3008 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3012 if (
associated (v7d%dativarattr%b))
then
3013 inddativarattr =
index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
3014 if (inddativarattr > 0 )
then
3016 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3018 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3022 if (
associated (v7d%dativarattr%c))
then
3023 inddativarattr =
index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
3024 if (inddativarattr > 0 )
then
3026 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3028 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3036 end subroutine move_datac
3043 subroutine move_datar (v7d,&
3044 indana,indtime,indlevel,indtimerange,indnetwork,&
3045 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
3047 TYPE(vol7d),
intent(inout) :: v7d
3049 integer,
intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork
3050 integer,
intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew
3051 integer :: inddativar,inddativarattr
3054 do inddativar=1,
size(v7d%dativar%r)
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))&
3062 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
3064 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
3068 if (
associated (v7d%dativarattr%i))
then
3069 inddativarattr =
index(v7d%dativarattr%i,v7d%dativar%r(inddativar))
3070 if (inddativarattr > 0 )
then
3072 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3074 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3078 if (
associated (v7d%dativarattr%r))
then
3079 inddativarattr =
index(v7d%dativarattr%r,v7d%dativar%r(inddativar))
3080 if (inddativarattr > 0 )
then
3082 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3084 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3088 if (
associated (v7d%dativarattr%d))
then
3089 inddativarattr =
index(v7d%dativarattr%d,v7d%dativar%r(inddativar))
3090 if (inddativarattr > 0 )
then
3092 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3094 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3098 if (
associated (v7d%dativarattr%b))
then
3099 inddativarattr =
index(v7d%dativarattr%b,v7d%dativar%r(inddativar))
3100 if (inddativarattr > 0 )
then
3102 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3104 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3108 if (
associated (v7d%dativarattr%c))
then
3109 inddativarattr =
index(v7d%dativarattr%c,v7d%dativar%r(inddativar))
3110 if (inddativarattr > 0 )
then
3112 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3114 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3122 end subroutine move_datar
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(:)
3145 logical,
intent(in),
optional :: nostatproc
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
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)
3163 roundlevel=v7din%level
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)
3173 roundtimerange=v7din%timerange
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)
3185 if (optio_log(nostatproc))
then
3186 roundtimerange(:)%timerange=254
3187 roundtimerange(:)%p2=0
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)
3200 call
copy(v7din,v7d_tmp)
3202 call vol7d_convr(v7din,v7d_tmp)
3205 v7d_tmp%level=roundlevel
3206 v7d_tmp%timerange=roundtimerange
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))
3213 if (indl /= ilevel .or. indt /= itimerange)
then
3217 do inetwork=1,nnetwork
3220 call move_datar(v7d_tmp,&
3221 iana,itime,ilevel,itimerange,inetwork,&
3222 iana,itime,indl,indt,inetwork)
3224 call move_datac(v7d_tmp,&
3225 iana,itime,ilevel,itimerange,inetwork,&
3226 iana,itime,indl,indt,inetwork)
3239 do ilevel=nlevel+1,
size(v7d_tmp%level)
3240 call
init(v7d_tmp%level(ilevel))
3243 do itimerange=ntimerange+1,
size(v7d_tmp%timerange)
3244 call
init(v7d_tmp%timerange(itimerange))
3248 CALL
copy(v7d_tmp,v7dout,miss=.true.,lsort_timerange=.true.,lsort_level=.true.)
3253 end subroutine v7d_rounding
Classi per la gestione delle coordinate temporali.
Functions that return a trimmed CHARACTER representation of the input variable.
Legge un oggetto datetime/timedelta o un vettore di oggetti datetime/timedelta da un file FORMATTED o...
Distruttore per la classe vol7d.
Represent data in a pretty string.
Definition of constants related to I/O units.
doubleprecision data conversion
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.
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.
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'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.
Module for quickly interpreting the OPTIONAL parameters passed to a subprogram.
Check for problems return 0 if all check passed print diagnostics with log4f.
This module defines usefull general purpose function and subroutine.