87 character (len=255),
parameter:: subcategorytem=
"QCtem"
89 integer,
parameter :: tem_nvar=1
90 CHARACTER(len=10) :: tem_btable(tem_nvar)=(/
"B12101"/)
92 real,
parameter :: tem_a(tem_nvar) = (/1.e5/)
94 real,
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()
103 type (
vol7d) :: clima
104 character(len=20):: operation
105 integer :: timeconfidence
111 module procedure qcteminit
116 module procedure qctemalloc
121 module procedure qctemdelete
134 subroutine 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)
142 type (
vol7d),
intent(in),
target:: v7d
143 character(len=*),
INTENT(in) :: var(:)
146 type(geo_coord),
INTENT(inout),
optional :: coordmin,coordmax
148 TYPE(datetime
),
INTENT(in),
optional :: timei, timef
149 integer,
intent(in),
optional,
target:: data_id_in(:,:,:,:,:)
150 character(len=*),
intent(in),
optional :: extremepath
151 character(len=*),
intent(in),
optional :: temporalpath
152 logical ,
intent(in),
optional :: height2level
153 character(len=*),
optional :: operation
154 integer,
intent(in),
optional :: timeconfidence
155 character(len=*),
INTENT(in),
OPTIONAL :: categoryappend
159 character(len=*),
intent(in),
optional :: dsne
160 character(len=*),
intent(in),
optional :: usere
161 character(len=*),
intent(in),
optional :: passworde
162 character(len=*),
intent(in),
optional :: dsntem
163 character(len=*),
intent(in),
optional :: usertem
164 character(len=*),
intent(in),
optional :: passwordtem
165 character(len=512) :: ldsntem
166 character(len=512) :: lusertem
167 character(len=512) :: lpasswordtem
170 type (vol7d) :: v7dtmp
171 TYPE(vol7d_network
):: network
173 character(len=512) :: filepathtem
174 character(len=512) :: a_name
175 character(len=9) ::netname(2)=(/
"qctemgndi",
"qctemsndi"/)
178 call l4f_launcher(a_name,a_name_append=trim(subcategorytem)//
"."//trim(categoryappend))
179 qctem%category=l4f_category_get(a_name)
181 nullify( qctem%data_id_in )
182 nullify( qctem%data_id_out )
187 qctem%operation=optio_c(operation,20)
188 filepathtem=optio_c(temporalpath,512)
191 if (qctem%operation /=
"gradient" .and. qctem%operation /=
"run")
then
192 call
l4f_category_log(qctem%category,l4f_error,
"operation is wrong: "//qctem%operation)
197 if (present(data_id_in))
then
198 qctem%data_id_in => data_id_in
201 qctem%timeconfidence = optio_i(timeconfidence)
204 call
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)
283 call vol7d_merge(qctem%clima,v7dtmp)
290 end subroutine qcteminit
295 subroutine qctemalloc(qctem)
304 call qctemdealloc(qctem)
306 if (
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
317 end subroutine qctemalloc
321 subroutine qctemdealloc(qctem)
326 if (
associated(qctem%data_id_out))
deallocate (qctem%data_id_out)
328 if (
associated(qctem%data_id_out))
then
329 deallocate (qctem%data_id_out)
330 nullify(qctem%data_id_out)
333 end subroutine qctemdealloc
339 subroutine qctemdelete(qctem)
343 call qctemdealloc(qctem)
348 call l4f_category_delete(qctem%category)
351 end subroutine qctemdelete
357 SUBROUTINE quacontem (qctem,battrinv,battrcli,battrout,&
358 anamask,timemask,levelmask,timerangemask,varmask,networkmask)
362 character (len=10) ,
intent(in),
optional :: battrinv
363 character (len=10) ,
intent(in),
optional :: battrcli
364 character (len=10) ,
intent(in),
optional :: battrout
365 logical ,
intent(in),
optional :: anamask(:)
366 logical ,
intent(in),
optional :: timemask(:)
367 logical ,
intent(in),
optional :: levelmask(:)
368 logical ,
intent(in),
optional :: timerangemask(:)
369 logical ,
intent(in),
optional :: varmask(:)
370 logical ,
intent(in),
optional :: networkmask(:)
375 integer :: indbattrinv,indbattrcli,indbattrout,grunit
376 logical :: 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))
379 integer :: indana , indtime ,indlevel ,indtimerange ,inddativarr, indnetwork,indtimenear
380 integer :: indcana , indctime ,indclevel ,indctimerange ,indcdativarr, indcnetwork, indcnetworks, indcnetworkg
381 real :: datoqui,datoprima,datodopo,climaquii, climaquif
385 TYPE(datetime
) :: time,prima, ora, dopo
386 TYPE(vol7d_network
):: network
389 double precision :: gradprima,graddopo,grad
391 character(len=512) :: filename
396 if (present(battrinv))
then
397 indbattrinv = index_c(qctem%v7d%datiattr%b(:)%btable, battrinv)
399 indbattrinv = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(1))
402 if (present(battrcli))
then
403 indbattrcli = index_c(qctem%v7d%datiattr%b(:)%btable, battrcli)
405 indbattrcli = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(2))
408 if (present(battrout))
then
409 indbattrout = index_c(qctem%v7d%datiattr%b(:)%btable, battrout)
411 indbattrout = index_c(qctem%v7d%datiattr%b(:)%btable, qcattrvarsbtables(3))
417 if (indbattrout <= 0 )
then
419 call
l4f_category_log(qctem%category,l4f_error,
"error finding attribute index for output")
424 if (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")
442 if(present(anamask))
then
447 if(present(timemask))
then
452 if(present(levelmask))
then
453 levelmaskl = levelmask
457 if(present(timerangemask))
then
458 timerangemaskl = timerangemask
460 timerangemaskl = .true.
462 if(present(varmask))
then
467 if(present(networkmask))
then
468 networkmaskl = networkmask
470 networkmaskl = .true.
474 qctem%v7d%voldatiattrb(:,:,:,:,:,:,indbattrout)=ibmiss
477 call vol7d_normalize_data(qctem%qccli)
483 time=cyclicdatetime_to_conventional(cyclicdatetime_new(chardate=
"/////////"))
487 if (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)
496 do 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
774 end subroutine quacontem
Classi per la gestione delle coordinate temporali.
Functions that return a trimmed CHARACTER representation of the input variable.
Check data validity based on gross error check.
Operatore di valore assoluto di un intervallo.
Oggetto per import ed export da DB-All.e.
Oggetto principale per il controllo di qualità
Generic subroutine for checking OPTIONAL parameters.
Classe per la gestione di un volume completo di dati osservati.
Restituiscono il valore dell'oggetto in forma di stringa stampabile.
Controllo di qualità temporale.
Restituiscono il valore dell'oggetto nella forma desiderata.
Definisce un oggetto contenente i volumi anagrafica e dati e tutti i descrittori delle loro dimension...
Controllo di qualità climatico.
Oggetto principale per il controllo di qualità
Copy an object, creating a fully new instance.
classe per import ed export di volumi da e in DB-All.e
Utilities and defines for quality control.
Class for expressing a relative time interval.
classe per la gestione del logging
Utilities for CHARACTER variables.
Utilities for managing files.
Emit log message for a category with specific priority.