libsim Versione 7.2.6
|
◆ vol7d_diff_only()
Metodo per ottenere solo le differenze tra due oggetti vol7d. Il primo volume viene confrontato col secondo; nel secondo volume ovunque i dati confrontati siano coincidenti viene impostato valore mancante.
Definizione alla linea 2489 del file vol7d_class.F90. 2490
2491if (.not. present(unit))then
2492 lunit=getunit()
2493else
2494 if (unit==0)then
2495 lunit=getunit()
2496 unit=lunit
2497 else
2498 lunit=unit
2499 end if
2500end if
2501
2502lfilename=trim(arg)//".v7d"
2504
2505if (present(filename))then
2506 if (filename /= "")then
2507 lfilename=filename
2508 end if
2509end if
2510
2511if (present(filename_auto))filename_auto=lfilename
2512
2513
2514inquire(unit=lunit,opened=opened)
2515if (.not. opened) then
2516! inquire(file=lfilename, EXIST=exist)
2517! IF (exist) THEN
2518! CALL l4f_log(L4F_FATAL, &
2519! 'in vol7d_write_on_file, file exists, cannot open file '//TRIM(lfilename))
2520! CALL raise_fatal_error()
2521! ENDIF
2522 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM')
2523 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
2524end if
2525
2526if (associated(this%ana)) nana=size(this%ana)
2527if (associated(this%time)) ntime=size(this%time)
2528if (associated(this%timerange)) ntimerange=size(this%timerange)
2529if (associated(this%level)) nlevel=size(this%level)
2530if (associated(this%network)) nnetwork=size(this%network)
2531
2532if (associated(this%dativar%r)) ndativarr=size(this%dativar%r)
2533if (associated(this%dativar%i)) ndativari=size(this%dativar%i)
2534if (associated(this%dativar%b)) ndativarb=size(this%dativar%b)
2535if (associated(this%dativar%d)) ndativard=size(this%dativar%d)
2536if (associated(this%dativar%c)) ndativarc=size(this%dativar%c)
2537
2538if (associated(this%datiattr%r)) ndatiattrr=size(this%datiattr%r)
2539if (associated(this%datiattr%i)) ndatiattri=size(this%datiattr%i)
2540if (associated(this%datiattr%b)) ndatiattrb=size(this%datiattr%b)
2541if (associated(this%datiattr%d)) ndatiattrd=size(this%datiattr%d)
2542if (associated(this%datiattr%c)) ndatiattrc=size(this%datiattr%c)
2543
2544if (associated(this%dativarattr%r)) ndativarattrr=size(this%dativarattr%r)
2545if (associated(this%dativarattr%i)) ndativarattri=size(this%dativarattr%i)
2546if (associated(this%dativarattr%b)) ndativarattrb=size(this%dativarattr%b)
2547if (associated(this%dativarattr%d)) ndativarattrd=size(this%dativarattr%d)
2548if (associated(this%dativarattr%c)) ndativarattrc=size(this%dativarattr%c)
2549
2550if (associated(this%anavar%r)) nanavarr=size(this%anavar%r)
2551if (associated(this%anavar%i)) nanavari=size(this%anavar%i)
2552if (associated(this%anavar%b)) nanavarb=size(this%anavar%b)
2553if (associated(this%anavar%d)) nanavard=size(this%anavar%d)
2554if (associated(this%anavar%c)) nanavarc=size(this%anavar%c)
2555
2556if (associated(this%anaattr%r)) nanaattrr=size(this%anaattr%r)
2557if (associated(this%anaattr%i)) nanaattri=size(this%anaattr%i)
2558if (associated(this%anaattr%b)) nanaattrb=size(this%anaattr%b)
2559if (associated(this%anaattr%d)) nanaattrd=size(this%anaattr%d)
2560if (associated(this%anaattr%c)) nanaattrc=size(this%anaattr%c)
2561
2562if (associated(this%anavarattr%r)) nanavarattrr=size(this%anavarattr%r)
2563if (associated(this%anavarattr%i)) nanavarattri=size(this%anavarattr%i)
2564if (associated(this%anavarattr%b)) nanavarattrb=size(this%anavarattr%b)
2565if (associated(this%anavarattr%d)) nanavarattrd=size(this%anavarattr%d)
2566if (associated(this%anavarattr%c)) nanavarattrc=size(this%anavarattr%c)
2567
2568write(unit=lunit)ldescription
2569write(unit=lunit)tarray
2570
2571write(unit=lunit)&
2572 nana, ntime, ntimerange, nlevel, nnetwork, &
2573 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2574 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2575 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2576 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2577 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2578 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
2579 this%time_definition
2580
2581
2582!write(unit=lunit)this
2583
2584
2585!! prime 5 dimensioni
2586if (associated(this%ana)) call write_unit(this%ana, lunit)
2587if (associated(this%time)) call write_unit(this%time, lunit)
2588if (associated(this%level)) write(unit=lunit)this%level
2589if (associated(this%timerange)) write(unit=lunit)this%timerange
2590if (associated(this%network)) write(unit=lunit)this%network
2591
2592 !! 6a dimensione: variabile dell'anagrafica e dei dati
2593 !! con relativi attributi e in 5 tipi diversi
2594
2595if (associated(this%anavar%r)) write(unit=lunit)this%anavar%r
2596if (associated(this%anavar%i)) write(unit=lunit)this%anavar%i
2597if (associated(this%anavar%b)) write(unit=lunit)this%anavar%b
2598if (associated(this%anavar%d)) write(unit=lunit)this%anavar%d
2599if (associated(this%anavar%c)) write(unit=lunit)this%anavar%c
2600
2601if (associated(this%anaattr%r)) write(unit=lunit)this%anaattr%r
2602if (associated(this%anaattr%i)) write(unit=lunit)this%anaattr%i
2603if (associated(this%anaattr%b)) write(unit=lunit)this%anaattr%b
2604if (associated(this%anaattr%d)) write(unit=lunit)this%anaattr%d
2605if (associated(this%anaattr%c)) write(unit=lunit)this%anaattr%c
2606
2607if (associated(this%anavarattr%r)) write(unit=lunit)this%anavarattr%r
2608if (associated(this%anavarattr%i)) write(unit=lunit)this%anavarattr%i
2609if (associated(this%anavarattr%b)) write(unit=lunit)this%anavarattr%b
2610if (associated(this%anavarattr%d)) write(unit=lunit)this%anavarattr%d
2611if (associated(this%anavarattr%c)) write(unit=lunit)this%anavarattr%c
2612
2613if (associated(this%dativar%r)) write(unit=lunit)this%dativar%r
2614if (associated(this%dativar%i)) write(unit=lunit)this%dativar%i
2615if (associated(this%dativar%b)) write(unit=lunit)this%dativar%b
2616if (associated(this%dativar%d)) write(unit=lunit)this%dativar%d
2617if (associated(this%dativar%c)) write(unit=lunit)this%dativar%c
2618
2619if (associated(this%datiattr%r)) write(unit=lunit)this%datiattr%r
2620if (associated(this%datiattr%i)) write(unit=lunit)this%datiattr%i
2621if (associated(this%datiattr%b)) write(unit=lunit)this%datiattr%b
2622if (associated(this%datiattr%d)) write(unit=lunit)this%datiattr%d
2623if (associated(this%datiattr%c)) write(unit=lunit)this%datiattr%c
2624
2625if (associated(this%dativarattr%r)) write(unit=lunit)this%dativarattr%r
2626if (associated(this%dativarattr%i)) write(unit=lunit)this%dativarattr%i
2627if (associated(this%dativarattr%b)) write(unit=lunit)this%dativarattr%b
2628if (associated(this%dativarattr%d)) write(unit=lunit)this%dativarattr%d
2629if (associated(this%dativarattr%c)) write(unit=lunit)this%dativarattr%c
2630
2631!! Volumi di valori e attributi per anagrafica e dati
2632
2633if (associated(this%volanar)) write(unit=lunit)this%volanar
2634if (associated(this%volanaattrr)) write(unit=lunit)this%volanaattrr
2635if (associated(this%voldatir)) write(unit=lunit)this%voldatir
2636if (associated(this%voldatiattrr)) write(unit=lunit)this%voldatiattrr
2637
2638if (associated(this%volanai)) write(unit=lunit)this%volanai
2639if (associated(this%volanaattri)) write(unit=lunit)this%volanaattri
2640if (associated(this%voldatii)) write(unit=lunit)this%voldatii
2641if (associated(this%voldatiattri)) write(unit=lunit)this%voldatiattri
2642
2643if (associated(this%volanab)) write(unit=lunit)this%volanab
2644if (associated(this%volanaattrb)) write(unit=lunit)this%volanaattrb
2645if (associated(this%voldatib)) write(unit=lunit)this%voldatib
2646if (associated(this%voldatiattrb)) write(unit=lunit)this%voldatiattrb
2647
2648if (associated(this%volanad)) write(unit=lunit)this%volanad
2649if (associated(this%volanaattrd)) write(unit=lunit)this%volanaattrd
2650if (associated(this%voldatid)) write(unit=lunit)this%voldatid
2651if (associated(this%voldatiattrd)) write(unit=lunit)this%voldatiattrd
2652
2653if (associated(this%volanac)) write(unit=lunit)this%volanac
2654if (associated(this%volanaattrc)) write(unit=lunit)this%volanaattrc
2655if (associated(this%voldatic)) write(unit=lunit)this%voldatic
2656if (associated(this%voldatiattrc)) write(unit=lunit)this%voldatiattrc
2657
2658if (.not. present(unit)) close(unit=lunit)
2659
2660end subroutine vol7d_write_on_file
2661
2662
2663!>\brief Lettura da file di un volume Vol7d.
2664!! Lettura da file unformatted di un intero volume Vol7d.
2665!! Questa subroutine comprende vol7d_alloc e vol7d_alloc_vol.
2666!! Il file puo' essere aperto opzionalmente dall'utente. Si possono passare
2667!! opzionalmente unità e nome del file altrimenti assegnati internamente a dei default; se assegnati internamente
2668!! tali parametri saranno in output.
2669
2670
2671subroutine vol7d_read_from_file (this,unit,filename,description,tarray,filename_auto)
2672
2673TYPE(vol7d),INTENT(OUT) :: this !< Volume vol7d da leggere
2674integer,intent(inout),optional :: unit !< unità su cui è stato aperto un file; se =0 rielaborato internamente (default = elaborato internamente con getunit)
2675character(len=*),INTENT(in),optional :: filename !< nome del file eventualmente da aprire (default = (nome dell'eseguibile)//.v7d )
2676character(len=*),intent(out),optional :: filename_auto !< nome del file generato se "filename" è omesso
2677character(len=*),INTENT(out),optional :: description !< descrizione del volume letto
2678integer,intent(out),optional :: tarray(8) !< vettore come definito da "date_and_time" della data di scrittura del volume
2679
2680
2681integer :: nana, ntime, ntimerange, nlevel, nnetwork, &
2682 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2683 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2684 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2685 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2686 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2687 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
2688
2689character(len=254) :: ldescription,lfilename,arg
2690integer :: ltarray(8),lunit,ios
2691logical :: opened,exist
2692
2693
2694call getarg(0,arg)
2695
2696if (.not. present(unit))then
2697 lunit=getunit()
2698else
2699 if (unit==0)then
2700 lunit=getunit()
2701 unit=lunit
2702 else
2703 lunit=unit
2704 end if
2705end if
2706
2707lfilename=trim(arg)//".v7d"
2709
2710if (present(filename))then
2711 if (filename /= "")then
2712 lfilename=filename
2713 end if
2714end if
2715
2716if (present(filename_auto))filename_auto=lfilename
2717
2718
2719inquire(unit=lunit,opened=opened)
2720IF (.NOT. opened) THEN
2721 inquire(file=lfilename,exist=exist)
2722 IF (.NOT.exist) THEN
2723 CALL l4f_log(l4f_fatal, &
2724 'in vol7d_read_from_file, file does not exists, cannot open')
2725 CALL raise_fatal_error()
2726 ENDIF
2727 OPEN(unit=lunit, file=lfilename, form='UNFORMATTED', access='STREAM', &
2728 status='OLD', action='READ')
2729 CALL l4f_log(l4f_info, 'opened: '//trim(lfilename))
2730end if
2731
2732
2733call init(this)
2734read(unit=lunit,iostat=ios)ldescription
2735
2736if (ios < 0) then ! A negative value indicates that the End of File or End of Record
2737 call vol7d_alloc (this)
2738 call vol7d_alloc_vol (this)
2739 if (present(description))description=ldescription
2740 if (present(tarray))tarray=ltarray
2741 if (.not. present(unit)) close(unit=lunit)
2742end if
2743
2744read(unit=lunit)ltarray
2745
2746CALL l4f_log(l4f_info, 'Reading vol7d from file')
2747CALL l4f_log(l4f_info, 'description: '//trim(ldescription))
2748CALL l4f_log(l4f_info, 'written on '//trim(to_char(ltarray(1)))//' '// &
2749 trim(to_char(ltarray(2)))//' '//trim(to_char(ltarray(3))))
2750
2751if (present(description))description=ldescription
2752if (present(tarray))tarray=ltarray
2753
2754read(unit=lunit)&
2755 nana, ntime, ntimerange, nlevel, nnetwork, &
2756 ndativarr, ndativari, ndativarb, ndativard, ndativarc,&
2757 ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc,&
2758 ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc,&
2759 nanavarr, nanavari, nanavarb, nanavard, nanavarc,&
2760 nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc,&
2761 nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc, &
2762 this%time_definition
2763
2764call vol7d_alloc (this, &
2765 nana=nana, ntime=ntime, ntimerange=ntimerange, nlevel=nlevel, nnetwork=nnetwork,&
2766 ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb,&
2767 ndativard=ndativard, ndativarc=ndativarc,&
2768 ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb,&
2769 ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
2770 ndativarattrr=ndativarattrr, ndativarattri=ndativarattri, ndativarattrb=ndativarattrb, &
2771 ndativarattrd=ndativarattrd, ndativarattrc=ndativarattrc,&
2772 nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, &
2773 nanavard=nanavard, nanavarc=nanavarc,&
2774 nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb,&
2775 nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
2776 nanavarattrr=nanavarattrr, nanavarattri=nanavarattri, nanavarattrb=nanavarattrb, &
2777 nanavarattrd=nanavarattrd, nanavarattrc=nanavarattrc)
2778
2779
2780if (associated(this%ana)) call read_unit(this%ana, lunit)
2781if (associated(this%time)) call read_unit(this%time, lunit)
2782if (associated(this%level)) read(unit=lunit)this%level
2783if (associated(this%timerange)) read(unit=lunit)this%timerange
2784if (associated(this%network)) read(unit=lunit)this%network
2785
2786if (associated(this%anavar%r)) read(unit=lunit)this%anavar%r
2787if (associated(this%anavar%i)) read(unit=lunit)this%anavar%i
2788if (associated(this%anavar%b)) read(unit=lunit)this%anavar%b
2789if (associated(this%anavar%d)) read(unit=lunit)this%anavar%d
2790if (associated(this%anavar%c)) read(unit=lunit)this%anavar%c
2791
2792if (associated(this%anaattr%r)) read(unit=lunit)this%anaattr%r
2793if (associated(this%anaattr%i)) read(unit=lunit)this%anaattr%i
2794if (associated(this%anaattr%b)) read(unit=lunit)this%anaattr%b
2795if (associated(this%anaattr%d)) read(unit=lunit)this%anaattr%d
2796if (associated(this%anaattr%c)) read(unit=lunit)this%anaattr%c
2797
2798if (associated(this%anavarattr%r)) read(unit=lunit)this%anavarattr%r
2799if (associated(this%anavarattr%i)) read(unit=lunit)this%anavarattr%i
2800if (associated(this%anavarattr%b)) read(unit=lunit)this%anavarattr%b
2801if (associated(this%anavarattr%d)) read(unit=lunit)this%anavarattr%d
2802if (associated(this%anavarattr%c)) read(unit=lunit)this%anavarattr%c
2803
2804if (associated(this%dativar%r)) read(unit=lunit)this%dativar%r
2805if (associated(this%dativar%i)) read(unit=lunit)this%dativar%i
2806if (associated(this%dativar%b)) read(unit=lunit)this%dativar%b
2807if (associated(this%dativar%d)) read(unit=lunit)this%dativar%d
2808if (associated(this%dativar%c)) read(unit=lunit)this%dativar%c
2809
2810if (associated(this%datiattr%r)) read(unit=lunit)this%datiattr%r
2811if (associated(this%datiattr%i)) read(unit=lunit)this%datiattr%i
2812if (associated(this%datiattr%b)) read(unit=lunit)this%datiattr%b
2813if (associated(this%datiattr%d)) read(unit=lunit)this%datiattr%d
2814if (associated(this%datiattr%c)) read(unit=lunit)this%datiattr%c
2815
2816if (associated(this%dativarattr%r)) read(unit=lunit)this%dativarattr%r
2817if (associated(this%dativarattr%i)) read(unit=lunit)this%dativarattr%i
2818if (associated(this%dativarattr%b)) read(unit=lunit)this%dativarattr%b
2819if (associated(this%dativarattr%d)) read(unit=lunit)this%dativarattr%d
2820if (associated(this%dativarattr%c)) read(unit=lunit)this%dativarattr%c
2821
2822call vol7d_alloc_vol (this)
2823
2824!! Volumi di valori e attributi per anagrafica e dati
2825
2826if (associated(this%volanar)) read(unit=lunit)this%volanar
2827if (associated(this%volanaattrr)) read(unit=lunit)this%volanaattrr
2828if (associated(this%voldatir)) read(unit=lunit)this%voldatir
2829if (associated(this%voldatiattrr)) read(unit=lunit)this%voldatiattrr
2830
2831if (associated(this%volanai)) read(unit=lunit)this%volanai
2832if (associated(this%volanaattri)) read(unit=lunit)this%volanaattri
2833if (associated(this%voldatii)) read(unit=lunit)this%voldatii
2834if (associated(this%voldatiattri)) read(unit=lunit)this%voldatiattri
2835
2836if (associated(this%volanab)) read(unit=lunit)this%volanab
2837if (associated(this%volanaattrb)) read(unit=lunit)this%volanaattrb
2838if (associated(this%voldatib)) read(unit=lunit)this%voldatib
2839if (associated(this%voldatiattrb)) read(unit=lunit)this%voldatiattrb
2840
2841if (associated(this%volanad)) read(unit=lunit)this%volanad
2842if (associated(this%volanaattrd)) read(unit=lunit)this%volanaattrd
2843if (associated(this%voldatid)) read(unit=lunit)this%voldatid
2844if (associated(this%voldatiattrd)) read(unit=lunit)this%voldatiattrd
2845
2846if (associated(this%volanac)) read(unit=lunit)this%volanac
2847if (associated(this%volanaattrc)) read(unit=lunit)this%volanaattrc
2848if (associated(this%voldatic)) read(unit=lunit)this%voldatic
2849if (associated(this%voldatiattrc)) read(unit=lunit)this%voldatiattrc
2850
2851if (.not. present(unit)) close(unit=lunit)
2852
2853end subroutine vol7d_read_from_file
2854
2855
2856! to double precision
2857elemental doubleprecision function doubledatd(voldat,var)
2858doubleprecision,intent(in) :: voldat
2859type(vol7d_var),intent(in) :: var
2860
2861doubledatd=voldat
2862
2863end function doubledatd
2864
2865
2866elemental doubleprecision function doubledatr(voldat,var)
2867real,intent(in) :: voldat
2868type(vol7d_var),intent(in) :: var
2869
2870if (c_e(voldat))then
2871 doubledatr=dble(voldat)
2872else
2873 doubledatr=dmiss
2874end if
2875
2876end function doubledatr
2877
2878
2879elemental doubleprecision function doubledati(voldat,var)
2880integer,intent(in) :: voldat
2881type(vol7d_var),intent(in) :: var
2882
2883if (c_e(voldat)) then
2884 if (c_e(var%scalefactor))then
2885 doubledati=dble(voldat)/10.d0**var%scalefactor
2886 else
2887 doubledati=dble(voldat)
2888 endif
2889else
2890 doubledati=dmiss
2891end if
2892
2893end function doubledati
2894
2895
2896elemental doubleprecision function doubledatb(voldat,var)
2897integer(kind=int_b),intent(in) :: voldat
2898type(vol7d_var),intent(in) :: var
2899
2900if (c_e(voldat)) then
2901 if (c_e(var%scalefactor))then
2902 doubledatb=dble(voldat)/10.d0**var%scalefactor
2903 else
2904 doubledatb=dble(voldat)
2905 endif
2906else
2907 doubledatb=dmiss
2908end if
2909
2910end function doubledatb
2911
2912
2913elemental doubleprecision function doubledatc(voldat,var)
2914CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
2915type(vol7d_var),intent(in) :: var
2916
2917doubledatc = c2d(voldat)
2918if (c_e(doubledatc) .and. c_e(var%scalefactor))then
2919 doubledatc=doubledatc/10.d0**var%scalefactor
2920end if
2921
2922end function doubledatc
2923
2924
2925! to integer
2926elemental integer function integerdatd(voldat,var)
2927doubleprecision,intent(in) :: voldat
2928type(vol7d_var),intent(in) :: var
2929
2930if (c_e(voldat))then
2931 if (c_e(var%scalefactor)) then
2932 integerdatd=nint(voldat*10d0**var%scalefactor)
2933 else
2934 integerdatd=nint(voldat)
2935 endif
2936else
2937 integerdatd=imiss
2938end if
2939
2940end function integerdatd
2941
2942
2943elemental integer function integerdatr(voldat,var)
2944real,intent(in) :: voldat
2945type(vol7d_var),intent(in) :: var
2946
2947if (c_e(voldat))then
2948 if (c_e(var%scalefactor)) then
2949 integerdatr=nint(voldat*10d0**var%scalefactor)
2950 else
2951 integerdatr=nint(voldat)
2952 endif
2953else
2954 integerdatr=imiss
2955end if
2956
2957end function integerdatr
2958
2959
2960elemental integer function integerdati(voldat,var)
2961integer,intent(in) :: voldat
2962type(vol7d_var),intent(in) :: var
2963
2964integerdati=voldat
2965
2966end function integerdati
2967
2968
2969elemental integer function integerdatb(voldat,var)
2970integer(kind=int_b),intent(in) :: voldat
2971type(vol7d_var),intent(in) :: var
2972
2973if (c_e(voldat))then
2974 integerdatb=voldat
2975else
2976 integerdatb=imiss
2977end if
2978
2979end function integerdatb
2980
2981
2982elemental integer function integerdatc(voldat,var)
2983CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
2984type(vol7d_var),intent(in) :: var
2985
2986integerdatc=c2i(voldat)
2987
2988end function integerdatc
2989
2990
2991! to real
2992elemental real function realdatd(voldat,var)
2993doubleprecision,intent(in) :: voldat
2994type(vol7d_var),intent(in) :: var
2995
2996if (c_e(voldat))then
2997 realdatd=real(voldat)
2998else
2999 realdatd=rmiss
3000end if
3001
3002end function realdatd
3003
3004
3005elemental real function realdatr(voldat,var)
3006real,intent(in) :: voldat
3007type(vol7d_var),intent(in) :: var
3008
3009realdatr=voldat
3010
3011end function realdatr
3012
3013
3014elemental real function realdati(voldat,var)
3015integer,intent(in) :: voldat
3016type(vol7d_var),intent(in) :: var
3017
3018if (c_e(voldat)) then
3019 if (c_e(var%scalefactor))then
3020 realdati=float(voldat)/10.**var%scalefactor
3021 else
3022 realdati=float(voldat)
3023 endif
3024else
3025 realdati=rmiss
3026end if
3027
3028end function realdati
3029
3030
3031elemental real function realdatb(voldat,var)
3032integer(kind=int_b),intent(in) :: voldat
3033type(vol7d_var),intent(in) :: var
3034
3035if (c_e(voldat)) then
3036 if (c_e(var%scalefactor))then
3037 realdatb=float(voldat)/10**var%scalefactor
3038 else
3039 realdatb=float(voldat)
3040 endif
3041else
3042 realdatb=rmiss
3043end if
3044
3045end function realdatb
3046
3047
3048elemental real function realdatc(voldat,var)
3049CHARACTER(len=vol7d_cdatalen),intent(in) :: voldat
3050type(vol7d_var),intent(in) :: var
3051
3052realdatc=c2r(voldat)
3053if (c_e(realdatc) .and. c_e(var%scalefactor))then
3054 realdatc=realdatc/10.**var%scalefactor
3055end if
3056
3057end function realdatc
3058
3059
3060!> Return an ana volume of a requested variable as real data.
3061!! It returns a 2-d array of the proper shape (ana x network) for the
3062!! ana variable requested, converted to real type. If the conversion
3063!! fails or if the variable is not contained in the ana volume,
3064!! missing data are returned.
3065FUNCTION realanavol(this, var) RESULT(vol)
3066TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
3067TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
3068REAL :: vol(SIZE(this%ana),size(this%network))
3069
3070CHARACTER(len=1) :: dtype
3071INTEGER :: indvar
3072
3073dtype = cmiss
3074indvar = index(this%anavar, var, type=dtype)
3075
3076IF (indvar > 0) THEN
3077 SELECT CASE (dtype)
3078 CASE("d")
3079 vol = realdat(this%volanad(:,indvar,:), var)
3080 CASE("r")
3081 vol = this%volanar(:,indvar,:)
3082 CASE("i")
3083 vol = realdat(this%volanai(:,indvar,:), var)
3084 CASE("b")
3085 vol = realdat(this%volanab(:,indvar,:), var)
3086 CASE("c")
3087 vol = realdat(this%volanac(:,indvar,:), var)
3088 CASE default
3089 vol = rmiss
3090 END SELECT
3091ELSE
3092 vol = rmiss
3093ENDIF
3094
3095END FUNCTION realanavol
3096
3097
3098!> Return an ana volume of a requested variable as integer data.
3099!! It returns a 2-d array of the proper shape (ana x network) for the
3100!! ana variable requested, converted to integer type. If the conversion
3101!! fails or if the variable is not contained in the ana volume,
3102!! missing data are returned.
3103FUNCTION integeranavol(this, var) RESULT(vol)
3104TYPE(vol7d),INTENT(in) :: this !< the \a vol7d object to query, the method \a vol7d_alloc_vol must have been called for it otherwise progam may abort
3105TYPE(vol7d_var),INTENT(in) :: var !< the ana variable to be returned
3106INTEGER :: vol(SIZE(this%ana),size(this%network))
3107
3108CHARACTER(len=1) :: dtype
3109INTEGER :: indvar
3110
3111dtype = cmiss
3112indvar = index(this%anavar, var, type=dtype)
3113
3114IF (indvar > 0) THEN
3115 SELECT CASE (dtype)
3116 CASE("d")
3117 vol = integerdat(this%volanad(:,indvar,:), var)
3118 CASE("r")
3119 vol = integerdat(this%volanar(:,indvar,:), var)
3120 CASE("i")
3121 vol = this%volanai(:,indvar,:)
3122 CASE("b")
3123 vol = integerdat(this%volanab(:,indvar,:), var)
3124 CASE("c")
3125 vol = integerdat(this%volanac(:,indvar,:), var)
3126 CASE default
3127 vol = imiss
3128 END SELECT
3129ELSE
3130 vol = imiss
3131ENDIF
3132
3133END FUNCTION integeranavol
3134
3135
3136!> Move data for all variables from one coordinate in the character volume to other.
3137!! Only not missing data will be copyed and all attributes will be moved together.
3138!! Usefull to colapse data spread in more indices (level or time or ....).
3139!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
3140!! to obtain a new vol7d with less data shape.
3141subroutine move_datac (v7d,&
3142 indana,indtime,indlevel,indtimerange,indnetwork,&
3143 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
3144
3145TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
3146
3147integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
3148integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
3149integer :: inddativar,inddativarattr
3150
3151
3152do inddativar=1,size(v7d%dativar%c)
3153
3154 if (c_e(v7d%voldatic(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
3155 .not. c_e(v7d%voldatic(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
3156 ) then
3157
3158 ! dati
3159 v7d%voldatic &
3160 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
3161 v7d%voldatic &
3162 (indana,indtime,indlevel,indtimerange,inddativar,indnetwork)
3163
3164
3165 ! attributi
3166 if (associated (v7d%dativarattr%i)) then
3167 inddativarattr = index(v7d%dativarattr%i,v7d%dativar%c(inddativar))
3168 if (inddativarattr > 0 ) then
3169 v7d%voldatiattri &
3170 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3171 v7d%voldatiattri &
3172 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3173 end if
3174 end if
3175
3176 if (associated (v7d%dativarattr%r)) then
3177 inddativarattr = index(v7d%dativarattr%r,v7d%dativar%c(inddativar))
3178 if (inddativarattr > 0 ) then
3179 v7d%voldatiattrr &
3180 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3181 v7d%voldatiattrr &
3182 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3183 end if
3184 end if
3185
3186 if (associated (v7d%dativarattr%d)) then
3187 inddativarattr = index(v7d%dativarattr%d,v7d%dativar%c(inddativar))
3188 if (inddativarattr > 0 ) then
3189 v7d%voldatiattrd &
3190 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3191 v7d%voldatiattrd &
3192 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3193 end if
3194 end if
3195
3196 if (associated (v7d%dativarattr%b)) then
3197 inddativarattr = index(v7d%dativarattr%b,v7d%dativar%c(inddativar))
3198 if (inddativarattr > 0 ) then
3199 v7d%voldatiattrb &
3200 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3201 v7d%voldatiattrb &
3202 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3203 end if
3204 end if
3205
3206 if (associated (v7d%dativarattr%c)) then
3207 inddativarattr = index(v7d%dativarattr%c,v7d%dativar%c(inddativar))
3208 if (inddativarattr > 0 ) then
3209 v7d%voldatiattrc &
3210 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativarattr,indnetworknew,:) = &
3211 v7d%voldatiattrc &
3212 (indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,:)
3213 end if
3214 end if
3215
3216 end if
3217
3218end do
3219
3220end subroutine move_datac
3221
3222!> Move data for all variables from one coordinate in the real volume to other.
3223!! Only not missing data will be copyed and all attributes will be moved together.
3224!! Usefull to colapse data spread in more indices (level or time or ....).
3225!! After the move is possible to set to missing some descriptor and make a copy with miss=.true.
3226!! to obtain a new vol7d with less data shape.
3227subroutine move_datar (v7d,&
3228 indana,indtime,indlevel,indtimerange,indnetwork,&
3229 indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew)
3230
3231TYPE(vol7d),intent(inout) :: v7d !< data in form of character in this object will be moved
3232
3233integer,intent(in) :: indana,indtime,indlevel,indtimerange,indnetwork !< source coordinate of the data
3234integer,intent(in) :: indananew,indtimenew,indlevelnew,indtimerangenew,indnetworknew !< destination coordinate of data
3235integer :: inddativar,inddativarattr
3236
3237
3238do inddativar=1,size(v7d%dativar%r)
3239
3240 if (c_e(v7d%voldatir(indana,indtime,indlevel,indtimerange,inddativar,indnetwork)) .and. &
3241 .not. c_e(v7d%voldatir(indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew))&
3242 ) then
3243
3244 ! dati
3245 v7d%voldatir &
3246 (indananew,indtimenew,indlevelnew,indtimerangenew,inddativar,indnetworknew) = &
3247 v7d%voldatir &
|