87character (len=255),
parameter:: subcategorytem=
"QCtem"
89integer,
parameter :: tem_nvar=1
90CHARACTER(len=10) :: tem_btable(tem_nvar)=(/
"B12101"/)
92real,
parameter :: tem_a(tem_nvar) = (/1.e5/)
94real,
parameter :: tem_b(tem_nvar) = (/250./)
98 type (vol7d),
pointer :: v7d => null()
99 integer,
pointer :: data_id_in(:,:,:,:,:) => null()
100 integer,
pointer :: data_id_out(:,:,:,:,:) => null()
102 type (qcclitype) :: qccli
103 type (vol7d) :: clima
104 character(len=20):: operation
105 integer :: timeconfidence
111 module procedure qcteminit
116 module procedure qctemalloc
121 module procedure qctemdelete
134subroutine qcteminit(qctem,v7d,var, timei, timef, coordmin, coordmax, data_id_in,extremepath,temporalpath,&
136 dsne,usere,passworde,&
137 dsntem,usertem,passwordtem,&
139 height2level,operation,timeconfidence,categoryappend)
141type(qctemtype),
intent(in out) :: qctem
142type (vol7d),
intent(in),
target:: v7d
143character(len=*),
INTENT(in) :: var(:)
146TYPE(geo_coord),
INTENT(inout),
optional :: coordmin,coordmax
148TYPE(datetime),
INTENT(in),
optional :: timei, timef
149integer,
intent(in),
optional,
target:: data_id_in(:,:,:,:,:)
150character(len=*),
intent(in),
optional :: extremepath
151character(len=*),
intent(in),
optional :: temporalpath
152logical ,
intent(in),
optional :: height2level
153character(len=*),
optional :: operation
154integer,
intent(in),
optional :: timeconfidence
155character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
158type (vol7d_dballe) :: v7d_dballetmp
159character(len=*),
intent(in),
optional :: dsne
160character(len=*),
intent(in),
optional :: usere
161character(len=*),
intent(in),
optional :: passworde
162character(len=*),
intent(in),
optional :: dsntem
163character(len=*),
intent(in),
optional :: usertem
164character(len=*),
intent(in),
optional :: passwordtem
165character(len=512) :: ldsntem
166character(len=512) :: lusertem
167character(len=512) :: lpasswordtem
170type (vol7d) :: v7dtmp
171TYPE(vol7d_network):: network
173character(len=512) :: filepathtem
174character(len=512) :: a_name
175character(len=9) ::netname(2)=(/
"qctemgndi",
"qctemsndi"/)
178call l4f_launcher(a_name,a_name_append=trim(subcategorytem)//
"."//trim(categoryappend))
179qctem%category=l4f_category_get(a_name)
181nullify ( qctem%data_id_in )
182nullify ( qctem%data_id_out )
187qctem%operation=optio_c(operation,20)
188filepathtem=optio_c(temporalpath,512)
191if (qctem%operation /=
"gradient" .and. qctem%operation /=
"run")
then
192 call l4f_category_log(qctem%category,l4f_error,
"operation is wrong: "//qctem%operation)
197if (
present(data_id_in))
then
198 qctem%data_id_in => data_id_in
201qctem%timeconfidence = optio_i(timeconfidence)
204call init(qctem%qccli,v7d,var, timei, timef, data_id_in,&
205 macropath=cmiss, climapath=cmiss, extremepath=extremepath, &
207 dsncli=cmiss,dsnextreme=dsne,user=usere,password=passworde,&
209 height2level=height2level,categoryappend=categoryappend)
216 if (qctem%operation ==
"run")
then
217 call init(network,netname(i))
220 call optio(dsntem,ldsntem)
221 call optio(usertem,lusertem)
222 call optio(passwordtem,lpasswordtem)
224 if (
c_e(filepathtem) .and. (
c_e(ldsntem).or.
c_e(lusertem).or.
c_e(lpasswordtem)))
then
225 call l4f_category_log(qctem%category,l4f_error,
"filepath defined together with dba options")
229 if (.not.
c_e(ldsntem))
then
233 if (.not.
c_e(filepathtem))
then
234 filepathtem=get_package_filepath(netname(i)//
'.v7d', filetype_data)
237 if (
c_e(filepathtem))
then
239 select case (trim(lowercase(suffixname(filepathtem))))
243 call import(v7dtmp,filename=filepathtem,unit=iuni)
248 call init(v7d_dballetmp,file=.true.,filename=filepathtem,categoryappend=trim(a_name)//
".clima")
249 call import(v7d_dballetmp,var=var, &
250 varkind=(/(
"r",i=1,
size(var))/),attr=(/
"*B33209"/),attrkind=(/
"b"/),network=network)
251 call copy(v7d_dballetmp%vol7d,v7dtmp)
252 call delete(v7d_dballetmp)
257 "file type not supported (use .v7d or .bufr suffix only): "//trim(filepathtem))
262 call l4f_category_log(qctem%category,l4f_warn,
"spatial clima volume not iniziatized: spatial QC will not be possible")
263 call init(qctem%clima)
264 call raise_fatal_error()
271 call init(v7d_dballetmp,dsn=ldsntem,user=lusertem,password=lpasswordtem,write=.false.,&
272 file=.false.,categoryappend=trim(a_name)//
".tem")
274 call import(v7d_dballetmp,var=var, &
275 varkind=(/(
"r",i=1,
size(var))/),attr=(/
"*B33209"/),attrkind=(/
"b"/),network=network)
277 call copy(v7d_dballetmp%vol7d,v7dtmp)
279 call delete(v7d_dballetmp)
283 call vol7d_merge(qctem%clima,v7dtmp)
290end subroutine qcteminit
295subroutine qctemalloc(qctem)
298type(qctemtype),
intent(in out) :: qctem
304call qctemdealloc(qctem)
306if (
associated(qctem%data_id_in))
then
307 sh=shape(qctem%data_id_in)
308 allocate (qctem%data_id_out(sh(1),sh(2),sh(3),sh(4),sh(5)),stat=istatt)
311 call raise_error(
"allocate error")
313 qctem%data_id_out=imiss
317end subroutine qctemalloc
321subroutine qctemdealloc(qctem)
326if (
associated(qctem%data_id_out))
deallocate (qctem%data_id_out)
328if (
associated(qctem%data_id_out))
then
329 deallocate (qctem%data_id_out)
330 nullify (qctem%data_id_out)
333end subroutine qctemdealloc
339subroutine qctemdelete(qctem)
343call qctemdealloc(qctem)
348call l4f_category_delete(qctem%category)
351end subroutine qctemdelete
357SUBROUTINE quacontem (qctem,battrinv,battrcli,battrout,&
358 anamask,timemask,levelmask,timerangemask,varmask,networkmask)
362character (len=10) ,
intent(in),
optional :: battrinv
363character (len=10) ,
intent(in),
optional :: battrcli
364character (len=10) ,
intent(in),
optional :: battrout
365logical ,
intent(in),
optional :: anamask(:)
366logical ,
intent(in),
optional :: timemask(:)
367logical ,
intent(in),
optional :: levelmask(:)
368logical ,
intent(in),
optional :: timerangemask(:)
369logical ,
intent(in),
optional :: varmask(:)
370logical ,
intent(in),
optional :: networkmask(:)
375integer :: indbattrinv,indbattrcli,indbattrout,grunit
376logical :: anamaskl(size(qctem%v7d%ana)), timemaskl(size(qctem%v7d%time)), levelmaskl(size(qctem%v7d%level)), &
377 timerangemaskl(size(qctem%v7d%timerange)), varmaskl(size(qctem%v7d%dativar%r)), networkmaskl(size(qctem%v7d%network))
379integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork,indtimenear
380integer :: indcana , indctime ,indclevel ,indctimerange ,indcdativarr, indcnetwork, indcnetworks, indcnetworkg
381real :: datoqui,datoprima,datodopo,climaquii, climaquif
385TYPE(
datetime) :: time,prima, ora, dopo
386TYPE(vol7d_network):: network
389double precision :: gradprima,graddopo,grad
391character(len=512) :: filename
396if (
present(battrinv))
then
397 indbattrinv = index_c(qctem%v7d%datiattr%b(:)%btable, battrinv)
399 indbattrinv = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(1))
402if (
present(battrcli))
then
403 indbattrcli = index_c(qctem%v7d%datiattr%b(:)%btable, battrcli)
405 indbattrcli = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(2))
408if (
present(battrout))
then
409 indbattrout = index_c(qctem%v7d%datiattr%b(:)%btable, battrout)
411 indbattrout = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(3))
417if (indbattrout <= 0 )
then
419 call l4f_category_log(qctem%category,l4f_error,
"error finding attribute index for output")
424if (qctem%operation ==
"gradient")
then
427 if (
size(qctem%v7d%level) > 1 .or.&
428 size(qctem%v7d%timerange) > 1 .or.&
429 size(qctem%v7d%dativar%r) > 1 )
then
430 call l4f_category_log(qctem%category,l4f_error,
"gradient operation manage one level/timerange/var only")
435 if (
size(qctem%v7d%time) < 1 )
then
436 call l4f_category_log(qctem%category,l4f_info,
"no data present for gradient operation")
442if(
present(anamask))
then
447if(
present(timemask))
then
452if(
present(levelmask))
then
453 levelmaskl = levelmask
457if(
present(timerangemask))
then
458 timerangemaskl = timerangemask
460 timerangemaskl = .true.
462if(
present(varmask))
then
467if(
present(networkmask))
then
468 networkmaskl = networkmask
470 networkmaskl = .true.
474qctem%v7d%voldatiattrb(:,:,:,:,:,:,indbattrout)=ibmiss
477call vol7d_normalize_data(qctem%qccli)
483time=cyclicdatetime_to_conventional(cyclicdatetime_new(chardate=
"/////////"))
487if (qctem%operation ==
"run")
then
489 call init(network,
"qctemsndi")
490 indcnetworks =
index(qctem%clima%network , network)
491 call init(network,
"qctemgndi")
492 indcnetworkg =
index(qctem%clima%network , network)
493 indctime =
index(qctem%clima%time , time)
496do indana=1,
size(qctem%v7d%ana)
497 if (.not.anamaskl(indana)) cycle
499 "Check ana:"//
to_char(qctem%v7d%ana(indana)) )
501 do indnetwork=1,
size(qctem%v7d%network)
502 do indlevel=1,
size(qctem%v7d%level)
503 do indtimerange=1,
size(qctem%v7d%timerange)
504 do inddativarr=1,
size(qctem%v7d%dativar%r)
505 ind=index_c(tem_btable,qctem%v7d%dativar%r(inddativarr)%btable)
507 if (qctem%operation ==
"gradient")
then
513 filename=trim(
to_char(qctem%v7d%level(indlevel)))//&
514 "_"//trim(
to_char(qctem%v7d%timerange(indtimerange)))//&
515 "_"//trim(qctem%v7d%dativar%r(inddativarr)%btable)//&
518 call l4f_category_log(qctem%category,l4f_info,
"try to open gradient file; filename below")
521 inquire(file=filename, exist=exist)
524 if (grunit /= -1)
then
526 open (grunit, file=filename ,status=
'UNKNOWN', form=
'FORMATTED',position=
'APPEND')
529 if (.not. exist)
then
530 call l4f_category_log(qctem%category,l4f_info,
"write header in gradient file")
532 qctem%v7d%level(indlevel), &
533 qctem%v7d%timerange(indtimerange), &
534 qctem%v7d%dativar%r(inddativarr)
542 do indtime=2,
size(qctem%v7d%time)-1
544 if (.not.timemaskl(indtime).or. .not. levelmaskl(indlevel).or. &
545 .not. timerangemaskl(indtimerange) .or. .not. varmaskl(inddativarr) .or. .not. networkmaskl(indnetwork)) cycle
548 datoqui = qctem%v7d%voldatir (indana ,indtime ,indlevel ,indtimerange ,inddativarr, indnetwork )
549 if (.not.
c_e(datoqui)) cycle
550 ora = qctem%v7d%time (indtime)
553 if (indbattrinv > 0)
then
555 (indana,indtime,indlevel,indtimerange,inddativarr,indnetwork,indbattrinv)))
then
557 "It's better to do a reform on ana to v7d after peeling, before spatial QC")
563 if (indbattrcli > 0)
then
564 if( .not.
vdge(qctem%v7d%voldatiattrb&
565 (indana,indtime,indlevel,indtimerange,inddativarr,indnetwork,indbattrcli)))
then
567 "It's better to do a reform on ana to v7d after peeling, before spatial QC")
574 if (qctem%operation ==
"run")
then
576 indclevel =
index(qctem%clima%level , qctem%v7d%level(indlevel))
577 indctimerange =
index(qctem%clima%timerange , qctem%v7d%timerange(indtimerange))
581 indcdativarr =
index(qctem%clima%dativar%r, qctem%v7d%dativar%r(inddativarr))
584 call l4f_log(l4f_debug,
"QCtem Index:"//
to_char(indctime)//
to_char(indclevel)//&
587 if ( indctime <= 0 .or. indclevel <= 0 .or. indctimerange <= 0 .or. indcdativarr <= 0 &
588 .or. indcnetworks <= 0 ) cycle
597 indtimenear=indtime-1
598 datoprima = qctem%v7d%voldatir (indana ,indtimenear ,indlevel ,indtimerange ,inddativarr, indnetwork )
599 prima = qctem%v7d%time (indtimenear)
602 if (indbattrinv > 0)
then
604 (indana,indtimenear,indlevel,indtimerange,inddativarr,indnetwork,indbattrinv)))
then
610 if (indbattrcli > 0)
then
611 if( .not.
vdge(qctem%v7d%voldatiattrb&
612 (indana,indtimenear,indlevel,indtimerange,inddativarr,indnetwork,indbattrcli)))
then
619 indtimenear=indtime+1
620 datodopo = qctem%v7d%voldatir (indana ,indtimenear ,indlevel ,indtimerange ,inddativarr, indnetwork )
621 dopo = qctem%v7d%time (indtimenear)
624 if (indbattrinv > 0)
then
626 (indana,indtimenear,indlevel,indtimerange,inddativarr,indnetwork,indbattrinv)))
then
632 if (indbattrcli > 0)
then
633 if( .not.
vdge(qctem%v7d%voldatiattrb&
634 (indana,indtimenear,indlevel,indtimerange,inddativarr,indnetwork,indbattrcli)))
then
640 IF(.NOT.
c_e(datoprima) .and. .NOT.
c_e(datodopo) ) cycle
649 if ((
c_e(qctem%timeconfidence) .and. asec <= qctem%timeconfidence) .or. &
650 .not.
c_e(qctem%timeconfidence))
then
651 if (
c_e(datoprima)) gradprima=(datoqui-datoprima) / dble(asec)
656 if ((
c_e(qctem%timeconfidence) .and. asec <= qctem%timeconfidence) .or. &
657 .not.
c_e(qctem%timeconfidence))
then
658 if (
c_e(datodopo)) graddopo =(datodopo-datoqui ) / dble(asec)
663 call l4f_log(l4f_debug,
"QCtem gradprima:"//
to_char(gradprima)//
" graddopo:"//
to_char(graddopo))
666 IF(.NOT.
c_e(gradprima) .and. .NOT.
c_e(graddopo) ) cycle
671 IF(.NOT.
c_e(gradprima) )
then
674 grad= sign(
abs(graddopo),-1.d0)
676 else IF(.NOT.
c_e(graddopo) )
then
679 grad= sign(
abs(gradprima),-1.d0)
683 if (
abs(max(
abs(gradprima),
abs(graddopo))-min(
abs(gradprima),
abs(graddopo))) < &
684 max(
abs(gradprima),
abs(graddopo))/2. .and. (sign(1.d0,gradprima)*sign(1.d0,graddopo)) < 0.)
then
686 grad= min(
abs(gradprima),
abs(graddopo))
689 grad= sign(max(
abs(gradprima),
abs(graddopo)),-1.d0)
693 if (qctem%operation ==
"gradient")
then
698 if (qctem%operation ==
"run")
then
703 call l4f_log(l4f_debug,
"QCtem choice gradient type: spike")
705 indcnetwork=indcnetworks
708 call l4f_log(l4f_debug,
"QCtem choice gradient type: gradmax")
710 indcnetwork=indcnetworkg
714 call l4f_log(l4f_debug,
"gradiente da confrontare con QCtem clima:"//
t2c(grad))
716 do indcana=1,
size(qctem%clima%ana)
718 climaquii=(qctem%clima%voldatir(indcana &
719 ,indctime,indclevel,indctimerange,indcdativarr,indcnetwork)&
720 -tem_b(ind))/tem_a(ind)
722 climaquif=(qctem%clima%voldatir(min(indcana+1,
size(qctem%clima%ana)) &
723 ,indctime,indclevel,indctimerange,indcdativarr,indcnetwork)&
724 -tem_b(ind))/tem_a(ind)
727 call l4f_log(l4f_debug,
"QCtem clima start:"//
t2c(climaquii))
728 call l4f_log(l4f_debug,
"QCtem clima end:"//
t2c(climaquif))
730 if (
c_e(climaquii) .and.
c_e(climaquif ))
then
732 if ( (grad >= climaquii .and. grad < climaquif) .or. &
733 (indcana == 1 .and. grad < climaquii) .or. &
734 (indcana ==
size(qctem%clima%ana) .and. grad >= climaquif) )
then
737 call l4f_log(l4f_debug,
"QCtem confidence:"//
t2c(qctem%clima%voldatiattrb&
738 (indcana,indctime,indclevel,indctimerange,indcdativarr,indcnetwork,1)))
741 qctem%v7d%voldatiattrb( indana, indtime, indlevel, indtimerange, inddativarr, indnetwork, indbattrout)=&
742 qctem%clima%voldatiattrb(indcana,indctime,indclevel,indctimerange,indcdativarr,indcnetwork,1 )
744 if (
associated ( qctem%data_id_in))
then
746 call l4f_log (l4f_debug,
"id: "//
t2c(&
747 qctem%data_id_in(indana,indtime,indlevel,indtimerange,indnetwork)))
749 qctem%data_id_out(indana,indtime,indlevel,indtimerange,indnetwork)=&
750 qctem%data_id_in(indana,indtime,indlevel,indtimerange,indnetwork)
762 if (qctem%operation ==
"gradient")
then
774end subroutine quacontem
Set of functions that return a trimmed CHARACTER representation of the input variable.
Set of functions that return a CHARACTER representation of the input variable.
Operatore di valore assoluto di un intervallo.
Restituiscono il valore dell'oggetto nella forma desiderata.
Emit log message for a category with specific priority.
Check data validity based on gross error check.
Utilities for CHARACTER variables.
Classi per la gestione delle coordinate temporali.
Utilities for managing files.
classe per la gestione del logging
Utilities and defines for quality control.
Controllo di qualità climatico.
Controllo di qualità temporale.
Classe per la gestione di un volume completo di dati osservati.
classe per import ed export di volumi da e in DB-All.e
Class for expressing an absolute time value.
Class for expressing a relative time interval.
Oggetto principale per il controllo di qualità
Oggetto principale per il controllo di qualità
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...