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