!-------------------------------------- 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(CDMVO) 3,1
#if defined (DOC)
*
***s/r VOBSLYRS
*
*Author : P. Koclas *CMC/AES Sept 7 1994
*Revision:
* P. Koclas *CMC/AES February 1995
* -Allow ROBDATA(NCMXTR,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 "NCMLYR" 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:
* CDMVO (character*2) : HR PROCESS HI RESOLUTION COMMVOHR
* BG PROCESS LO RESOLUTION COMMVOG
* none
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "commvohr.cdk"
#include "comcst.cdk"
*
character*2 cdmvo
INTEGER J,JK,JDATA
REAL*8 ZLEV,ZPREF,ZPT,ZPB,ZXI
INTEGER IOBS,IDATYP,IBEGIN,ILAST,IK,ITYP
LOGICAL LLOK, LLPRINT
CHARACTER *2 CLFAM
C
C --------
C
LLPRINT = .FALSE.
C
C CHECK VALUE OF CDMVO
C
IF(CDMVO .NE. 'HR' .AND. CDMVO .NE. 'BG') THEN
WRITE(NULOUT,*)'VOBSLYRS: CDMVO IS NOT VALID CDMVO= ',CDMVO
CALL ABORT3D(NULOUT,'ERR. IN VOBSLYRS')
ENDIF
C
100 CONTINUE
C-----------------------------------------------------------------------
C
C
C --------
C ETA
C --------
C
C 1. Find where extrapolation is needed
C ----------------------------------
C
C 1.1 PPP Vertical coordinate
C
DO JDATA= 1,NDATA
LLOK = ( (MOBDATA(NCMASS,JDATA) .EQ. 1 .OR.
& MOBDATA(NCMVNM,JDATA) .EQ. NEHU) .AND.
& MOBDATA(NCMVCO,JDATA) .EQ. 2 )
IF ( LLOK ) THEN
IF(MOBDATA(NCMVNM,JDATA) .NE. NEDZ ) THEN
ZLEV = ROBDATA8(NCMPPP,JDATA)
ELSE
ZLEV = ROBDATA8(NCMPRL,JDATA)
ENDIF
IOBS = MOBDATA(NCMOBS,JDATA)
ITYP = MOBDATA(NCMVNM,JDATA)
IF(CDMVO .EQ. 'HR') THEN
ZPT= RPPOBSHR(1,IOBS)
ZPB= RPPOBSHR(NLEVTRL,IOBS)
ELSEIF(CDMVO .EQ. 'BG') THEN
ZPT= RPPOBS(1,IOBS)
cjmb ZPB= RPPOBS(NFLEV,IOBS)
cjmb Surface pressure artificially modified to account
cjmb for difference in rejections caused by 32 bits
cjmb conversion (MRBCVT) of observed pressure.
ZPB= RPPOBS(NFLEV,IOBS)+ 0.01D0
ENDIF
IF ( ZLEV .LT. ZPT ) THEN
MOBDATA(NCMXTR,JDATA)=1
ELSE IF ( ZLEV .GT. ZPB ) THEN
MOBDATA(NCMXTR,JDATA)=2
ELSE
MOBDATA(NCMXTR,JDATA)=0
ENDIF
****************************************************************
if (LLPRINT .AND. cstnid(iobs) .eq. '72562') then
write(nulout,*)
& 'vobslyrs PPP:jdata,stn,ielm,zlev,ZPT,ZPB'
& ,',MOB(XTR,),MOB(ASS,),CDMVO ',jdata,cstnid(iobs)
& ,ityp,zlev,ZPT,ZPB,MOBDATA(NCMXTR,JDATA)
& ,MOBDATA(NCMASS,JDATA),CDMVO
endif
*****************************************************************
ENDIF
END DO
C
C 1.2 ZZZ Vertical coordinate
C
DO JDATA= 1,NDATA
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1 .AND.
& MOBDATA(NCMVCO,JDATA) .EQ. 1 )
IF ( LLOK ) THEN
IF(MOBDATA(NCMVNM,JDATA) .NE. NEDZ ) THEN
ZLEV = ROBDATA8(NCMPPP,JDATA)
ELSE
ZLEV = ROBDATA8(NCMPRL,JDATA)
ENDIF
IOBS = MOBDATA(NCMOBS,JDATA)
ITYP = MOBDATA(NCMVNM,JDATA)
IF(CDMVO .EQ. 'HR') THEN
ZPT= GOMGZHR(1,IOBS)/RG
ZPB= GOMGZHR(NLEVTRL,IOBS)/RG
ELSEIF(CDMVO .EQ. 'BG') THEN
ZPT= GOMGZG(1,IOBS)/RG
ZPB= GOMGZG(NFLEV,IOBS)/RG
ENDIF
IF ( ZLEV .GT. ZPT ) THEN
MOBDATA(NCMXTR,JDATA)=1
ELSE IF ( ZLEV .LT. ZPB ) THEN
MOBDATA(NCMXTR,JDATA)=2
ELSE
MOBDATA(NCMXTR,JDATA)=0
ENDIF
****************************************************************
if (LLPRINT .AND. cstnid(iobs) .eq. '72562') then
write(nulout,*)
& 'vobslyrs ZZZ:jdata,stn,ielm,zlev,ZPT,ZPB'
& ,',MOB(XTR,),MOB(ASS,),CDMVO ',jdata,cstnid(iobs)
& ,ityp,zlev,ZPT,ZPB,MOBDATA(NCMXTR,JDATA)
& ,MOBDATA(NCMASS,JDATA),CDMVO
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,NDATA
ROBDATA(NCMLYR,JDATA)=0
END DO
C
DO JDATA= 1,NDATA
LLOK = ( (MOBDATA(NCMASS,JDATA) .EQ. 1 .OR.
& MOBDATA(NCMVNM,JDATA) .EQ. NEHU) .AND.
& MOBDATA(NCMVCO,JDATA) .EQ. 2 )
IF ( LLOK ) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
ITYP = MOBDATA(NCMVNM,JDATA)
IK = 1
IF(CDMVO .EQ. 'HR') THEN
DO JK = 2,NLEVTRL - 1
ZPT = RPPOBSHR(JK,IOBS)
IF( ZLEV .GT. ZPT ) IK = JK
END DO
ZPT = RPPOBSHR(IK,IOBS)
zpb=RPPOBSHR(IK+1,IOBS)
ELSEIF(CDMVO .EQ. 'BG') THEN
DO JK = 2,NFLEV - 1
ZPT = RPPOBS(JK,IOBS)
IF( ZLEV .GT. ZPT ) IK = JK
END DO
ZPT = RPPOBS(IK,IOBS)
zpb=RPPOBS(IK+1,IOBS)
ENDIF
ROBDATA(NCMLYR,JDATA)= IK
****************************************************************
if (LLPRINT .AND. cstnid(iobs) .eq. '72562') then
write(nulout,*)
& 'vobslyrs PPP:jdata,iobs,stn,ielm,ik,zlev'
& ,',pppobs(ik+1,),pppobs(ik,),rdata(lyr,),CDMVO '
& ,jdata,iobs,cstnid(iobs),ityp,ik,zlev,ZPB,ZPT
& ,ROBDATA(NCMLYR,JDATA),CDMVO
endif
*****************************************************************
ENDIF
END DO
C
C 2.2 ZZZ Vertical coordinate and surface observations
C
DO JDATA= 1,NDATA
LLOK = ( (MOBDATA(NCMASS,JDATA) .EQ. 1 .OR.
& MOBDATA(NCMVNM,JDATA) .EQ. NEHS) .AND.
& MOBDATA(NCMVCO,JDATA) .EQ. 1 )
IF ( LLOK ) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
ITYP = MOBDATA(NCMVNM,JDATA)
IK = 1
IF(CDMVO .EQ. 'HR') THEN
DO JK = 2,NLEVTRL - 1
ZPT = GOMGZHR(JK,IOBS)/RG
IF( ZLEV .LT. ZPT ) IK = JK
END DO
IF((ITYP.EQ.NEPS .or. ityp .eq. NEPN) ) THEN
IK=0
ELSEIF(ITYP.EQ.NETS .or. ityp .eq. NESS .OR.
& ITYP.EQ.NEUS .or. ityp .eq. NEVS .OR.
& ITYP.EQ.NEHS ) THEN
IK=NLEVTRL-1
ENDIF
ELSEIF(CDMVO .EQ. 'BG') THEN
DO JK = 2,NFLEV - 1
ZPT = GOMGZG(JK,IOBS)/RG
IF( ZLEV .LT. ZPT ) IK = JK
END DO
IF((ITYP.EQ.NEPS .or. ityp .eq. NEPN) ) THEN
IK=0
ELSEIF(ITYP.EQ.NETS .or. ityp .eq. NESS .OR.
& ITYP.EQ.NEUS .or. ityp .eq. NEVS .OR.
& ITYP.EQ.NEHS ) THEN
IK=NFLEV-1
ENDIF
ENDIF
ROBDATA(NCMLYR,JDATA)= IK
****************************************************************
if (LLPRINT .AND. cstnid(iobs) .eq. '72562') then
ZPB = GOMGZHR(IK+1,IOBS)/RG
write(nulout,*) 'vobslyrs ZZZ:jdata,iobs,stn,ielm,ik,zlev'
& ,',GZ(ik,),GZ(ik+1,),rdata(lyr,),CDMVO '
& ,jdata,iobs,cstnid(iobs),ityp,ik,zlev,ZPT,ZPB
& ,ROBDATA(NCMLYR,JDATA),CDMVO
endif
*****************************************************************
ENDIF
END DO
C
C 2.3 Reference ppp level of thickness data (SATEMS)
C -----
C
DO J = 1,NFILES
IF ((CFAMTYP(J) .EQ. 'ST').AND.(NBEGINTYP(J) .GT. 0))THEN
IBEGIN=NBEGINTYP(J)
ILAST=NENDTYP(J)
DO JDATA= IBEGIN,ILAST
LLOK = (MOBDATA(NCMASS,JDATA) .EQ. 1 .AND.
& MOBDATA(NCMVCO,JDATA) .EQ. 2 )
IF ( LLOK ) THEN
IOBS = MOBDATA(NCMOBS,JDATA)
ZLEV = ROBDATA8(NCMPRL,JDATA)
IK = 1
IF(CDMVO .EQ. 'HR') THEN
DO JK = 2,NLEVTRL - 1
ZPT = RPPOBSHR(JK,IOBS)
IF( ZLEV .GT. ZPT ) IK = JK
END DO
ELSEIF(CDMVO .EQ. 'BG') THEN
DO JK = 2,NFLEV - 1
ZPT = RPPOBS(JK,IOBS)
IF( ZLEV .GT. ZPT ) IK = JK
END DO
ENDIF
ROBDATA(NCMLYR,JDATA)= ROBDATA(NCMLYR,JDATA)
& + 1000 * IK
ENDIF
****************************************************************
c write(nulout,*) 'vobslyrs PRL:JDATA,iobs,IK,zlev,ZPT,ZPB '
c & ,JDATA,iobs,IK,ZLEV,RPPOBS(IK,IOBS),RPPOBS(IK+1,IOBS)
*****************************************************************
END DO
ENDIF
END DO
300 CONTINUE
C
RETURN
END