libsim Versione 7.1.11
|
◆ vol7d_dballe_export_old()
Exporta un volume dati a un DSN DB-all.e. Riscrive i dati nel DSN di DB-All.e con la possibilità di attivare una serie di filtri.
Definizione alla linea 2642 del file vol7d_dballe_class.F03. 2644! Copyright (C) 2010 ARPA-SIM <urpsim@smr.arpa.emr.it>
2645! authors:
2646! Davide Cesari <dcesari@arpa.emr.it>
2647! Paolo Patruno <ppatruno@arpa.emr.it>
2648
2649! This program is free software; you can redistribute it and/or
2650! modify it under the terms of the GNU General Public License as
2651! published by the Free Software Foundation; either version 2 of
2652! the License, or (at your option) any later version.
2653
2654! This program is distributed in the hope that it will be useful,
2655! but WITHOUT ANY WARRANTY; without even the implied warranty of
2656! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
2657! GNU General Public License for more details.
2658
2659! You should have received a copy of the GNU General Public License
2660! along with this program. If not, see <http://www.gnu.org/licenses/>.
2661
2662#include "config.h"
2663
2720
2722
2729!use list_mix
2732use vol7d_serialize_dballe_class
2733
2734IMPLICIT NONE
2735
2736character (len=255),parameter:: subcategory="vol7d_dballe_class"
2737
2744
2746
2747 TYPE(vol7d) :: vol7d
2748 type(dbaconnection) :: idbhandle
2749 type(dbasession) :: handle
2752 integer ,pointer :: data_id(:,:,:,:,:)
2753 integer :: time_definition
2754 integer :: category = 0
2755 logical :: file
2756
2758
2759INTEGER, PARAMETER, PRIVATE :: nftype = 2
2760CHARACTER(len=16), PARAMETER, PRIVATE :: &
2761 pathlist(2,nftype) = reshape((/ &
2762 '/usr/share ', '/usr/local/share', &
2763 '/etc ', '/usr/local/etc ' /), &
2764 (/2,nftype/))
2765
2766
2767type(vol7d_var),allocatable,private :: blocal(:) ! cache of dballe.txt
2768
2769CHARACTER(len=20),PRIVATE :: dballe_name='wreport', dballe_name_env='DBA_TABLES'
2770
2771
2774 MODULE PROCEDURE vol7d_dballe_init
2776
2779 MODULE PROCEDURE vol7d_dballe_delete
2781
2782
2784INTERFACE import
2785 MODULE PROCEDURE vol7d_dballe_importvvnv,vol7d_dballe_import, vol7d_dballe_import_old, dba2v7d
2786END INTERFACE import
2787
2790 MODULE PROCEDURE vol7d_dballe_export_old,vol7d_dballe_export, v7d2dba
2792
2793
2794PRIVATE
2795PUBLIC vol7d_dballe, init, delete, import, export, vol7d_dballe_import_dballevar, vol7d_dballe_set_var_du
2796
2797CONTAINS
2798
2799
2801SUBROUTINE vol7d_dballe_init(this,dsn,user,password,write,wipe,repinfo,&
2802 filename,format,file,categoryappend,time_definition,idbhandle,template)
2803
2804
2805TYPE(vol7d_dballe),INTENT(out) :: this
2806character(len=*), INTENT(in),OPTIONAL :: dsn
2807character(len=*), INTENT(in),OPTIONAL :: user
2808character(len=*), INTENT(in),OPTIONAL :: password
2809logical,INTENT(in),OPTIONAL :: write
2810logical,INTENT(in),OPTIONAL :: wipe
2811character(len=*), INTENT(in),OPTIONAL :: repinfo
2812character(len=*),intent(inout),optional :: filename
2813character(len=*),intent(in),optional :: format
2814logical,INTENT(in),OPTIONAL :: file
2815character(len=*),INTENT(in),OPTIONAL :: categoryappend
2816integer,INTENT(in),OPTIONAL :: time_definition
2817integer,INTENT(in),OPTIONAL :: idbhandle
2820character(len=*),intent(in),optional :: template
2821
2822logical :: quiwrite,loadfile
2823character(len=512) :: a_name
2824character(len=254) :: arg,lfilename,lformat
2825
2826quiwrite=.false.
2827if (present(write))then
2828 quiwrite=write
2829endif
2830
2831if (present(categoryappend))then
2832 call l4f_launcher(a_name,a_name_append=trim(subcategory)//"."//trim(categoryappend))
2833else
2834 call l4f_launcher(a_name,a_name_append=trim(subcategory))
2835endif
2836this%category=l4f_category_get(a_name)
2837
2838#ifdef DEBUG
2840#endif
2841
2842nullify(this%data_id)
2843
2844if (optio_log(file)) then
2845
2846 this%file=.true.
2847
2848 lformat="BUFR"
2849 if (present(format))then
2850 lformat=format
2851 end if
2852
2853 CALL getarg(0,arg)
2854
2855 lfilename=trim(arg)//"."//trim(lformat)
2857
2858 if (present(filename))then
2860 lfilename=filename
2861 end if
2862 end if
2863
2864 if(quiwrite)then
2865 ! this for write in memdb and write file on export
2866 loadfile=.false.
2867 else
2868 loadfile=.true.
2869 end if
2870
2871 this%handle=dbasession(wipe=wipe,write=quiwrite,repinfo=repinfo, &
2872 filename=lfilename,format=lformat,template=template, &
2873 memdb=.true.,loadfile=loadfile)
2874
2875else
2876
2877 this%file=.false.
2878 this%idbhandle=dbaconnection(dsn,user,password,idbhandle=idbhandle)
2879 this%handle=dbasession(this%idbhandle,wipe=wipe,write=quiwrite,repinfo=repinfo)
2880
2881endif
2882
2883! this init has been added here for cleaningness, this%vol7d gets
2884! reinitialised afterwards in dba2v7d and this%vol7d%time_definition is
2885! overwritten by this%time_definition, this duplication is required in
2886! order to pass time_definition down to dba2v7d
2888this%time_definition = optio_i(time_definition)
2889
2890#ifdef DEBUG
2892#endif
2893
2894END SUBROUTINE vol7d_dballe_init
2895
2896
2897
2901
2902SUBROUTINE vol7d_dballe_importvvnv(this, var, network, coordmin,coordmax, timei, timef, level,timerange,set_network,&
2903 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana)
2904TYPE(vol7d_dballe),INTENT(inout) :: this
2905CHARACTER(len=*),INTENT(in) :: var(:)
2906TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
2907TYPE(vol7d_ana),INTENT(inout),optional :: ana
2908TYPE(datetime),INTENT(in),optional :: timei, timef
2909TYPE(vol7d_network),INTENT(in) :: network(:)
2910TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
2911TYPE(vol7d_level),INTENT(in),optional :: level
2912TYPE(vol7d_timerange),INTENT(in),optional :: timerange
2913CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
2914CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
2915logical,intent(in),optional :: anaonly
2916LOGICAL,INTENT(in),OPTIONAL :: dataonly
2917TYPE(vol7d_dballe) :: v7ddbatmp
2918
2919INTEGER :: i
2920
2921IF (SIZE(network) == 0 )THEN
2923 timef=timef, level=level, timerange=timerange, set_network=set_network, &
2924 attr=attr, anavar=anavar, anaattr=anaattr, varkind=varkind, attrkind=attrkind, &
2925 anavarkind=anavarkind, anaattrkind=anaattrkind, anaonly=anaonly, &
2926 dataonly=dataonly, ana=ana)
2927ELSE
2929 v7ddbatmp = this ! shallow copy
2930 DO i = 1, SIZE(network)
2932 level,timerange, set_network, attr,anavar,anaattr, varkind, attrkind, &
2933 anavarkind, anaattrkind, anaonly, dataonly, ana)
2935 ENDDO
2936ENDIF
2937
2938END SUBROUTINE vol7d_dballe_importvvnv
2939
2941SUBROUTINE vol7d_dballe_import_old(this, var, network, coordmin, coordmax, timei, timef,level,timerange, set_network,&
2942 attr,anavar,anaattr, varkind,attrkind,anavarkind,anaattrkind,anaonly,dataonly,ana)
2943
2944TYPE(vol7d_dballe),INTENT(inout) :: this
2945CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:)
2946TYPE(geo_coord),INTENT(inout),optional :: coordmin,coordmax
2947TYPE(vol7d_ana),INTENT(inout),optional :: ana
2948TYPE(datetime),INTENT(in),OPTIONAL :: timei, timef
2949TYPE(vol7d_network),INTENT(in),OPTIONAL :: network,set_network
2950TYPE(vol7d_level),INTENT(in),optional :: level
2951TYPE(vol7d_timerange),INTENT(in),optional :: timerange
2952CHARACTER(len=*),INTENT(in),OPTIONAL :: attr(:),anavar(:),anaattr(:)
2953CHARACTER(len=*),INTENT(in),OPTIONAL :: varkind(:),attrkind(:),anavarkind(:),anaattrkind(:)
2954logical,intent(in),optional :: anaonly
2955logical,intent(in),optional :: dataonly
2956
2957
2958INTEGER,PARAMETER :: maxvarlist=100
2959 !TYPE(vol7d) :: v7d
2960 ! da non fare (con gfortran?)!!!!!
2961 !CHARACTER(len=SIZE(var)*7) :: varlist
2962 !CHARACTER(len=SIZE(attr)*8) :: starvarlist
2963
2964LOGICAL :: ldegnet
2965
2966INTEGER :: i
2967integer :: nvar
2968integer :: nanavar
2969
2970 !CHARACTER(len=10),allocatable :: lvar(:), lanavar(:)
2971type(dbadcv) :: vars,starvars,anavars,anastarvars
2972type(dbafilter) :: filter
2973type(dbacoord) :: mydbacoordmin, mydbacoordmax
2974type(dbaana) :: mydbaana
2975type(dbadatetime) :: mydatetimemin, mydatetimemax
2976type(dbatimerange) :: mydbatimerange
2977type(dbalevel) :: mydbalevel
2978type(dbanetwork) :: mydbanetwork
2979
2980integer :: nanaattr,nattr
2981
2982character(len=40) :: query
2983
2984#ifdef DEBUG
2986#endif
2987
2988
2989IF (PRESENT(set_network)) THEN
2991 ldegnet = .true.
2992 else
2993 ldegnet = .false.
2994 end if
2995ELSE
2996 ldegnet = .false.
2997ENDIF
2998
2999if(ldegnet) then
3000 query = "best"
3001else
3002 query=cmiss
3003end if
3004
3005
3006 ! uncommenti this if you want compatibility API with old import
3007
3008!!$ if (allocated(starvars%dcv)) then
3009!!$ ldataonly=.false.
3010!!$ else
3011!!$ ldataonly=.true.
3012!!$ end if
3013
3014
3015!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
3016 ! ------------- prepare filter options
3017
3018!!
3019!! translate import option for dballe2003 api
3020!!
3021
3022if (present(var)) then
3023 nvar=count(c_e(var))
3024 if (nvar > 0) then
3025 allocate (vars%dcv(nvar))
3026 do i=1,size(var)
3028 if (present(varkind))then
3029 select case (varkind(i))
3030 case("r")
3032 case("i")
3034 case("b")
3036 case("d")
3038 case("c")
3040 case default
3042 CALL raise_fatal_error()
3043 end select
3044 else
3046 end if
3047 end if
3048 end do
3049 end if
3050end if
3051
3052if (present(anavar)) then
3053 nanavar=count(c_e(anavar))
3054 if (nanavar > 0) then
3055 allocate (anavars%dcv(nanavar))
3056 do i=1,size(anavar)
3058 if (present(anavarkind))then
3059 select case (anavarkind(i))
3060 case("r")
3062 case("i")
3064 case("b")
3066 case("d")
3068 case("c")
3070 case default
3072 CALL raise_fatal_error()
3073 end select
3074 else
3076 end if
3077 end if
3078 end do
3079 end if
3080end if
3081
3082if (present(attr)) then
3083 nattr=size(attr)
3084 if (nattr == 0) then
3085 allocate (starvars%dcv(nattr))
3086 else
3087 nattr=count(c_e(attr))
3088 if (nattr > 0) then
3089 allocate (starvars%dcv(nattr))
3090 do i=1,size(attr)
3092 if (present(attrkind))then
3093 select case (attrkind(i))
3094 case("r")
3096 case("i")
3098 case("b")
3100 case("d")
3102 case("c")
3104 case default
3106 CALL raise_fatal_error()
3107 end select
3108 else
3110 end if
3111 end if
3112 end do
3113 end if
3114 endif
3115end if
3116
3117if (present(anaattr)) then
3118 nanaattr=size(anaattr)
3119 if (nanaattr == 0) then
3120 allocate (anastarvars%dcv(nanaattr))
3121 else
3122 nanaattr=count(c_e(anaattr))
3123 if (nanaattr > 0) then
3124 allocate (anastarvars%dcv(nanaattr))
3125 do i=1,size(anaattr)
3127 if (present(anaattrkind))then
3128 select case (anaattrkind(i))
3129 case("r")
3131 case("i")
3133 case("b")
3135 case("d")
3137 case("c")
3139 case default
3141 CALL raise_fatal_error()
3142 end select
3143 else
3145 end if
3146 end if
3147 end do
3148 end if
3149 end if
3150end if
3151
3152
3153 ! like a cast
3154mydbacoordmin=dbacoord()
3155if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
3156mydbacoordmax=dbacoord()
3157if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
3158mydbaana=dbaana()
3159if (present(ana)) mydbaana%vol7d_ana=ana
3160mydatetimemin=dbadatetime()
3161if (present(timei)) mydatetimemin%datetime=timei
3162mydatetimemax=dbadatetime()
3163if (present(timef)) mydatetimemax%datetime=timef
3164mydbatimerange=dbatimerange()
3165if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
3166mydbalevel=dbalevel()
3167if (present(level)) mydbalevel%vol7d_level=level
3168mydbanetwork=dbanetwork()
3169if (present(network)) mydbanetwork%vol7d_network=network
3170
3171!!
3172!! here we have options ready for filter
3173!!
3174filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, &
3175 datetimemin=mydatetimemin,datetimemax=mydatetimemax, &
3176 timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,query=query,&
3177 vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,&
3178 dataonly=dataonly,anaonly=anaonly)
3179!!$ print *, "filter:"
3180!!$ call filter%display()
3181
3183
3184
3185END SUBROUTINE vol7d_dballe_import_old
3186
3187
3188
3190subroutine vol7d_dballe_import(this,filter,set_network)
3191
3192TYPE(vol7d_dballe),INTENT(inout) :: this
3193type(dbafilter),INTENT(in) :: filter
3194TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
3195
3196TYPE(vol7d) :: vol7dtmp
3197type(dbametaanddata),allocatable :: metaanddatav(:)
3198type(dbafilter) :: myfilter
3199
3201
3202if ( .not. filter%dataonly) then
3203 ! ----------------> constant station data
3204 myfilter=dbafilter(filter=filter,contextana=.true.,query=cmiss)
3205! ! set filter
3206! call this%handle%set(filter=myfilter)
3207 ! estrude the data
3208 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for constant station data')
3209! call this%handle%ingest(filter=myfilter)
3210 call this%handle%ingest(metaanddatav,filter=myfilter)
3213 call dba2v7d(this%vol7d, metaanddatav,this%time_definition,set_network)
3215
3216 deallocate (metaanddatav)
3217
3218else
3219 ! empty volume
3221 call vol7d_alloc(this%vol7d)
3222 call vol7d_alloc_vol(this%vol7d)
3223end if
3224 ! ----------------> constant station data end
3225
3226if ( .not. filter%anaonly) then
3227 ! ----------------> working on data
3228 myfilter=dbafilter(filter=filter,contextana=.false.)
3229! ! set filter
3230! call this%handle%set(filter=myfilter)
3231 ! estrude the data
3232
3233 CALL l4f_category_log(this%category,l4f_debug,'start import vol7d_dballe ingest for station data')
3234! call this%handle%ingest(filter=myfilter)
3235 call this%handle%ingest(metaanddatav,filter=myfilter)
3238 call dba2v7d(vol7dtmp,metaanddatav,this%time_definition,set_network)
3240
3241 deallocate (metaanddatav)
3242
3244!!$else
3245!!$ ! should we sort separately in case no merge is done?
3246!!$ CALL vol7d_smart_sort(this%vol7d, lsort_time=.TRUE., lsort_timerange=.TRUE., lsort_level=.TRUE.)
3247end if
3248
3249call vol7d_dballe_set_var_du(this%vol7d)
3250
3251
3252#ifdef NONE
3253
3254!!$if (lattr) then
3255!!$
3256!!$ allocate (this%data_id( nana, ntime, nlevel, ntimerange, nnetwork),stat=istat)
3257!!$ if (istat/= 0) THEN
3258!!$ CALL l4f_category_log(this%category,L4F_ERROR,'cannot allocate ' &
3259!!$ //TRIM(to_char(nana*ntime*nlevel*ntimerange*nnetwork))//' data_id elements')
3260!!$ CALL raise_fatal_error()
3261!!$
3262!!$ ENDIF
3263!!$
3264!!$ this%data_id=DBA_MVI
3265!!$
3266!!$else
3267
3268nullify(this%data_id)
3269
3270!!$end if
3271
3272
3273 !memorizzo data_id
3274#ifdef DEBUG
3275 !CALL l4f_category_log(this%category,L4F_DEBUG,"data_id: "//trim(to_char(buffer(i)%data_id)))
3276#endif
3277
3278this%data_id(indana,indtime,indlevel,indtimerange,indnetwork)=buffer(i)%data_id
3279
3280
3281ier=idba_set(this%handle,"*context_id",buffer(i)%data_id)
3282ier=idba_set(this%handle,"*var_related",buffer(i)%btable)
3283 !per ogni dato ora lavoro sugli attributi
3284ier=idba_set(this%handle, "*varlist",starvarlist )
3285ier=idba_voglioancora(this%handle,nn)
3286 !print*,buffer(i)%btable," numero attributi",nn
3287
3288#endif
3289
3291
3292end subroutine vol7d_dballe_import
3293
3294
3295
3297
3298SUBROUTINE vol7d_dballe_delete(this, preserveidbhandle)
3299TYPE(vol7d_dballe) :: this
3300logical,intent(in), optional :: preserveidbhandle
3301
3302# ifndef F2003_FULL_FEATURES
3303call this%handle%delete()
3304
3305if (.not. optio_log(preserveidbhandle)) call this%idbhandle%delete()
3306# endif
3307
3308!!$if (associated(this%data_id)) then
3309!!$ deallocate (this%data_id)
3310!!$ nullify(this%data_id)
3311!!$end if
3312
3314
3315 !chiudo il logger
3316call l4f_category_delete(this%category)
3317 !ier=l4f_fini()
3318
3319END SUBROUTINE vol7d_dballe_delete
3320
3321
3322
3324!subroutine dba2v7d(this,metaanddatav,vars,starvars,anavars,anastarvars,time_definition, set_network)
3325subroutine dba2v7d(this,metaanddatav,time_definition, set_network)
3326
3327type(dbametaanddata),intent(inout) :: metaanddatav(:) ! change value in datetime reguard timedefinition
3328TYPE(vol7d),INTENT(inout) :: this
3329integer,INTENT(in),OPTIONAL :: time_definition
3330TYPE(vol7d_network),INTENT(in),OPTIONAL :: set_network
3331type(dbadcv) :: vars
3332type(dbadcv) :: starvars
3333type(dbadcv) :: anavars
3334type(dbadcv) :: anastarvars
3335
3336
3337LOGICAL :: ldegnet
3338integer :: indana,indtime,indlevel,indtimerange,inddativar,indnetwork,indattrvar
3339
3340integer :: nana,ntime,ntimerange,nlevel,nnetwork
3341
3342INTEGER :: i, j, k, n
3343integer :: inddativarattr
3344integer :: nanavar, indanavar,indanavarattr,nanavarattr
3345
3346integer :: ndativarr, ndativari, ndativarb, ndativard, ndativarc
3347integer :: ndatiattrr, ndatiattri, ndatiattrb, ndatiattrd, ndatiattrc
3348integer :: ndativarattrr, ndativarattri, ndativarattrb, ndativarattrd, ndativarattrc
3349
3350integer :: nanavarr, nanavari, nanavarb, nanavard, nanavarc
3351integer :: nanaattrr, nanaattri, nanaattrb, nanaattrd, nanaattrc
3352integer :: nanavarattrr, nanavarattri, nanavarattrb, nanavarattrd, nanavarattrc
3353
3354integer :: ndativar,ndativarattr
3355
3356type(characterlist) :: dativarl,dativarattrl,anavarl,anavarattrl
3357
3358character(len=listcharmaxlen),allocatable :: dativara(:),dativarattra(:),anavara(:),anavarattra(:)
3359logical :: status
3360integer :: ltime_definition
3361
3362type(datetime),allocatable :: tmptime(:)
3363type(vol7d_network),allocatable :: tmpnetwork(:)
3364type(vol7d_level),allocatable :: tmplevel(:)
3365type(vol7d_timerange),allocatable :: tmptimerange(:)
3366type(vol7d_ana),allocatable :: tmpana(:)
3367
3368
3369ltime_definition=optio_i(time_definition)
3371
3372 ! take in account time_definition
3373if (ltime_definition == 0) then
3374 do i =1,size(metaanddatav)
3375 metaanddatav(i)%metadata%datetime%datetime = &
3376 metaanddatav(i)%metadata%datetime%datetime - &
3377 timedelta_new(sec=metaanddatav(i)%metadata%timerange%vol7d_timerange%p1)
3378 end do
3379end if
3380
3381
3382IF (PRESENT(set_network)) THEN
3384 ldegnet = .true.
3385 else
3386 ldegnet = .false.
3387 end if
3388ELSE
3389 ldegnet = .false.
3390ENDIF
3391
3392
3393
3394!!--------------------------------------------------------------------------
3395!! find vars, starvars, anavars, anastarvars
3396!!
3397
3398! create lists of all
3399 ! data
3400do i =1, size(metaanddatav)
3401 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3403 !print *,"dativarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable
3404 call dativarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable)
3405 else
3406 !print *,"anavarl: ", metaanddatav(i)%dataattrv%dataattr(j)%dat%btable
3407 call anavarl%append(metaanddatav(i)%dataattrv%dataattr(j)%dat%btable)
3408 end if
3409 end do
3410end do
3411
3412!count and put in vector of unuique key
3413ndativar = count_distinct(toarray_charl(dativarl) , back=.true.)
3414allocate(dativara(ndativar))
3415call pack_distinct_c (toarray_charl(dativarl) , dativara , back=.true.)
3416status = dativarl%delete()
3417allocate (vars%dcv(ndativar))
3418
3419nanavar = count_distinct(toarray_charl(anavarl) , back=.true.)
3420allocate(anavara(nanavar))
3421call pack_distinct_c (toarray_charl(anavarl) , anavara , back=.true.)
3422status = anavarl%delete()
3423allocate (anavars%dcv(nanavar))
3424
3425
3426an: do n=1,ndativar
3427 do i =1, size(metaanddatav)
3428 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3430 if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == dativara(n)) then
3431 allocate(vars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat)
3432 cycle an
3433 end if
3434 end if
3435 end do
3436 end do
3437end do an
3438
3439bn: do n=1,nanavar
3440 do i =1, size(metaanddatav)
3441 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3443 if (metaanddatav(i)%dataattrv%dataattr(j)%dat%btable == anavara(n)) then
3444 allocate(anavars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%dat)
3445 cycle bn
3446 end if
3447 end if
3448 end do
3449 end do
3450end do bn
3451
3452 ! attributes
3453do i =1, size(metaanddatav)
3454 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3455 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
3457 !print *,"dativarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable
3458 call dativarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable)
3459 else
3460 !print *,"anavarattrl: ", metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable
3461 call anavarattrl%append(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable)
3462 end if
3463 end do
3464 end do
3465end do
3466
3467
3468ndativarattr = count_distinct(toarray_charl(dativarattrl), back=.true.)
3469allocate(dativarattra(ndativarattr))
3470call pack_distinct_c (toarray_charl(dativarattrl), dativarattra, back=.true.)
3471status = dativarattrl%delete()
3472allocate(starvars%dcv(ndativarattr))
3473
3474nanavarattr = count_distinct(toarray_charl(anavarattrl) , back=.true.)
3475allocate(anavarattra(nanavarattr))
3476call pack_distinct_c (toarray_charl(anavarattrl) , anavarattra , back=.true.)
3477status = anavarattrl%delete()
3478allocate(anastarvars%dcv(nanavarattr))
3479
3480
3481cn: do n=1,ndativarattr
3482 do i =1, size(metaanddatav)
3483 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3484 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
3486 if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == dativarattra(n))then
3487 allocate(starvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
3488 cycle cn
3489 end if
3490 end if
3491 end do
3492 end do
3493 end do
3494end do cn
3495
3496
3497dn: do n=1,nanavarattr
3498 do i =1, size(metaanddatav)
3499 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3500 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
3502 if (metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat%btable == anavarattra(n))then
3503 allocate(anastarvars%dcv(n)%dat,source=metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
3504 cycle dn
3505 end if
3506 end if
3507 end do
3508 end do
3509 end do
3510end do dn
3511
3512
3513!!--------------------------------------------------------------------------
3514
3515
3516!!
3517!! count all unique metadata
3518!!
3519
3520if(ldegnet) then
3521 nnetwork=1
3522else
3523 !nnetwork = count_distinct(metaanddatav(:)%metadata%network%vol7d_network, back=.TRUE.)
3524 allocate (tmpnetwork(size(metaanddatav(:))),&
3525 source=metaanddatav(:)%metadata%network%vol7d_network)
3527 nnetwork = count_distinct_sorted(tmpnetwork)
3528end if
3529
3530!ntime = count_distinct(metaanddatav(:)%metadata%datetime%datetime, &
3531! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
3532allocate (tmptime(size(metaanddatav(:))),&
3533 source=metaanddatav(:)%metadata%datetime%datetime)
3535ntime = count_distinct_sorted(tmptime,mask=c_e(tmptime))
3536
3537!ntimerange = count_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, &
3538! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
3539allocate (tmptimerange(size(metaanddatav(:))),&
3540 source=metaanddatav(:)%metadata%timerange%vol7d_timerange)
3542ntimerange = count_distinct_sorted(tmptimerange,mask=c_e(tmptimerange))
3543
3544!nlevel = count_distinct(metaanddatav(:)%metadata%level%vol7d_level, &
3545! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level),back=.TRUE.)
3546allocate (tmplevel(size(metaanddatav(:))),&
3547 source=metaanddatav(:)%metadata%level%vol7d_level)
3549nlevel = count_distinct_sorted(tmplevel,mask=c_e(tmplevel))
3550
3551!nana = count_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, back=.TRUE.)
3552allocate (tmpana(size(metaanddatav(:))),&
3553 source=metaanddatav(:)%metadata%ana%vol7d_ana)
3555nana = count_distinct_sorted(tmpana)
3556
3557!!$if(ldegnet) then
3558!!$ nnetwork=1
3559!!$else
3560!!$ nnetwork = size(metaanddatav(:)%metadata%network%vol7d_network)
3561!!$end if
3562!!$ntime = size(metaanddatav(:)%metadata%datetime%datetime)
3563!!$ntimerange = size(metaanddatav(:)%metadata%timerange%vol7d_timerange)
3564!!$nlevel = size(metaanddatav(:)%metadata%level%vol7d_level)
3565!!$nana = size(metaanddatav(:)%metadata%ana%vol7d_ana)
3566
3567 ! var
3568
3569ndativarr = 0
3570ndativari = 0
3571ndativarb = 0
3572ndativard = 0
3573ndativarc = 0
3574
3575do i =1 ,size(vars%dcv)
3576 associate(dato => vars%dcv(i)%dat)
3577 select type (dato)
3579 ndativarr = ndativarr + 1
3581 ndativari = ndativari + 1
3583 ndativarb = ndativarb + 1
3585 ndativard = ndativard + 1
3587 ndativarc = ndativarc + 1
3588 end select
3589 end associate
3590end do
3591
3592
3593 !attr
3594
3595ndatiattrr = 0
3596ndatiattri = 0
3597ndatiattrb = 0
3598ndatiattrd = 0
3599ndatiattrc = 0
3600
3601do i =1 ,size(starvars%dcv)
3602 associate(dato => starvars%dcv(i)%dat)
3603 select type (dato)
3605 ndatiattrr = ndatiattrr + 1
3607 ndatiattri = ndatiattri + 1
3609 ndatiattrb = ndatiattrb + 1
3611 ndatiattrd = ndatiattrd + 1
3613 ndatiattrc = ndatiattrc + 1
3614 end select
3615 end associate
3616end do
3617
3618
3619 ! ana var
3620
3621nanavarr = 0
3622nanavari = 0
3623nanavarb = 0
3624nanavard = 0
3625nanavarc = 0
3626
3627do i =1 ,size(anavars%dcv)
3628 associate(dato => anavars%dcv(i)%dat)
3629 select type (dato)
3630 type is (dbadatar)
3631 nanavarr = nanavarr + 1
3632 type is (dbadatai)
3633 nanavari = nanavari + 1
3634 type is (dbadatab)
3635 nanavarb = nanavarb + 1
3636 type is (dbadatad)
3637 nanavard = nanavard + 1
3638 type is (dbadatac)
3639 nanavarc = nanavarc + 1
3640 end select
3641 end associate
3642end do
3643
3644
3645 ! ana attr
3646
3647nanaattrr = 0
3648nanaattri = 0
3649nanaattrb = 0
3650nanaattrd = 0
3651nanaattrc = 0
3652
3653do i =1 ,size(anastarvars%dcv)
3654 associate(dato => anastarvars%dcv(i)%dat)
3655 select type (dato)
3656 type is (dbadatar)
3657 nanaattrr = nanaattrr + 1
3658 type is (dbadatai)
3659 nanaattri = nanaattri + 1
3660 type is (dbadatab)
3661 nanaattrb = nanaattrb + 1
3662 type is (dbadatad)
3663 nanaattrd = nanaattrd + 1
3664 type is (dbadatac)
3665 nanaattrc = nanaattrc + 1
3666 end select
3667 end associate
3668end do
3669
3670
3671 !refine
3672
3673ndativarattrr=0
3674ndativarattri=0
3675ndativarattrb=0
3676ndativarattrd=0
3677ndativarattrc=0
3678
3679if (ndatiattrr > 0 ) ndativarattrr=ndativarr+ndativari+ndativarb+ndativard+ndativarc
3680if (ndatiattri > 0 ) ndativarattri=ndativarr+ndativari+ndativarb+ndativard+ndativarc
3681if (ndatiattrb > 0 ) ndativarattrb=ndativarr+ndativari+ndativarb+ndativard+ndativarc
3682if (ndatiattrd > 0 ) ndativarattrd=ndativarr+ndativari+ndativarb+ndativard+ndativarc
3683if (ndatiattrc > 0 ) ndativarattrc=ndativarr+ndativari+ndativarb+ndativard+ndativarc
3684
3685
3686nanavarattrr=0
3687nanavarattri=0
3688nanavarattrb=0
3689nanavarattrd=0
3690nanavarattrc=0
3691
3692if (nanaattrr > 0 ) nanavarattrr=nanavarr+nanavari+nanavarb+nanavard+nanavarc
3693if (nanaattri > 0 ) nanavarattri=nanavarr+nanavari+nanavarb+nanavard+nanavarc
3694if (nanaattrb > 0 ) nanavarattrb=nanavarr+nanavari+nanavarb+nanavard+nanavarc
3695if (nanaattrd > 0 ) nanavarattrd=nanavarr+nanavari+nanavarb+nanavard+nanavarc
3696if (nanaattrc > 0 ) nanavarattrc=nanavarr+nanavari+nanavarb+nanavard+nanavarc
3697
3698
3700
3701!!$print *, "nana=",nana, "ntime=",ntime, "ntimerange=",ntimerange, &
3702!!$ "nlevel=",nlevel, "nnetwork=",nnetwork, &
3703!!$ "ndativarr=",ndativarr, "ndativari=",ndativari, &
3704!!$ "ndativarb=",ndativarb, "ndativard=",ndativard, "ndativarc=",ndativarc,&
3705!!$ "ndatiattrr=",ndatiattrr, "ndatiattri=",ndatiattri, "ndatiattrb=",ndatiattrb,&
3706!!$ "ndatiattrd=",ndatiattrd, "ndatiattrc=",ndatiattrc,&
3707!!$ "ndativarattrr=",ndativarattrr, "ndativarattri=",ndativarattri, "ndativarattrb=",ndativarattrb,&
3708!!$ "ndativarattrd=",ndativarattrd, "ndativarattrc=",ndativarattrc
3709!!$
3710!!$print *,"nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc"
3711!!$print *,nanaattrr,nanaattri,nanaattrb,nanaattrd,nanaattrc
3712
3713
3714call vol7d_alloc (this, &
3715nana=nana, ntime=ntime, ntimerange=ntimerange, &
3716nlevel=nlevel, nnetwork=nnetwork, &
3717ndativarr=ndativarr, ndativari=ndativari, ndativarb=ndativarb, ndativard=ndativard, ndativarc=ndativarc,&
3718ndatiattrr=ndatiattrr, ndatiattri=ndatiattri, ndatiattrb=ndatiattrb, ndatiattrd=ndatiattrd, ndatiattrc=ndatiattrc,&
3719ndativarattrr=ndativarattrr, &
3720ndativarattri=ndativarattri, &
3721ndativarattrb=ndativarattrb, &
3722ndativarattrd=ndativarattrd, &
3723ndativarattrc=ndativarattrc,&
3724nanavarr=nanavarr, nanavari=nanavari, nanavarb=nanavarb, nanavard=nanavard, nanavarc=nanavarc,&
3725nanaattrr=nanaattrr, nanaattri=nanaattri, nanaattrb=nanaattrb, nanaattrd=nanaattrd, nanaattrc=nanaattrc,&
3726nanavarattrr=nanavarattrr, &
3727nanavarattri=nanavarattri, &
3728nanavarattrb=nanavarattrb, &
3729nanavarattrd=nanavarattrd, &
3730nanavarattrc=nanavarattrc)
3731
3732
3733! fill metadata removing contextana metadata
3734
3735!nana=count_and_pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana,this%ana, back=.TRUE.)
3736!this%ana=pack_distinct(metaanddatav(:)%metadata%ana%vol7d_ana, nana, back=.TRUE.)
3737this%ana=pack_distinct_sorted(tmpana, nana)
3738deallocate(tmpana)
3739!call sort(this%ana)
3740
3741!ntime=count_and_pack_distinct(metaanddatav(:)%metadata%datetime%datetime,this%time, &
3742! mask=c_e(metaanddatav(:)%metadata%datetime%datetime), back=.TRUE.)
3743!this%time=pack_distinct(metaanddatav(:)%metadata%datetime%datetime, ntime, &
3744! mask=c_e(metaanddatav(:)%metadata%datetime%datetime),back=.TRUE.)
3745this%time=pack_distinct_sorted(tmptime, ntime,mask=c_e(tmptime))
3746deallocate(tmptime)
3747!call sort(this%time)
3748
3749!ntimerange=count_and_pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange,this%timerange, &
3750! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
3751!this%timerange=pack_distinct(metaanddatav(:)%metadata%timerange%vol7d_timerange, ntimerange, &
3752! mask=c_e(metaanddatav(:)%metadata%timerange%vol7d_timerange), back=.TRUE.)
3753this%timerange=pack_distinct_sorted(tmptimerange, ntimerange,mask=c_e(tmptimerange))
3754deallocate(tmptimerange)
3755!call sort(this%timerange)
3756
3757!nlevel=count_and_pack_distinct(metaanddatav(:)%metadata%level%vol7d_level,this%level, &
3758! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
3759!this%level=pack_distinct(metaanddatav(:)%metadata%level%vol7d_level, nlevel, &
3760! mask=c_e(metaanddatav(:)%metadata%level%vol7d_level), back=.TRUE.)
3761this%level=pack_distinct_sorted(tmplevel, nlevel,mask=c_e(tmplevel))
3762deallocate(tmplevel)
3763!call sort(this%level)
3764
3765if(ldegnet)then
3766 nnetwork=1
3767 ALLOCATE(this%network(1))
3768 this%network(1)=set_network
3769else
3770 !nnetwork=count_and_pack_distinct(metaanddatav(:)%metadata%network%vol7d_network,this%network, back=.TRUE.)
3771 !this%network=pack_distinct(metaanddatav(:)%metadata%network%vol7d_network, nnetwork, back=.TRUE.)
3772 this%network=pack_distinct_sorted(tmpnetwork, nnetwork)
3773 deallocate(tmpnetwork)
3774end if
3775!call sort(this%network)
3776
3777 ! var
3778
3779ndativarr = 0
3780ndativari = 0
3781ndativarb = 0
3782ndativard = 0
3783ndativarc = 0
3784
3785do i =1 ,size(vars%dcv)
3786 associate(dato => vars%dcv(i)%dat)
3787 select type (dato)
3788 type is (dbadatar)
3789 ndativarr = ndativarr + 1
3791 type is (dbadatai)
3792 ndativari = ndativari + 1
3794 type is (dbadatab)
3795 ndativarb = ndativarb + 1
3797 type is (dbadatad)
3798 ndativard = ndativard + 1
3800 type is (dbadatac)
3801 ndativarc = ndativarc + 1
3803 end select
3804 end associate
3805end do
3806
3807
3808 !attr
3809
3810ndatiattrr = 0
3811ndatiattri = 0
3812ndatiattrb = 0
3813ndatiattrd = 0
3814ndatiattrc = 0
3815
3816do i =1 ,size(starvars%dcv)
3817 associate(dato => starvars%dcv(i)%dat)
3818 select type (dato)
3819 type is (dbadatar)
3820 ndatiattrr = ndatiattrr + 1
3822 type is (dbadatai)
3823 ndatiattri = ndatiattri + 1
3825 type is (dbadatab)
3826 ndatiattrb = ndatiattrb + 1
3828 type is (dbadatad)
3829 ndatiattrd = ndatiattrd + 1
3831 type is (dbadatac)
3832 ndatiattrc = ndatiattrc + 1
3834 end select
3835 end associate
3836end do
3837
3838
3839 ! ana var
3840
3841nanavarr = 0
3842nanavari = 0
3843nanavarb = 0
3844nanavard = 0
3845nanavarc = 0
3846
3847do i =1 ,size(anavars%dcv)
3848 associate(dato => anavars%dcv(i)%dat)
3849 select type (dato)
3850 type is (dbadatar)
3851 nanavarr = nanavarr + 1
3853 type is (dbadatai)
3854 nanavari = nanavari + 1
3856 type is (dbadatab)
3857 nanavarb = nanavarb + 1
3859 type is (dbadatad)
3860 nanavard = nanavard + 1
3862 type is (dbadatac)
3863 nanavarc = nanavarc + 1
3865 end select
3866 end associate
3867end do
3868
3869
3870 ! ana attr
3871
3872nanaattrr = 0
3873nanaattri = 0
3874nanaattrb = 0
3875nanaattrd = 0
3876nanaattrc = 0
3877
3878do i =1 ,size(anastarvars%dcv)
3879 associate(dato => anastarvars%dcv(i)%dat)
3880 select type (dato)
3881 type is (dbadatar)
3882 nanaattrr = nanaattrr + 1
3884 type is (dbadatai)
3885 nanaattri = nanaattri + 1
3887 type is (dbadatab)
3888 nanaattrb = nanaattrb + 1
3890 type is (dbadatad)
3891 nanaattrd = nanaattrd + 1
3893 type is (dbadatac)
3894 nanaattrc = nanaattrc + 1
3896 end select
3897 end associate
3898end do
3899
3900
3901 ! here we colcolate the link from attributes and vars
3902do i =1, size(vars%dcv)
3903 associate(dato => vars%dcv(i)%dat)
3909 end associate
3910end do
3911
3912do i =1, size(anavars%dcv)
3913 associate(dato => anavars%dcv(i)%dat)
3919 end associate
3920end do
3921
3922 ! set index in dativaratt*
3923call vol7d_set_attr_ind(this)
3924
3925call vol7d_alloc_vol (this)
3926
3927 ! Ora qui bisogna metterci dentro idati
3928indana = 0
3929indtime = 0
3930indnetwork = 0
3931indtime = 0
3932indtimerange = 0
3933indlevel = 0
3934do i =1, size(metaanddatav)
3935
3936 indana = index_sorted(this%ana, metaanddatav(i)%metadata%ana%vol7d_ana)
3937
3938 if (ldegnet)then
3939 indnetwork=1
3940 else
3941 indnetwork = index_sorted(this%network, metaanddatav(i)%metadata%network%vol7d_network)
3942 endif
3943
3944 if (c_e(metaanddatav(i)%metadata%datetime%datetime) .and. &
3945 c_e(metaanddatav(i)%metadata%timerange%vol7d_timerange) .and. &
3946 c_e(metaanddatav(i)%metadata%level%vol7d_level) ) then ! dati
3947
3948 indtime = index_sorted(this%time, metaanddatav(i)%metadata%datetime%datetime)
3949 indtimerange = index_sorted(this%timerange, metaanddatav(i)%metadata%timerange%vol7d_timerange)
3950 indlevel = index_sorted(this%level, metaanddatav(i)%metadata%level%vol7d_level)
3951
3952 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
3953
3954 associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
3955 select type (dato)
3956 type is (dbadatai)
3957 inddativar = firsttrue(dato%btable == this%dativar%i%btable)
3958 this%voldatii( &
3959 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3960 ) = dato%value
3961
3962 type is (dbadatar)
3963 inddativar = firsttrue(dato%btable == this%dativar%r%btable)
3964 this%voldatir( &
3965 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3966 ) = dato%value
3967
3968 type is (dbadatad)
3969 inddativar = firsttrue(dato%btable == this%dativar%d%btable)
3970 this%voldatid( &
3971 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3972 ) = dato%value
3973
3974 type is (dbadatab)
3975 inddativar = firsttrue(dato%btable == this%dativar%b%btable)
3976 this%voldatib( &
3977 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3978 ) = dato%value
3979
3980 type is (dbadatac)
3981 inddativar = firsttrue(dato%btable == this%dativar%c%btable)
3982 this%voldatic( &
3983 indana,indtime,indlevel,indtimerange,inddativar,indnetwork &
3984 ) = dato%value
3985
3986 end select
3987
3988
3989 ! dati attributes
3990 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
3991 associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
3992 select type (attr)
3993
3994 type is (dbadatai)
3995 inddativarattr = firsttrue(dato%btable == this%dativarattr%i%btable)
3996 indattrvar = firsttrue(attr%btable == this%datiattr%i%btable)
3997 this%voldatiattri( &
3998 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
3999 ) = attr%value
4000 type is (dbadatar)
4001 inddativarattr = firsttrue(dato%btable == this%dativarattr%r%btable)
4002 indattrvar = firsttrue(attr%btable == this%datiattr%r%btable)
4003 this%voldatiattrr( &
4004 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
4005 ) = attr%value
4006 type is (dbadatad)
4007 inddativarattr = firsttrue(dato%btable == this%dativarattr%d%btable)
4008 indattrvar = firsttrue(attr%btable == this%datiattr%d%btable)
4009 this%voldatiattrd( &
4010 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
4011 ) = attr%value
4012 type is (dbadatab)
4013 inddativarattr = firsttrue(dato%btable == this%dativarattr%b%btable)
4014 indattrvar = firsttrue(attr%btable == this%datiattr%b%btable)
4015 this%voldatiattrb( &
4016 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
4017 ) = attr%value
4018 type is (dbadatac)
4019 inddativarattr = firsttrue(dato%btable == this%dativarattr%c%btable)
4020 indattrvar = firsttrue(attr%btable == this%datiattr%c%btable)
4021 this%voldatiattrc( &
4022 indana,indtime,indlevel,indtimerange,inddativarattr,indnetwork,indattrvar &
4023 ) = attr%value
4024
4025 end select
4026 end associate
4027 end do
4028 end associate
4029 end do
4030
4031 else
4032 ! ana
4033 do j=1, size(metaanddatav(i)%dataattrv%dataattr)
4034
4035 associate(dato => metaanddatav(i)%dataattrv%dataattr(j)%dat)
4036 select type (dato)
4037 type is (dbadatai)
4038 indanavar = firsttrue(dato%btable == this%anavar%i%btable)
4039 this%volanai( &
4040 indana,indanavar,indnetwork &
4041 ) = dato%value
4042
4043 type is (dbadatar)
4044 indanavar = firsttrue(dato%btable == this%anavar%r%btable)
4045 this%volanar( &
4046 indana,indanavar,indnetwork &
4047 ) = dato%value
4048
4049 type is (dbadatad)
4050 indanavar = firsttrue(dato%btable == this%anavar%d%btable)
4051 this%volanad( &
4052 indana,indanavar,indnetwork &
4053 ) = dato%value
4054
4055 type is (dbadatab)
4056 indanavar = firsttrue(dato%btable == this%anavar%b%btable)
4057 this%volanab( &
4058 indana,indanavar,indnetwork &
4059 ) = dato%value
4060
4061 type is (dbadatac)
4062 indanavar = firsttrue(dato%btable == this%anavar%c%btable)
4063 this%volanac( &
4064 indana,indanavar,indnetwork &
4065 ) = dato%value
4066
4067 end select
4068
4069
4070 ! ana attributes
4071 do k=1, size(metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv)
4072 associate(attr => metaanddatav(i)%dataattrv%dataattr(j)%attrv%dcv(k)%dat)
4073 select type (attr)
4074
4075 type is (dbadatai)
4076 indanavarattr = firsttrue(dato%btable == this%anavarattr%i%btable)
4077 indattrvar = firsttrue(attr%btable == this%anaattr%i%btable)
4078 this%volanaattri( &
4079 indana,indanavarattr,indnetwork,indattrvar &
4080 ) = attr%value
4081 type is (dbadatar)
4082 indanavarattr = firsttrue(dato%btable == this%anavarattr%r%btable)
4083 indattrvar = firsttrue(attr%btable == this%anaattr%r%btable)
4084 this%volanaattrr( &
4085 indana,indanavarattr,indnetwork,indattrvar &
4086 ) = attr%value
4087 type is (dbadatad)
4088 indanavarattr = firsttrue(dato%btable == this%anavarattr%d%btable)
4089 indattrvar = firsttrue(attr%btable == this%anaattr%d%btable)
4090 this%volanaattrd( &
4091 indana,indanavarattr,indnetwork,indattrvar &
4092 ) = attr%value
4093 type is (dbadatab)
4094 indanavarattr = firsttrue(dato%btable == this%anavarattr%b%btable)
4095 indattrvar = firsttrue(attr%btable == this%anaattr%b%btable)
4096 this%volanaattrb( &
4097 indana,indanavarattr,indnetwork,indattrvar &
4098 ) = attr%value
4099 type is (dbadatac)
4100 indanavarattr = firsttrue(dato%btable == this%anavarattr%c%btable)
4101 indattrvar = firsttrue(attr%btable == this%anaattr%c%btable)
4102 this%volanaattrc( &
4103 indana,indanavarattr,indnetwork,indattrvar &
4104 ) = attr%value
4105
4106 end select
4107 end associate
4108 end do
4109 end associate
4110 end do
4111 end if
4112end do
4113
4114contains
4115
4116!!$!> /brief Return an dbadcv from a mixlist with dbadata* type
4117!!$function todcv_dbadat(this)
4118!!$type(dbadcv) :: todcv_dbadat !< array
4119!!$type(mixlist) :: this
4120!!$
4121!!$integer :: i
4122!!$
4123!!$allocate (todcv_dbadat%dcv(this%countelements()))
4124!!$
4125!!$call this%rewind()
4126!!$i=0
4127!!$do while(this%element())
4128!!$ i=i+1
4129!!$
4130!!$ associate (dato => this%current())
4131!!$ select type (dato)
4132!!$ type is (dbadatar)
4133!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
4134!!$ type is (dbadatai)
4135!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
4136!!$ type is (dbadatab)
4137!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
4138!!$ type is (dbadatad)
4139!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
4140!!$ type is (dbadatac)
4141!!$ allocate(todcv_dbadat%dcv(i)%dat,source=dato)
4142!!$ end select
4143!!$ end associate
4144!!$
4145!!$ call this%next()
4146!!$end do
4147!!$end function todcv_dbadat
4148
4149!!$! Definisce le funzioni count_distinct e pack_distinct
4150!!$#define VOL7D_POLY_TYPE TYPE(dbadata)
4151!!$#define VOL7D_POLY_TYPES _dbadata
4152!!$#undef ENABLE_SORT
4153!!$#include "array_utilities_inc.F90"
4154!!$#undef VOL7D_POLY_TYPE
4155!!$#undef VOL7D_POLY_TYPES
4156
4157
4158end subroutine dba2v7d
4159
4160
4161subroutine vol7d_dballe_import_dballevar(this)
4162
4163type(vol7d_var),pointer :: this(:)
4164INTEGER :: i,un,n
4165
4166IF (associated(this)) return
4167IF (allocated(blocal)) then
4168 ALLOCATE(this(size(blocal)))
4169 this=blocal
4170 return
4171end if
4172
4173un = open_dballe_file('dballe.txt', filetype_data)
4174IF (un < 0) then
4175
4176 call l4f_log(l4f_error,"error open_dballe_file: dballe.txt")
4177 CALL raise_error("error open_dballe_file: dballe.txt")
4178 return
4179end if
4180
4181n = 0
4182DO WHILE(.true.)
4183 READ(un,*,END=100)
4184 n = n + 1
4185ENDDO
4186100 CONTINUE
4187
4188IF (n > 0) THEN
4189 ALLOCATE(this(n))
4190 ALLOCATE(blocal(n))
4191 rewind(un)
4192 readline: do i = 1 ,n
4193 READ(un,'(1x,A6,1x,a65,a24,i4)')blocal(i)%btable,blocal(i)%description,blocal(i)%unit,&
4194 blocal(i)%scalefactor
4195 blocal(i)%btable(:1)="B"
4196 !print*,"B=",blocal(i)%btable
4197 !print*," D=",blocal(i)%description
4198 !PRINT*," U=",blocal(i)%unit
4199 !PRINT*," D=",blocal(i)%scalefactor
4200 ENDDO readline
4201
4202 CALL l4f_log(l4f_info,'Found '//trim(to_char(i-1))//' variables in dballe master table')
4203
4204 this=blocal
4205
4206ENDIF
4207CLOSE(un)
4208
4209END SUBROUTINE vol7d_dballe_import_dballevar
4210
4211
4212
4215
4216subroutine vol7d_dballe_set_var_du(this)
4217
4218TYPE(vol7d) :: this
4219integer :: i,j
4220type(vol7d_var),pointer :: dballevar(:)
4221
4222nullify(dballevar)
4223call vol7d_dballe_import_dballevar(dballevar)
4224
4225#undef VOL7D_POLY_NAME
4226#define VOL7D_POLY_NAME dativar
4227
4228
4229#undef VOL7D_POLY_TYPES_V
4230#define VOL7D_POLY_TYPES_V r
4231#include "vol7d_dballe_class_var_du.F90"
4232#undef VOL7D_POLY_TYPES_V
4233#define VOL7D_POLY_TYPES_V i
4234#include "vol7d_dballe_class_var_du.F90"
4235#undef VOL7D_POLY_TYPES_V
4236#define VOL7D_POLY_TYPES_V b
4237#include "vol7d_dballe_class_var_du.F90"
4238#undef VOL7D_POLY_TYPES_V
4239#define VOL7D_POLY_TYPES_V d
4240#include "vol7d_dballe_class_var_du.F90"
4241#undef VOL7D_POLY_TYPES_V
4242#define VOL7D_POLY_TYPES_V c
4243#include "vol7d_dballe_class_var_du.F90"
4244#undef VOL7D_POLY_TYPES_V
4245
4246#undef VOL7D_POLY_NAME
4247#define VOL7D_POLY_NAME anavar
4248
4249
4250#undef VOL7D_POLY_TYPES_V
4251#define VOL7D_POLY_TYPES_V r
4252#include "vol7d_dballe_class_var_du.F90"
4253#undef VOL7D_POLY_TYPES_V
4254#define VOL7D_POLY_TYPES_V i
4255#include "vol7d_dballe_class_var_du.F90"
4256#undef VOL7D_POLY_TYPES_V
4257#define VOL7D_POLY_TYPES_V b
4258#include "vol7d_dballe_class_var_du.F90"
4259#undef VOL7D_POLY_TYPES_V
4260#define VOL7D_POLY_TYPES_V d
4261#include "vol7d_dballe_class_var_du.F90"
4262#undef VOL7D_POLY_TYPES_V
4263#define VOL7D_POLY_TYPES_V c
4264#include "vol7d_dballe_class_var_du.F90"
4265#undef VOL7D_POLY_TYPES_V
4266
4267
4268#undef VOL7D_POLY_NAME
4269#define VOL7D_POLY_NAME datiattr
4270
4271
4272#undef VOL7D_POLY_TYPES_V
4273#define VOL7D_POLY_TYPES_V r
4274#include "vol7d_dballe_class_var_du.F90"
4275#undef VOL7D_POLY_TYPES_V
4276#define VOL7D_POLY_TYPES_V i
4277#include "vol7d_dballe_class_var_du.F90"
4278#undef VOL7D_POLY_TYPES_V
4279#define VOL7D_POLY_TYPES_V b
4280#include "vol7d_dballe_class_var_du.F90"
4281#undef VOL7D_POLY_TYPES_V
4282#define VOL7D_POLY_TYPES_V d
4283#include "vol7d_dballe_class_var_du.F90"
4284#undef VOL7D_POLY_TYPES_V
4285#define VOL7D_POLY_TYPES_V c
4286#include "vol7d_dballe_class_var_du.F90"
4287#undef VOL7D_POLY_TYPES_V
4288
4289
4290#undef VOL7D_POLY_NAME
4291#define VOL7D_POLY_NAME anaattr
4292
4293
4294#undef VOL7D_POLY_TYPES_V
4295#define VOL7D_POLY_TYPES_V r
4296#include "vol7d_dballe_class_var_du.F90"
4297#undef VOL7D_POLY_TYPES_V
4298#define VOL7D_POLY_TYPES_V i
4299#include "vol7d_dballe_class_var_du.F90"
4300#undef VOL7D_POLY_TYPES_V
4301#define VOL7D_POLY_TYPES_V b
4302#include "vol7d_dballe_class_var_du.F90"
4303#undef VOL7D_POLY_TYPES_V
4304#define VOL7D_POLY_TYPES_V d
4305#include "vol7d_dballe_class_var_du.F90"
4306#undef VOL7D_POLY_TYPES_V
4307#define VOL7D_POLY_TYPES_V c
4308#include "vol7d_dballe_class_var_du.F90"
4309#undef VOL7D_POLY_TYPES_V
4310
4311
4312deallocate(dballevar)
4313
4314return
4315
4316end subroutine vol7d_dballe_set_var_du
4317
4318
4319
4320FUNCTION get_dballe_filepath(filename, filetype) RESULT(path)
4321CHARACTER(len=*), INTENT(in) :: filename
4322INTEGER, INTENT(in) :: filetype
4323
4324INTEGER :: j
4325CHARACTER(len=512) :: path
4326LOGICAL :: exist
4327
4328IF (dballe_name == ' ') THEN
4329 CALL getarg(0, dballe_name)
4330 ! dballe_name_env
4331ENDIF
4332
4333IF (filetype < 1 .OR. filetype > nftype) THEN
4334 path = ""
4335 CALL l4f_log(l4f_error, 'dballe file type '//trim(to_char(filetype))// &
4336 ' not valid')
4337 CALL raise_error()
4338 RETURN
4339ENDIF
4340
4341! try with environment variable
4342CALL getenv(trim(dballe_name_env), path)
4343IF (path /= ' ') THEN
4344
4345 path=trim(path)//'/'//filename
4346 INQUIRE(file=path, exist=exist)
4347 IF (exist) THEN
4348 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
4349 RETURN
4350 ENDIF
4351ENDIF
4352! try with pathlist
4353DO j = 1, SIZE(pathlist,1)
4354 IF (pathlist(j,filetype) == ' ') EXIT
4355 path=trim(pathlist(j,filetype))//'/'//trim(dballe_name)//'/'//filename
4356 INQUIRE(file=path, exist=exist)
4357 IF (exist) THEN
4358 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' found')
4359 RETURN
4360 ENDIF
4361ENDDO
4362CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
4363CALL raise_error()
4364path = ""
4365
4366END FUNCTION get_dballe_filepath
4367
4368
4369FUNCTION open_dballe_file(filename, filetype) RESULT(unit)
4370CHARACTER(len=*), INTENT(in) :: filename
4371INTEGER, INTENT(in) :: filetype
4372INTEGER :: unit,i
4373
4374CHARACTER(len=512) :: path
4375
4376unit = -1
4377path=get_dballe_filepath(filename, filetype)
4378IF (path == '') RETURN
4379
4380unit = getunit()
4381IF (unit == -1) RETURN
4382
4383OPEN(unit, file=path, status='old', iostat = i)
4384IF (i == 0) THEN
4385 CALL l4f_log(l4f_info, 'dballe file '//trim(path)//' opened')
4386 RETURN
4387ENDIF
4388
4389CALL l4f_log(l4f_error, 'dballe file '//trim(filename)//' not found')
4390CALL raise_error()
4391unit = -1
4392
4393END FUNCTION open_dballe_file
4394
4395
4400
4401
4402!!! TODO manage attr_only
4403!!! attention template migrated in init
4404!SUBROUTINE vol7d_dballe_export(this, network, coordmin, coordmax,&
4405! timei, timef,level,timerange,var,attr,anavar,anaattr,attr_only,ana,dataonly)
4406
4407SUBROUTINE vol7d_dballe_export_old(this, network, coordmin, coordmax,&
4408 timei, timef,level,timerange,var,attr,anavar,anaattr,ana,dataonly,anaonly,template,attr_only)
4409
4410TYPE(vol7d_dballe),INTENT(inout) :: this
4411character(len=network_name_len),INTENT(in),optional :: network
4414TYPE(geo_coord),INTENT(in),optional :: coordmin,coordmax
4416TYPE(datetime),INTENT(in),optional :: timei, timef
4417TYPE(vol7d_level),INTENT(in),optional :: level
4418TYPE(vol7d_timerange),INTENT(in),optional :: timerange
4421CHARACTER(len=*),INTENT(in),OPTIONAL :: var(:),attr(:),anavar(:),anaattr(:)
4422!!$!> permette di riscrivere su un DSN letto precedentemente, modificando solo gli attributi ai dati,
4423!!$!! ottimizzando enormente le prestazioni: gli attributi riscritti saranno quelli con this%data_id definito
4424!!$!! (solitamente ricopiato dall'oggetto letto)
4425!!$logical,intent(in),optional :: attr_only
4426TYPE(vol7d_ana),INTENT(inout),optional :: ana
4427logical, intent(in),optional :: dataonly
4428logical, intent(in),optional :: anaonly
4431character(len=*),intent(in),optional :: template
4432logical, intent(in),optional :: attr_only
4433
4434
4435type(dbadcv) :: vars,starvars,anavars,anastarvars
4436type(dbafilter) :: filter
4437type(dbacoord) :: mydbacoordmin, mydbacoordmax
4438type(dbaana) :: mydbaana
4439type(dbadatetime) :: mydatetimemin, mydatetimemax
4440type(dbatimerange) :: mydbatimerange
4441type(dbalevel) :: mydbalevel
4442type(dbanetwork) :: mydbanetwork
4443
4444integer :: i
4445LOGICAL :: lattr, lanaattr
4446integer :: nanaattr,nattr,nanavar,nvar
4447
4448
4449 ! ------------- prepare filter options
4450
4451!!
4452!! translate export option for dballe2003 api
4453!!
4454
4455if (present(var)) then
4456 nvar=count(c_e(var))
4457 if (nvar > 0) then
4458 allocate (vars%dcv(nvar))
4459 do i=1,size(var)
4460 if (c_e(var(i)))then
4461 allocate (vars%dcv(i)%dat,source=dbadatac(var(i))) !char is default
4462 end if
4463 end do
4464 end if
4465end if
4466
4467if (present(anavar)) then
4468 nanavar=count(c_e(anavar))
4469 if (nanavar > 0) then
4470 allocate (anavars%dcv(nanavar))
4471 do i=1,size(anavar)
4472 if (c_e(anavar(i)))then
4473 allocate (anavars%dcv(i)%dat,source=dbadatac(anavar(i))) !char is default
4474 end if
4475 end do
4476 end if
4477end if
4478
4479lattr = .false.
4480if (present(attr)) then
4481 nattr=count(c_e(attr))
4482 if (nattr > 0) then
4483 lattr = .true.
4484 allocate (starvars%dcv(nattr))
4485 do i=1,size(attr)
4486 if (c_e(attr(i)))then
4487 allocate (starvars%dcv(i)%dat,source=dbadatac(attr(i))) !char is default
4488 end if
4489 end do
4490 end if
4491end if
4492
4493lanaattr = .false.
4494if (present(anaattr)) then
4495 nanaattr=count(c_e(anaattr))
4496 if (nanaattr > 0) then
4497 lanaattr = .true.
4498 allocate (anastarvars%dcv(nanaattr))
4499 do i=1,size(anaattr)
4500 if (c_e(anaattr(i)))then
4501 allocate (anastarvars%dcv(i)%dat,source=dbadatac(anaattr(i))) !char is default
4502 end if
4503 end do
4504 end if
4505end if
4506
4507
4508 ! like a cast
4509mydbacoordmin=dbacoord()
4510if (present(coordmin)) mydbacoordmin%geo_coord=coordmin
4511mydbacoordmax=dbacoord()
4512if (present(coordmax)) mydbacoordmax%geo_coord=coordmax
4513mydbaana=dbaana()
4514if (present(ana)) mydbaana%vol7d_ana=ana
4515mydatetimemin=dbadatetime()
4516if (present(timei)) mydatetimemin%datetime=timei
4517mydatetimemax=dbadatetime()
4518if (present(timef)) mydatetimemax%datetime=timef
4519mydbatimerange=dbatimerange()
4520if (present(timerange)) mydbatimerange%vol7d_timerange=timerange
4521mydbalevel=dbalevel()
4522if (present(level)) mydbalevel%vol7d_level=level
4523mydbanetwork=dbanetwork()
4525
4526!!
4527!! here we have options ready for filter
4528!!
4529filter=dbafilter(coordmin=mydbacoordmin,coordmax=mydbacoordmax,ana=mydbaana, &
4530 datetimemin=mydatetimemin,datetimemax=mydatetimemax, &
4531 timerange=mydbatimerange,level=mydbalevel,network=mydbanetwork,&
4532 vars=vars,starvars=starvars,anavars=anavars,anastarvars=anastarvars,&
4533 dataonly=dataonly,anaonly=anaonly)
4534
4535!!$ print *, "filter:"
4536!!$ call filter%display()
4537
4539
4540end SUBROUTINE vol7d_dballe_export_old
4541
4542
4543subroutine vol7d_dballe_export (this, filter, template, attr_only)
4544
4545TYPE(vol7d_dballe),INTENT(inout) :: this
4546type(dbafilter),intent(in) :: filter
4549character(len=*),intent(in),optional :: template
4550logical, intent(in),optional :: attr_only
4551
4552character(len=40) :: ltemplate
4553
4554type(dbametaanddatalist) :: metaanddatal
4555logical :: stat
4556
4557metaanddatal=dbametaanddatalist()
4558
4559call v7d2dba(this%vol7d,metaanddatal)
4560!call metaanddatal%display()
4561
4562!clean memdb
4563if (this%file) call this%handle%remove_all()
4564
4565! using filter here can limit memory use for memdb
4566call metaanddatal%extrude(session=this%handle,filter=filter,attronly=attr_only,template=template)
4567
4568if (this%file) then
4569 !!!!! this if we have written in memdb and now we have to write the file
4570
4571 !filter is already in extrude
4572 !this%handle%set(filter=filter)
4573
4574 ! export to file
4575 !! TODO : revert template from init to export !!!!!!!!!!!!!!!!!!!!!
4576 !!call this%handle%messages_write_next(template)
4577
4578 ! note that you can use unsetall hera because the filter was used in extrude
4579 call filter%dbaset(this%handle)
4580
4581 ltemplate=this%handle%template
4582 if (present(template))then
4583 ltemplate=template
4584 end if
4585
4586 call this%handle%messages_write_next(ltemplate)
4587
4588 !clean memdb
4589 call this%handle%remove_all()
4590
4591end if
4592
4593stat = metaanddatal%delete()
4594
4595end subroutine vol7d_dballe_export
4596
4597
4598subroutine v7d2dba(v7d,metaanddatal)
4599TYPE(vol7d),INTENT(in) :: v7d !!!!!! dovrebbe essere intent(in)
4600type(dbametaanddatalist),intent(inout) :: metaanddatal
4601
4602TYPE(vol7d_serialize_dballe) :: serialize
4603
4604serialize = vol7d_serialize_dballe_new()
4605serialize%anaonly=.true.
4606call serialize%vol7d_serialize_setup(v7d)
4607call serialize%vol7d_serialize_export(metaanddatal)
4608
4609serialize = vol7d_serialize_dballe_new()
4610serialize%dataonly=.true.
4611call serialize%vol7d_serialize_setup(v7d)
4612call serialize%vol7d_serialize_export(metaanddatal)
4613
4614end subroutine v7d2dba
4615
4616
4618
4622
4627
Emit log message for a category with specific priority. Definition: log4fortran.F90:463 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:218 Classes for handling georeferenced sparse points in geographical corodinates. Definition: geo_coord_class.F90:222 class to use character lists in fortran 2003 WARNING !!!! CHAR LEN IS FIXED TO listcharmaxlen. Definition: list_character.F03:58 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 classe per import ed export di volumi da e in DB-All.e Definition: vol7d_dballe_class.F03:272 Oggetto per import ed export da DB-All.e. Definition: vol7d_dballe_class.F03:296 |