!-------------------------------------- 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 VOBSLYRS(lcolumnghr,lobsSpaceData) 2,67
#if defined (DOC)
*
***s/r VOBSLYRS
*
*Author : P. Koclas *CMC/AES Sept 7 1994
*Revision:
* P. Koclas *CMC/AES February 1995
* -Allow ROBDATA(OBS_XTR,JDATA)=0 when
* level of data= Bottom layer of model (pressure case)
*
* P. Koclas *CMC/AES July 1995
* -fix bugs
* -( mobdata <---> robdata confusion)
* -( IF ( NINT(ZLEV) .EQ. NINT(ZPB) ) THEN )
* P. Koclas *CMC/AES April 1996
* - new definition of "OBS_LYR" to include reference levels of satem data
* C. CHARETTE *CMC/AES OCT 1998
* - Adapted for version on eta levels
* C. CHARETTE *CMC/AES OCT 2000
* - Adapted to process data with pressure vertical coordinate
* D. Anselmo *ARMA/MSC OCT 2004
* - Adapted to process atmospheric and surface ln specific humidity
** Purpose:
* Find which model levels to use for the vertical interpolation
* of model fields to CMA data.
*
*Arguments
*
* input:
* none
#endif
use EarthConstants_mod
use MathPhysConstants_mod
use obsSpaceData_mod
use columnData_mod
use bufr
IMPLICIT NONE
type(struct_columnData) :: lcolumnghr
type(struct_obs) :: lobsSpaceData
INTEGER :: JK,JDATA,NLEV
REAL(8) :: ZLEV,ZPT,ZPB
INTEGER :: IOBS,IK,ITYP
LOGICAL :: LLOK
CHARACTER(len=2) :: varType
integer :: index_header, index_body
C
C-----------------------------------------------------------------------
C --------
C ETA
C --------
C
C 1. Find where extrapolation is needed
C ----------------------------------
C
C 1.1 PPP Vertical coordinate
C
Write(*,*) "Entering subroutine VOBSLYRS"
DO JDATA= 1,obs_numbody(lobsSpaceData)
LLOK = ( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1 .OR.
& obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. -1) .AND.
& obs_bodyElem_i(lobsSpaceData,OBS_VCO,JDATA) .EQ. 2 )
IF ( LLOK ) THEN
IF(obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA) .NE. BUFR_NEDZ ) THEN
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JDATA)
ELSE
call abort3d('vobslyr: ZLEV cannot be set, BUFR_NEDZ not supported!')
ENDIF
IOBS = obs_bodyElem_i(lobsSpaceData,OBS_HIND,JDATA)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA)
varType = vnl_vartypeFromVarnum(ITYP)
ZPT= col_getPressure(LCOLUMNGHR,1,IOBS,varType)
ZPB= col_getPressure(LCOLUMNGHR,COL_GETNUMLEV(LCOLUMNGHR,varType),IOBS,varType)
IF ( ZLEV .LT. ZPT ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,1)
!
!- !!! WARNING !!! This obs is above the model lid.
! We must turn off its assimilation flag because the
! current obs operators cannot deal with this situation (JFC)
if(varType.ne.'SF') then
write(*,*) "vobslyrs: Rejecting OBS above model lid, pressure = ", ZLEV," < ",ZPT
call obs_bodySet_i(lobsSpaceData,OBS_ASS,JDATA, 0)
endif
ELSE IF ( ZLEV .GT. ZPB ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,2)
ELSE
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,0)
ENDIF
ENDIF
END DO
C
C 1.2 ZZZ Vertical coordinate
C
DO JDATA= 1,obs_numbody(lobsSpaceData)
LLOK = (obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1 .AND.
& obs_bodyElem_i(lobsSpaceData,OBS_VCO,JDATA) .EQ. 1 )
IF ( LLOK ) THEN
IF(obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA) .NE. BUFR_NEDZ ) THEN
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JDATA)
ELSE
call abort3d('vobslyr: ZLEV cannot be set, BUFR_NEDZ not supported!')
ENDIF
IOBS = obs_bodyElem_i(lobsSpaceData,OBS_HIND,JDATA)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA)
varType = vnl_vartypeFromVarnum(ITYP)
if(varType.eq.'SF') then
nlev=col_getNumLev(lcolumnghr,'TH')
ZPT= col_getHeight(lcolumnghr,1,IOBS,'TH')/RG
ZPB= col_getHeight(lcolumnghr,NLEV,IOBS,'TH')/RG
else
nlev=col_getNumLev(lcolumnghr,varType)
ZPT= col_getHeight(lcolumnghr,1,IOBS,varType)/RG
ZPB= col_getHeight(lcolumnghr,NLEV,IOBS,varType)/RG
endif
IF ( ZLEV .GT. ZPT ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,1)
write(*,*) "vobslyrs: Rejecting OBS above model lid, height =", ZLEV," > ",ZPT
call obs_bodySet_i(lobsSpaceData,OBS_ASS,JDATA, 0)
ELSE IF ( ZLEV .LT. ZPB ) THEN
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,2)
ELSE
call obs_bodySet_i(lobsSpaceData,OBS_XTR,JDATA,0)
ENDIF
ENDIF
END DO
C
C
C 2. FInd interpolation layer
C ------------------------
C (Model levels are assumed to be in increasing order in Mbs)
C ...The SIGN and MAX intrinsincs are used for vectorization
C purposes......
C
C 2.1 PPP Vertical coordinate
C
DO JDATA=1,obs_numbody(lobsSpaceData)
call obs_bodySet_i(lobsSpaceData,OBS_LYR,JDATA,0)
END DO
C
DO JDATA= 1,obs_numbody(lobsSpaceData)
LLOK = ( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1 .OR.
& obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. -1) .AND.
& obs_bodyElem_i(lobsSpaceData,OBS_VCO,JDATA) .EQ. 2 )
IF ( LLOK ) THEN
IOBS = obs_bodyElem_i(lobsSpaceData,OBS_HIND,JDATA)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JDATA)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA)
IK = 1
varType = vnl_vartypeFromVarnum(ITYP)
nlev=COL_GETNUMLEV(LCOLUMNGHR,varType)
DO JK = 2,NLEV - 1
ZPT = col_getPressure(LCOLUMNGHR,JK,IOBS,varType)
IF( ZLEV .GT. ZPT ) IK = JK
END DO
ZPT = col_getPressure(LCOLUMNGHR,IK,IOBS,varType)
ZPB = col_getPressure(LCOLUMNGHR,IK+1,IOBS,varType)
call obs_bodySet_i(lobsSpaceData,OBS_LYR,JDATA, IK)
ENDIF
END DO
C
C 2.2 ZZZ Vertical coordinate and surface observations
C
DO JDATA= 1,obs_numbody(lobsSpaceData)
LLOK = ( (obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. 1 .OR.
& obs_bodyElem_i(lobsSpaceData,OBS_ASS,JDATA) .EQ. -1) .AND.
& obs_bodyElem_i(lobsSpaceData,OBS_VCO,JDATA) .EQ. 1 )
IF ( LLOK ) THEN
IOBS = obs_bodyElem_i(lobsSpaceData,OBS_HIND,JDATA)
ZLEV = obs_bodyElem_r(lobsSpaceData,OBS_PPP,JDATA)
ITYP = obs_bodyElem_i(lobsSpaceData,OBS_VNM,JDATA)
IK = 1
varType = vnl_vartypeFromVarnum(ITYP)
nlev=COL_GETNUMLEV(LCOLUMNGHR,varType)
DO JK = 2,NLEV - 1
ZPT = col_getHeight(lcolumnghr,JK,IOBS,varType)/RG
IF( ZLEV .LT. ZPT ) IK = JK
END DO
IF ( ITYP.EQ.BUFR_NEPS .or. ITYP.EQ.BUFR_NEPN .or.
& ITYP.EQ.BUFR_NEZD ) THEN
! for surface observations associated with surface analysis variables
IK = 0
ELSEIF ( ITYP.EQ.BUFR_NETS .or. ityp.eq.BUFR_NESS .OR.
& ITYP.EQ.BUFR_NEUS .or. ityp.eq.BUFR_NEVS .OR.
& ITYP.EQ.BUFR_NEHS) THEN
! for surface observations associated with NON-surface analysis variables
IK = nlev - 1
ENDIF
call obs_bodySet_i(lobsSpaceData,OBS_LYR,JDATA, IK)
ENDIF
END DO
C
RETURN
END