libsim Versione 7.1.11
|
◆ vol7d_dballe_export()
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
2857
2864!use list_mix
2867use vol7d_serialize_dballe_class
2868
2869IMPLICIT NONE
2870
2871character (len=255),parameter:: subcategory="vol7d_dballe_class"
2872
2879
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
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
2909 MODULE PROCEDURE vol7d_dballe_init
2911
2914 MODULE PROCEDURE vol7d_dballe_delete
2916
2917
2919INTERFACE import
2920 MODULE PROCEDURE vol7d_dballe_importvvnv,vol7d_dballe_import, vol7d_dballe_import_old, dba2v7d
2921END INTERFACE import
2922
2925 MODULE PROCEDURE vol7d_dballe_export_old,vol7d_dballe_export, v7d2dba
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
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)
2992
2993 if (present(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
3023this%time_definition = optio_i(time_definition)
3024
3025#ifdef DEBUG
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
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
3064 v7ddbatmp = this ! shallow copy
3065 DO i = 1, SIZE(network)
3067 level,timerange, set_network, attr,anavar,anaattr, varkind, attrkind, &
3068 anavarkind, anaattrkind, anaonly, dataonly, ana)
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
3121#endif
3122
3123
3124IF (PRESENT(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)
3163 if (present(varkind))then
3164 select case (varkind(i))
3165 case("r")
3167 case("i")
3169 case("b")
3171 case("d")
3173 case("c")
3175 case default
3177 CALL raise_fatal_error()
3178 end select
3179 else
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)
3193 if (present(anavarkind))then
3194 select case (anavarkind(i))
3195 case("r")
3197 case("i")
3199 case("b")
3201 case("d")
3203 case("c")
3205 case default
3207 CALL raise_fatal_error()
3208 end select
3209 else
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)
3227 if (present(attrkind))then
3228 select case (attrkind(i))
3229 case("r")
3231 case("i")
3233 case("b")
3235 case("d")
3237 case("c")
3239 case default
3241 CALL raise_fatal_error()
3242 end select
3243 else
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)
3262 if (present(anaattrkind))then
3263 select case (anaattrkind(i))
3264 case("r")
3266 case("i")
3268 case("b")
3270 case("d")
3272 case("c")
3274 case default
3276 CALL raise_fatal_error()
3277 end select
3278 else
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
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
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)
3348 call dba2v7d(this%vol7d, metaanddatav,this%time_definition,set_network)
3350
3351 deallocate (metaanddatav)
3352
3353else
3354 ! empty volume
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)
3373 call dba2v7d(vol7dtmp,metaanddatav,this%time_definition,set_network)
3375
3376 deallocate (metaanddatav)
3377
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
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
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)
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
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
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)
3714 ndativarr = ndativarr + 1
3716 ndativari = ndativari + 1
3718 ndativarb = ndativarb + 1
3720 ndativard = ndativard + 1
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)
3740 ndatiattrr = ndatiattrr + 1
3742 ndatiattri = ndatiattri + 1
3744 ndatiattrb = ndatiattrb + 1
3746 ndatiattrd = ndatiattrd + 1
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
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
3926 type is (dbadatai)
3927 ndativari = ndativari + 1
3929 type is (dbadatab)
3930 ndativarb = ndativarb + 1
3932 type is (dbadatad)
3933 ndativard = ndativard + 1
3935 type is (dbadatac)
3936 ndativarc = ndativarc + 1
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
3957 type is (dbadatai)
3958 ndatiattri = ndatiattri + 1
3960 type is (dbadatab)
3961 ndatiattrb = ndatiattrb + 1
3963 type is (dbadatad)
3964 ndatiattrd = ndatiattrd + 1
3966 type is (dbadatac)
3967 ndatiattrc = ndatiattrc + 1
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
3988 type is (dbadatai)
3989 nanavari = nanavari + 1
3991 type is (dbadatab)
3992 nanavarb = nanavarb + 1
3994 type is (dbadatad)
3995 nanavard = nanavard + 1
3997 type is (dbadatac)
3998 nanavarc = nanavarc + 1
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
4019 type is (dbadatai)
4020 nanaattri = nanaattri + 1
4022 type is (dbadatab)
4023 nanaattrb = nanaattrb + 1
4025 type is (dbadatad)
4026 nanaattrd = nanaattrd + 1
4028 type is (dbadatac)
4029 nanaattrc = nanaattrc + 1
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)
4044 end associate
4045end do
4046
4047do i =1, size(anavars%dcv)
4048 associate(dato => anavars%dcv(i)%dat)
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()
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
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
4753
4757
4762
Emit log message for a category with specific priority. Definition: log4fortran.F90:463 This module defines usefull general purpose function and subroutine. Definition: array_utilities.F90:218 Classes for handling georeferenced sparse points in geographical corodinates. Definition: geo_coord_class.F90:222 class to use character lists in fortran 2003 WARNING !!!! CHAR LEN IS FIXED TO listcharmaxlen. Definition: list_character.F03:58 Classe per la gestione di un volume completo di dati osservati. Definition: vol7d_class.F90:279 classe per import ed export di volumi da e in DB-All.e Definition: vol7d_dballe_class.F03:272 Oggetto per import ed export da DB-All.e. Definition: vol7d_dballe_class.F03:296 |