SUBROUTINE CH_GETOBSERR(KNUM,KLEM,KPARM,KHR,KLIST,PVALUES,PPROF 1,2
& ,KELE,KVAL,KNT,KIIND,LDERR,KELESTD
& ,KLISTSTD,PSTDDEV,KMXL,CDSTNID)
#if defined (DOC)
*
***s/r CH_GETOBSERR -- Set observation std. dev. for chemistry species
*
*Author .Y. Yang June 2004
*
*Revision:
*
* .Y. Yang Feb. 2005
* - Removed 'OZ' part
* .Y.J. Rochon, AQRX/MSC May 2005
* - Cleanup
* - Input for KLEM and KNUM for consideration of
* multiple data types in a block.
* .Y.J. Rochon and Y. Yang, March 2006
* - Modified choices.
* .Y.J. Rochon, June 2006, March 2007
* - Generalization to allow setting of std. dev.
* when std. dev. not available in the BURP file.
* .Y.J. Rochon, Aug 2010
* - Added input of CDSTNID and use of CH_KGETPOS
*
* PURPOSE: Assign observation std. dev. for chemistry species
* according to user's specification controlled
* by IFLGERR (=NFLGSTDTR).
*
* Let a=RSCALER=SCALERRTR, b=ROBSERR=ROBSSTDTR,
* s = std.dev. in BURP file, x=obs. from BURP file
* (s set to zero if not available from the BURP file)
*
* Default values: a=1.0, b=0.0
*
* If IFLGERR = -1: Error statistics will be assigned in sucovo
* (not valid at this time)
* = 0: Final std. dev. set to
*
* b*x/100 + a*s
*
* = 1: Final std. dev. set to
*
* b + a*s
*
* = 2: Final std. dev. set to
*
* sqrt{[a*x/100]^2 + [max(0.01x,max(b,s))]^2}
*
* Scheme from BASCOE/BIRA (S. Chabrillat)
* Suggested values with IFLGERR=2:
*
* a=5.0
*
* Species Value for "b"
* O3 8.E-9
* H2O 1.E-7
* N2O 1.E-9
* NO2 1.E-9
* HNO3 1.E-9
* CH4 1.E-8
*
* ARGUMENTS:
* INPUT:
*
* KLEM : Element index in list
* KNUM : IF KNUM>0, position index within list.
* Order and number of elements in std. dev. block assumed
* same as order and number of species/dynamics obs if data block.
* Otherwise (KNUM=0), first element of std. dev. block satisfying
* search condition is used
* KPARM : Species ID
* KHR : index in the 3rd dimension of the record to be read
* KLIST : List of elements in the data block represented by PVALUES
* PVALUES : one data record from BURP file
* KELE : number of elements in KLIST
* KVAL : number of vertical levels in this record
* KNT : the 3rd dimension of the record
* KLISTSTD : list of elements in the obs. error block represented by PSTDDEV
* Order and sequence should be identical to the species
* obs in data block when KNUM>0.
* PSTDDEV : std. dev. record from BURP file
* KELESTD : number of elements in KLISTSTD
* Should be identical to the number of species obs in data block
* when KNUM>0. Otherwise, will assume that there are no
* repeated elements in the std. dev. block.
* KMXL : Max size of PSTDDEV
* CDSTNID : Station id.
*
* OUTPUT:
*
* LDERR : .TRUE. for missing std. dev.
* PPROF : the profile of observation std. dev.
* KIIND : index of the obs. std. dev.
* = -1: the obs. std. dev. is not assigned
* >0 : the index in the KLIST corresponds to
* the error statistics read from BURP file.
* =999: the std. dev. is not read in from BURP file
* but is specified by user.
*
*
#endif
*
IMPLICIT NONE
#include "comlun.cdk"
#include "comdim.cdk"
#include "comchem.cdk"
*
CHARACTER*(*) CDSTNID
INTEGER KPARM,KHR,KLEM,KNUM
INTEGER KELE,KVAL,KNT
INTEGER KELESTD,KMXL
INTEGER KLIST(KELE), KLISTSTD(KELE)
*
REAL*8 PVALUES(KELE,KVAL,KNT),PPROF(KVAL)
REAL*8 PSTDDEV(KMXL)
*
LOGICAL LDERR
INTEGER KIIND, INDEX
INTEGER IFLGERR
REAL*8 ROBSERR, RSCALERR
INTEGER JJ,IK, II
REAL*8 Z1,Z2,Z3
*
INTEGER CH_KGETPOS
EXTERNAL CH_KGETPOS
************************************************************************
*
INDEX = -1
KIIND = -1
LDERR = .TRUE.
C
C Define parameters for obs. error and scaling
C for chemistry species
C
INDEX=CH_KGETPOS(KLIST(KLEM),KPARM,CDSTNID)
if (INDEX .lt.0) then
write(nulout, *) ' CH_GETOBSERR: WARNING!!! No matching species found.'
return
endif
IFLGERR = NFLGSTDTR(INDEX)
ROBSERR = ROBSSTDTR(INDEX)
RSCALERR= SCALERRTR(INDEX)
C
C Assign final error std. dev.
C
if (IFLGERR.lt.0.or.IFLGERR.gt.2) then
C
C Obs. std. dev. will be assigned in sucovo (THIS OPTION NOT AVAILABLE!!!)
C
write(nulout, *) ' CH_GETOBSERR: ERROR! No assigned std. dev.'
C
else
C
C An obs. error std. dev. is assumed to have been read
C from the BURP file or can be set here using ROBSERR or RSCALERR.
C
KIIND=-1
IF (KELESTD.GT.0) THEN
IF (KNUM.GT.0) THEN
C
C Order and number of elements in std. dev. block assumed
C same as order and number of species/dynamics in data block.
C (Blocks should have number of total number of elements.)
C
KIIND=KNUM-1
CALL CH_GETELEX(NETR(INDEX),KHR,KLISTSTD,PSTDDEV,
+ PPROF,KELESTD,KVAL,KNT,KIIND)
ELSE
C
C Obtain first element satisfying search condition
C
CALL GETELE(NETR(INDEX),KHR,KLISTSTD,PSTDDEV,
+ PPROF,KELESTD,KVAL,KNT,KIIND)
END IF
END IF
C
IF (KIIND.GT.0) THEN
LDERR=.FALSE.
ELSE
IF (ROBSERR.GT.1.E-20.or.
& (IFLGERR.eq.2.and.RSCALERR.GT.1.E-20)) THEN
C
KIIND=999
LDERR=.FALSE.
PPROF(1:KVAL)=0.0D0
ELSE
write(nulout, *) ' CH_GETOBSERR: ERROR! Std. dev. ',
& 'not found in BURP fie.'
KIIND=-1
LDERR=.TRUE.
write(nulout, *) ' CH_GETOBSERR: ERROR 2! No assigned std. dev.'
RETURN
END IF
END IF
end if
C
C Set obs std. dev.
C
if (IFLGERR .eq. 0) then
C
DO JJ=1,KVAL
PPROF(JJ) = ROBSERR/100.0*PVALUES(KLEM,JJ,KHR) + PPROF(JJ)*RSCALERR
ENDDO
C
else if (IFLGERR .eq. 1) then
C
DO JJ=1,KVAL
PPROF(JJ) = ROBSERR+RSCALERR*PPROF(JJ)
ENDDO
C
else
C
DO JJ=1,KVAL
Z1=MAX(PPROF(JJ),ROBSERR)
Z1=MAX(0.01*PVALUES(KLEM,JJ,KHR),Z1)
Z2=RSCALERR/100.0*PVALUES(KLEM,JJ,KHR)
PPROF(JJ) = sqrt(Z1*Z1+Z2*Z2)
ENDDO
C
end if
C
RETURN
END