SUBROUTINE huoma(CDFAM) #if defined (DOC) * ***s/r huoma - Store gomq (O-A) values for RAOBS. * * *Author : D. Anselmo *ARMA/MSC October 2004 *Revision: * Y.J. Rochon *AQRX/MSC Feb 2005 * - Switched order of comnumbr.cdk and cvcord.cdk * as JPNBRELEM of comnumbr required by cvcord. * * ** Purpose: - Interpolate GOMQ (O-A) values to RAOBS altitude and * store in CMA. Also store surface GOMQ values to CMA. * * *Arguments * CDFAM: FAMILY OF OBSERVATION * #endif IMPLICIT NONE CHARACTER *2 CDFAM *implicits c------------------------------------------------------------------------ #include "comlun.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comgem.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "commvog.cdk"
#include "comnumbr.cdk"
#include "cvcord.cdk"
#include "comfilt.cdk"
#include "cparbrp.cdk"
* INTEGER IOBS,IK,IBEGIN,ILAST,IPRES INTEGER J,JDATA REAL*8 ZVAR,ZOER,ZDADPS REAL*8 ZWB,ZWT REAL*8 ZLEV,ZPT,ZPB,ZPRESBPB,ZPRESBPT LOGICAL LLPRINT C cc LLPRINT = .TRUE. LLPRINT = .FALSE. IF (LLPRINT) print*,' ---huoma---------------' DO J = 1,NFILES IF ( (CFAMTYP(J) .EQ. CDFAM) .AND.( NBEGINTYP(J) .GT. 0)) THEN IBEGIN=NBEGINTYP(J) ILAST=NENDTYP(J) C C* 1. Computation of (HX - Z)/SIGMA C . ----------------------------- C 100 CONTINUE C C Process all data within the domain of the model C Exclude levels above RLIMLVHU as it is done with T-Td in s/r suprep C DO JDATA=IBEGIN,ILAST c upper-air observations: IF ( MOBDATA(NCMVNM,JDATA) .EQ. NEHU .AND. & MOBDATA(NCMVCO,JDATA) .EQ. 2 ) THEN IPRES= NINT(ROBDATA8(NCMPPP,JDATA)) ROBDATA8(NCMOMA,JDATA) = PPMIS IF ( IPRES .GE. NINT(RLIMLVHU*100) ) THEN IOBS = MOBDATA(NCMOBS,JDATA) ZVAR = ROBDATA8(NCMVAR,JDATA) ZOER = ROBDATA8(NCMOER,JDATA) ZLEV = ROBDATA8(NCMPPP,JDATA) IK = ROBDATA(NCMLYR,JDATA) ZPT = RPPOBS(IK,IOBS) ZPB = RPPOBS(IK+1,IOBS) ZWB = LOG(ZLEV/ZPT)/LOG(ZPB/ZPT) ZWT = 1. - ZWB C zpresbpt = ((vhybinc(ik) - rptopinc/rprefinc) & /(1.0-rptopinc/rprefinc))**rcoefinc zpresbpb = ((vhybinc(ik+1) - rptopinc/rprefinc) & /(1.0-rptopinc/rprefinc))**rcoefinc ZDADPS = ( (ZPRESBPT/ZPT)*LOG(ZLEV/ZPB) + -(ZPRESBPB/ZPB)*LOG(ZLEV/ZPT) ) + /LOG(ZPB/ZPT)**2 C ROBDATA8(NCMOMA,JDATA) = ( + ZWB*GOMQ(IK+1,IOBS) + ZWT*GOMQ(IK,IOBS) + + ( GOMQG(IK+1,IOBS)-GOMQG(IK,IOBS) )*ZDADPS & * GOMPS(1,IOBS)- ZVAR ) / ZOER IF ( LLPRINT ) THEN write(nulout,*)' -------------------------' write(nulout,*)' jdata = ',JDATA write(nulout,*)' iobs = ',IOBS write(nulout,*)' zvar = ',ZVAR write(nulout,*)' zoer = ',ZOER write(nulout,*)' zlev = ',ZLEV write(nulout,*)' ik = ',IK write(nulout,*)' gomq(ik,iobs) = ',GOMQ(IK,IOBS) write(nulout,*)' gomq(ik+1,iobs) = ',GOMQ(IK+1 & ,IOBS) write(nulout,*)' O-A = ',-ROBDATA8(NCMOMA & ,JDATA)*ZOER write(nulout,*)' -------------------------' ENDIF ENDIF c surface observations: ELSEIF ( MOBDATA(NCMVNM,JDATA) .EQ. NEHS .AND. & MOBDATA(NCMVCO,JDATA) .EQ. 1 ) THEN IOBS = MOBDATA(NCMOBS,JDATA) ZVAR = ROBDATA8(NCMVAR,JDATA) ZOER = ROBDATA8(NCMOER,JDATA) ROBDATA8(NCMOMA,JDATA) = (GOMQ(NFLEV,IOBS)-ZVAR)/ZOER IF ( LLPRINT ) THEN write(nulout,*)' -------------------------' write(nulout,*)' jdata = ',JDATA write(nulout,*)' iobs = ',IOBS write(nulout,*)' zvar = ',ZVAR write(nulout,*)' zoer = ',ZOER write(nulout,*)' gomq(nflev,iobs) = ',GOMQ(NFLEV & ,IOBS) write(nulout,*)' O-Asfc = ',-ROBDATA8(NCMOMA,JDATA) & *ZOER write(nulout,*)' -------------------------' ENDIF ENDIF END DO ENDIF END DO C-------------------------------------------------------------------- * RETURN END