!-------------------------------------- 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 oda_Hsf 1,1
use modmask
, only : lmasksf_in,lmasksf_out,ldiagsf
#if defined (DOC)
*
* Purpose: Compute simulated surface observations from profiled model
* increments.
* It returns Hdx in ROBDATA8(NCMOMA,*)
*
*Author : P. Koclas *CMC/AES September 1994
*Revision:
* P. Koclas *CMC/AES February 1995
* - Minor modifications
* - Allow for multiple data files.
* P. KoCLAS CMC/CMSV AUGUST 1998
* - ANALYSYS ON ETA COORDINATE
* C. Charette ARMA/AES NOV 1998
* - Extrapolation DZ below model orography.
* - Adapt code to follow Luc Fillion's notes on 3dvar-eta
* analysis. LLPRINT to print diagnostics
* B. Brasnett CMC/CMDA Nov 1999
* - Modify functional for variational quality control
* C. Charette ARMA/AES Jun 2000
* - Adapt code to process data with height as vertical
* coordinate.
* Special care for surface temperature(12004) and for
* sfc pressure(10004) and mean sea level pressure(10051)
* C. Charette ARMA/AES Oct 2000
* - Process elements 12203,11215,11216 at the reported height
* rather than at the model surface. These observations are
* no longer displaced to the model surface in SFCADJUSTZ.
* C. Charette ARMA/SMC FEV. 2002
* - Commented out the if(llprint...) statements within
* the do loops. They were preventing vectorization.
* S. Pellerin ARMA, January 2009
* - Rename the subroutine acording to ODA naming convention
* - Use of mask to process only assimilated data
* - Computation of Hdx instead of Jo=sum([Hdx-d]/sigma)
* - Withdraw of the QCVAR to be applied outside of the
* operator
*
*
#endif
IMPLICIT NONE
REAL*8 PJO
CHARACTER *2 CDFAM
*implicits
#include "comlun.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comphy.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comnumbr.cdk"
*
INTEGER IPB,IPT,IXTR
INTEGER IOBS,IPOS,IK,IBEGIN,ILAST,ILASTOB,IBEGINOB,IDATEND
INTEGER J,JDATA,JO,IDATA,ITYP,ISTYP,JJ
REAL*8 ZCON,ZINC,ZPHI,ZJON,ZGAMI,ZSLEV,ZQCARG
REAL*8 ZWB,ZWT, ZEXP,ZEXPGZ,ZGAMMA,ZLTV,ZTVG,ZPPOST
REAL*8 ZLEV,ZPT,ZPB,ZDELPS,ZDELTV,ZGAMAZ,ZHHH
C
C Temperature lapse rate for extrapolation of gz below model surface
C
zgamma = 0.0065 / GRAV
zexp = 1.0/(RGASD*zgamma)
zexpGZ = RGASD*zgamma
C
C Process all data within the domain of the model
C
DO JDATA=1,ndata
if(lmasksf_in(jdata)) then
IOBS = MOBDATA(NCMOBS,JDATA)
IPOS = MOBDATA(NCMPOS,JDATA)
ITYP = MOBDATA(NCMVNM,JDATA)
IXTR = MOBDATA(NCMXTR,JDATA)
IK = ROBDATA(NCMLYR,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
ZHHH = ZLEV * GRAV
IPT = NFLEV-1 + IPOS*NFLEV
IPB = IPT+1
IF (ITYP.EQ.NETS .OR. ITYP.EQ.NESS .OR.
& ITYP.EQ.NEUS .OR. ITYP.EQ.NEVS .or. ldiagsf(jdata)) THEN
ROBDATA8(NCMOMA,JDATA) =GOMOBS(IPB,IOBS)
ELSEIF (ITYP.EQ.NEPS .OR. ITYP.EQ.NEPN) THEN
ZLTV = OLTV(1,NFLEV,IOBS)*GOMT(NFLEV,IOBS)
& + OLTV(2,NFLEV,IOBS)*GOMQ(NFLEV,IOBS)
ZTVG = OLTV(1,NFLEV,IOBS)*GOMTG(NFLEV,IOBS)
ZGAMAZ= ZGAMMA*(ZHHH-GOMGZG(NFLEV,IOBS))
ZCON = ((ZTVG-ZGAMAZ)/ZTVG)
ZDELPS= (GOMPS(1,IOBS)*ZCON**ZEXP)
ZDELTV= ((GOMPSG(1,IOBS)*ZEXP*ZCON**(ZEXP-1))
& *(ZGAMAZ/(ZTVG*ZTVG)*ZLTV))
ROBDATA8(NCMOMA,JDATA)= ZDELPS+ZDELTV
ELSE
IPT = IK + IPOS*NFLEV
IPB = IPT+1
ZPT = GOMGZG(IK,IOBS)
ZPB = GOMGZG(IK+1,IOBS)
ZWB = (ZPT-ZHHH)/(ZPT-ZPB)
ZWT = 1. - ZWB
ROBDATA8(NCMOMA,JDATA) =
+ ZWB*GOMOBS(IPB,IOBS) + ZWT*GOMOBS(IPT,IOBS)+
+ (GOMOBSG(IPB,IOBS)-GOMOBSG(IPT,IOBS))
ENDIF
elseif(lmasksf_out(jdata)) then
IOBS = MOBDATA(NCMOBS,JDATA)
IPOS = MOBDATA(NCMPOS,JDATA)
ZLEV = ROBDATA8(NCMPPP,JDATA)
C
C CONTRIBUTION TO Jo
C
c TL model for height data below model's orography
c
ZLTV = OLTV(1,NFLEV,IOBS)*GOMT(NFLEV,IOBS)
& + OLTV(2,NFLEV,IOBS)*GOMQ(NFLEV,IOBS)
ZTVG = OLTV(1,NFLEV,IOBS)*GOMTG(NFLEV,IOBS)
ZCON=(ZLEV/GOMPSG(1,IOBS))**ZEXPGZ
robdata8(ncmoma,jdata)=(1.-zcon)/zgamma*ZLTV
& + RGASD*ZTVG*zcon*gomps(1,iobs)
& /gompsg(1,iobs)
endif
enddo
C--------------------------------------------------------------------
RETURN
END