!-------------------------------------- LICENCE BEGIN ------------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!
SUBROUTINE SUASYM2(lobsSpaceData) 1,39
#if defined (DOC)
*
*s/r SUASYM - SET CERTAIN PARAMETERS FOR THE ASYMMETRIC
* CHECK AND FOR VARIATIONAL QUALITY CONTROL
*
*Author : B. BRASNETT CMDA JUNE 1999
*Revision:
* S. Pellerin ARMA/SMC Nov. 2002
* . Elemination of nincrem variable
* R. Sarrazin/B. Brasnett CMC March 2004
* . tighten rejection on satwinds
* J. Hale CMC Sept. 2005
* . added MHS (codtyp=182).
* S. Macpherson ARMA/CMC Sept. 2007
* . add parameters for GB-GPS ZTD
* S. Macpherson ARMA/CMC March 2013
* . modified GPS ZTD parameters to increase QC-Var rejections
*
*Arguments
*
#endif
use MathPhysConstants_mod
use obsSpaceData_mod
use bufr
IMPLICIT NONE
type(struct_obs) :: lobsSpaceData
*
INTEGER JDATA,KINDIC,ITER,JJO,IDATA,IDATEND,IDBURP
INTEGER ITYP,IASS,IFLD,IOTHER,JJ,ISTYP,ILEV
real(8) ZAGZ,ZAHU,ZATT,ZDUV,ZDGZ,ZDTT,ZDHU,ZAUV,ZSLEV,ZAPN,ZDPN
real(8) ZABT,ZDBT,ZABTB,ZDBTB
real(8) ZLEV,ZJO,ZVAL,ZSPDO,ZSPDF,ZOFCST,ZOVAL,ZDIFF,ZAASYM,ZOER
real(8) ZFCST,ZLAT,ZLON,ZPRIOR,ZAPS,ZDPS,ZAUVRA,ZATTRA,ZATTSYM
LOGICAL LLOK
real(8) ZAZD, ZDZD
*
*_____prior probabilities for winds:ZAUV
* prior probabilities for scalar variables: zagz and zahu
* standard deviation multiple for background check for winds: zduv
* standard deviation multiple for background check for heights: zdgz
* standard deviation multiple for background check for humidity: zdhu
*
ZAGZ = 1.d-12
ZATT = 5.d-2
* ZATTRA = 1.d-2
ZATTRA = 0.005d0
* ZAUV = 0.01d0
ZAUV = 0.02d0
* ZAUVRA = 1.d-3
ZAUVRA = 1.d-5
* ZAHU = 0.01d0
ZAHU = 0.05d0
ZAPN = 1.d-4
ZAPS = 1.d-4
ZABT = 1.0d-1
ZABTB = 1.0d-1
ZATTSYM = 1.d-1
ZAZD = 2.0d-2
ZDUV = 5.d0
ZDGZ = 5.d0
ZDTT = 5.d0
ZDHU = 5.d0
ZDPN = 5.d0
ZDPS = 5.d0
ZDBT = 3.d0
ZDBTB = 3.d0
ZDZD = 3.d0
*
*
DO JJO = 1, obs_numheader(lobsSpaceData)
IDATA = obs_headElem_i(lobsSpaceData,OBS_RLN,JJO)
IDATEND = obs_headElem_i(lobsSpaceData,OBS_NLV,JJO) + IDATA - 1
IDBURP = obs_headElem_i(lobsSpaceData,OBS_ITY,JJO)
ZLAT = obs_headElem_r(lobsSpaceData,OBS_LAT,JJO)*MPC_DEGREES_PER_RADIAN_R8
ZLON = obs_headElem_r(lobsSpaceData,OBS_LON,JJO)*MPC_DEGREES_PER_RADIAN_R8
DO JDATA = IDATA, IDATEND
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA)
IASS = obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JDATA)*MPC_MBAR_PER_PA_R8
ZOER = obs_bodyElem_r(lobsSpaceData,OBS_OER,JDATA)
ZVAL = obs_bodyElem_r(lobsSpaceData,OBS_VAR,JDATA)
ZFCST= ZVAL - obs_bodyElem_r(lobsSpaceData,OBS_OMP,JDATA)
C
IF (ITYP .EQ. BUFR_NETS .OR. ITYP .EQ. BUFR_NEPS .OR.
1 ITYP .EQ. BUFR_NEPN .OR. ITYP .EQ. BUFR_NESS .OR.
2 ITYP .EQ. BUFR_NEUS .OR. ITYP .EQ. BUFR_NEVS .OR.
3 ITYP .EQ. BUFR_NEZD) THEN
LLOK = (obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1)
ELSE
LLOK = (IASS .EQ. 1) .AND. ((obs_bodyElem_i(lobsSpaceData,OBS_XTR,JDATA) .EQ.0)
1 .OR. ((obs_bodyElem_i(lobsSpaceData,OBS_XTR,JDATA) .EQ. 2) .AND.
2 (obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA) .EQ. BUFR_NEGZ)))
ENDIF
IF (LLOK) THEN
IF (ITYP .EQ. BUFR_NEUU .OR. ITYP .EQ. BUFR_NEVV .OR.
1 ITYP .EQ. BUFR_NEUS .OR. ITYP .EQ. BUFR_NEVS) THEN
ZAASYM = 1.0d0
IOTHER = -1
IF (ITYP .EQ. BUFR_NEUU .OR. ITYP .EQ. BUFR_NEUS) THEN
DO JJ=IDATA,JDATA
ISTYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JJ)
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JJ)*MPC_MBAR_PER_PA_R8
IF ((ISTYP .EQ. BUFR_NEVV .OR. ISTYP .EQ. BUFR_NEVS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = JJ
ENDIF
ENDDO
ELSE
DO JJ=IDATA,JDATA
ISTYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JJ)
ZSLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JJ)*MPC_MBAR_PER_PA_R8
IF ((ISTYP .EQ. BUFR_NEUU .OR. ISTYP .EQ. BUFR_NEUS)
1 .AND. ZLEV .EQ. ZSLEV) THEN
IOTHER = JJ
ENDIF
ENDDO
ENDIF
IF (IOTHER .NE. -1) THEN
ZOER = obs_bodyElem_r(lobsSpaceData,OBS_OER,JDATA)
ZOVAL = obs_bodyElem_r(lobsSpaceData,OBS_VAR,IOTHER)
ZOFCST = ZOVAL-obs_bodyElem_r(lobsSpaceData,OBS_OMP,IOTHER)
ZSPDO = SQRT(ZOVAL*ZOVAL + ZVAL*ZVAL)
ZSPDF = SQRT(ZOFCST*ZOFCST + ZFCST*ZFCST)
ZDIFF = ZSPDO - ZSPDF
ILEV = NINT(ZLEV)
*
*___________________tighten rejection criterion for satob winds
*
IF (IDBURP .EQ. 88 .OR. IDBURP .EQ. 188) THEN
IF (ZDIFF .LT. 0.0d0 .AND. ABS(ZLAT) .GT. 20.d0 .AND.
1 ILEV .LT. 550) THEN
ZAASYM = 0.7d0*MAX(ZSPDF,1.0d0)
ZPRIOR = ZAASYM*ZAUV
IF (ZPRIOR .GT. 0.99d0) ZAASYM = 0.99d0/ZAUV
* WRITE(*,620)ZAASYM,ILEV,ZLAT,ZLON,ZSPDO,
* 1 ZSPDF
620 FORMAT('ASYMMETRIC TEST. ZAASYM=',f7.1,', LEV=',
1 I4,', LAT=',F5.1,', LON=',F5.1,
2 ', OBSERVED SPEED=',F4.0,', FCST SPEED=',F4.0)
ELSE
*
*_______________________zaasym used to specify new criterion for satwinds
* than are not included in the asymmetric test
*
ZAASYM = 10.d0
ENDIF
ENDIF
ENDIF
*
*_______________________INITIAL VALUE OF GAMMA FOR QCVAR (WINDS)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(1.d0 -
1 (1.d0-(ZAUV*ZAASYM))*(1.d0-(ZAUV*ZAASYM)))*(2.d0*MPC_PI_r8)/
2 ((1.d0-(ZAUV*ZAASYM))*(1.d0-(ZAUV*ZAASYM))*
3 (2.d0*ZDUV)*(2.d0*ZDUV)))
IF ((IDBURP .GE. 32 .AND. IDBURP .LE. 38) .OR.
1 (IDBURP .GE. 135 .AND. IDBURP .LE. 142) .OR.
1 (IDBURP .EQ. 132) )
2 call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,
+ (1.d0 - (1.d0-ZAUVRA)*(1.d0-ZAUVRA))
3 *(2.d0*MPC_PI_R8)/((1.d0-ZAUVRA)*(1.d0-ZAUVRA)*
4 (2.d0*ZDUV)*(2.d0*ZDUV)))
ELSEIF (ITYP .EQ. BUFR_NEGZ) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (HEIGHTS)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZAGZ*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZAGZ)*(2.d0*ZDGZ)))
ELSEIF (ITYP .EQ. BUFR_NETT) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (TEMPERATURES)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZATT*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZATT)*(2.d0*ZDTT)))
IF ((IDBURP .GE. 32 .AND. IDBURP .LE. 38) .OR.
1 (IDBURP .GE. 135 .AND. IDBURP .LE. 142) .OR.
1 (IDBURP .EQ. 132) )
2 call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZATTRA*
3 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZATTRA)*(2.d0*ZDTT)))
ELSEIF (ITYP .EQ. BUFR_NETS) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (SCREEN-LEVEL TEMPERATURES)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZATT*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZATT)*(2.d0*ZDTT)))
*
* ASYMMETRIC TEST FOR SHIP TEMPERATURES
*
IF ((IDBURP .EQ. 13) .AND. (ZVAL .GT. ZFCST)) THEN
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZATTSYM*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZATTSYM)*(2.d0*ZDTT)))
ENDIF
ELSEIF (ITYP .EQ. BUFR_NEPN) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (MSL PRESSURE)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZAPN*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZAPN)*(2.d0*ZDPN)))
ELSEIF (ITYP .EQ. BUFR_NEPS) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (STATION PRESSURE)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZAPS*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZAPS)*(2.d0*ZDPS)))
ELSEIF ( ITYP .EQ. 12062 .OR. ITYP .EQ. 12063 .OR.
1 ITYP .EQ. 12163) THEN
*
* INITIAL VALUE OF GAMMA FOR BRIGHTNESS TEMPERATURES
* TOVS AMSU-A + AIRS + IASI + GEORAD !!!!!
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZABT*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZABT)*(2.d0*ZDBT)))
IF (IDBURP .EQ. 181 .OR.
1 IDBURP .EQ. 182 ) THEN
*
* INITIAL VALUE OF GAMMA FOR TOVS AMSU-B (181) AND MHS (182)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZABTB*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZABTB)*(2.d0*ZDBTB)))
ENDIF
ELSEIF (ITYP .EQ. BUFR_NEZD) THEN
*
* INITIAL VALUE OF GAMMA FOR QCVAR (GPS ZENITH DELAY)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZAZD*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZAZD)*(2.d0*ZDZD)))
ELSE
*
* INITIAL VALUE OF GAMMA FOR QCVAR (OTHERS)
*
call obs_bodySet_r(lobsSpaceData,OBS_POB,JDATA,(ZAHU*
1 SQRT(2.d0*MPC_PI_R8))/((1.d0-ZAHU)*(2.d0*ZDHU)))
ENDIF
ENDIF
END DO
C
END DO
RETURN
END