libsim Versione 7.2.1

◆ vol7d_dballe_export()

subroutine vol7d_dballe_export ( type(vol7d_dballe), intent(inout) this,
type(dbafilter), intent(in) filter,
character(len=*), intent(in), optional template,
logical, intent(in), optional attr_only )
private
Parametri
[in,out]thisoggetto contenente il volume e altre info per l'accesso al DSN
[in]filterfilter o use
[in]templatespecificando category.subcategory.localcategory oppure un alias ("synop", "metar","temp","generic") forza l'exportazione ad uno specifico template BUFR/CREX" the special value "generic-frag is used to generate bufr on file where ana data is reported only once at beginning and data in other bufr after
[in]attr_onlyset to .true. to export attr only (no data)

Definizione alla linea 2772 del file vol7d_dballe_class.F03.

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

Generated with Doxygen.