libsim Versione 7.1.11

◆ 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 
)
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 2778 del file vol7d_dballe_class.F03.

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