!-------------------------------------- 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 ESTOHU(ZVAL,IMARK,KLIST,KNELE,KNVAL,KINT,KNELOUT) 3,11
IMPLICIT NONE
#include "comlun.cdk"
#include "comcst.cdk"
#include "cparbrp.cdk"
#include "comnumbr.cdk"
#include "comphy.cdk"
#include "dintern8.cdk"
#include "fintern8.cdk"
INTEGER KNELE,KNVAL,KINT,KNELOUT
INTEGER KLIST(*)
REAL*8 ZVAL(*)
INTEGER IMARK(*)
*
#if defined (DOC)
************************************************************************
*
* PURPOSE: TO COMPUTE SPECIFIC HUMIDITY FROM EXISTING RAOBS AND
* SURFACE DATA EXTRACTED FROM A BURP FILE
*
* AUTHOR: D. ANSELMO (MRB/ARMA) October 2004
* (modified copy of FDTOUV.ftn)
*
* REVISION:
*
* ARGUMENTS:
* INPUT:
* -ZVAL : DATA BLOCK
* -IMARK : MARKER DATA BLOCK
* -KLIST : LIST OF BUFR ELEMENTS
* -KNELE : NUMBER OF ELEMENTS IN DATA BLOCK
* -KNVAL : NUMBER OF LEVELS IN DATA BLOCK
* -KINT : THIRD DIMENSION OF INPUT DATA BLOCK
* -KNELOUT : THIRD DIMENSION OF OUTPUT DATA BLOCK
*
* OUTPUT:
* -MODIFIED ZVAL AND KLIST
*
* INTERNAL:
* -ZPROFES : PROFILE OF ES VALUES EXTRACTED FROM ZVAL
* -ZPROFTT : PROFILE OF TT VALUES EXTRACTED FROM ZVAL
* -ZPROFPS : PROFILE OF PS VALUES EXTRACTED FROM ZVAL
* -ZPROFHU : PROFILE OF HU VALUES EXTRACTED FROM ZVAL
*
*
************************************************************************
#endif
*
REAL*8 ZPROFES(JPMXNLV),ZPROFTT(JPMXNLV)
REAL*8 ZPROFPP(JPMXNLV),ZPROFHU(JPMXNLV)
REAL*8 ZVAL2(JPLNG)
INTEGER IMARK2(JPLNG)
REAL*8 ZES,ZTT,ZPP,ZTD,ZESTD,ZHU
INTEGER JJ,JN,INDEX1,INDEX2,J1,J2,J3
INTEGER IND1,IND2,IND3,IND4
INTEGER IES,ITT,IPP,IHU
logical llmis,lladd2,LLEXPAND,LLPRINT
*
cc LLPRINT = .TRUE.
LLPRINT = .FALSE.
*
************************************************************************
* BURP FILE ELEMENT NAMES
* GET ES,TT,PP
************************************************************************
*
IES=NEES
ITT=NETT
IPP=NEPP
IHU=NEHU
lladd2=.true.
KNELOUT=KNELE+1
CALL GETELE(IES,1,KLIST,ZVAL,ZPROFES,KNELE,KNVAL,KINT,IND1)
CALL GETELE(ITT,1,KLIST,ZVAL,ZPROFTT,KNELE,KNVAL,KINT,IND2)
CALL GETELE(IPP,1,KLIST,ZVAL,ZPROFPP,KNELE,KNVAL,KINT,IND3)
CALL GETELE(IHU,1,KLIST,ZVAL,ZPROFHU,KNELE,KNVAL,KINT,IND4)
C
C FOR SURFACE (SYNOP ...etc..) ES,TT at 2 M iS REPORTED
C
IF ( IND1 .EQ. -1 .AND. IND2 .EQ. -1 .AND. IND3 .EQ. -1 ) THEN
IES=NESS
ITT=NETS
IPP=NEPS
CALL GETELE(IES,1,KLIST,ZVAL,ZPROFES,KNELE,KNVAL,KINT,IND1)
CALL GETELE(ITT,1,KLIST,ZVAL,ZPROFTT,KNELE,KNVAL,KINT,IND2)
CALL GETELE(IPP,1,KLIST,ZVAL,ZPROFPP,KNELE,KNVAL,KINT,IND3)
IF ( IND1 .NE. -1 .AND. IND2 .NE. -1 .AND. IND3 .NE. -1 ) THEN
IHU=NEHS
CALL GETELE(IHU,1,KLIST,ZVAL,ZPROFHU,KNELE,KNVAL,KINT,IND4)
ENDIF
ENDIF
C
LLEXPAND=.FALSE.
IF ( (IND1 .NE. -1) .AND. (IND2 .NE. -1) .AND. (IND3 .NE. -1) .AND.
+ (IND4 .EQ. -1) )THEN
LLEXPAND=.TRUE.
DO 2 JN=1,KINT
CALL GETELE(IES,JN,KLIST,ZVAL,ZPROFES,KNELE,KNVAL,KINT,IND1)
CALL GETELE(ITT,JN,KLIST,ZVAL,ZPROFTT,KNELE,KNVAL,KINT,IND2)
CALL GETELE(IPP,JN,KLIST,ZVAL,ZPROFPP,KNELE,KNVAL,KINT,IND3)
C
C FOR SURFACE (SYNOP ...etc..) ES,TT at 2 M iS REPORTED
C
*
************************************************************************
* -IF ES,TT,PP WERE FOUND CONVERT TO HU
* -CHECK IF MISSING DATA
* -SET FLAGS TO 0
************************************************************************
*
* for residual or background check configuration
C
IF ( lladd2 ) THEN
KLIST(KNELE+1)=IHU
ELSE
KLIST(IND1)=IHU
ENDIF
*
*
DO 3 JJ=1,KNVAL
IF (LLPRINT) write(nulout,*)' ----ESTOHU: press= ',ZPROFPP(JJ)
IF ( lladd2 ) THEN
INDEX1=KNELE+1 + (JJ-1)*(KNELOUT)+(JN-1)*(KNVAL)*(KNELOUT)
ELSE
INDEX1=IND1 + (JJ-1)*(KNELOUT)+(JN-1)*(KNVAL)*(KNELOUT)
ENDIF
IMARK2(INDEX1)=0
zVAL2(INDEX1)=PPMIS
*
IF ( ZPROFES(JJ).GT.30. .OR. ZPROFES(JJ).LT.0. ) THEN
ZPROFES(JJ) = PPMIS
ENDIF
llmis=(ZPROFES(JJ) .eq. PPMIS) .OR. (ZPROFTT(JJ) .eq. PPMIS)
+ .OR. (ZPROFPP(JJ) .eq. PPMIS)
if ( .NOT. LLMIS) THEN
*
ZES=ZPROFES(JJ)
ZTT=ZPROFTT(JJ)
ZPP=ZPROFPP(JJ)
*=============================================
c COMPUTE LQ given ES,TT,PP
c a) compute td
c b) compute sat. vap. press using Tetens (water)
c c) compute ln q
*=============================================
ZTD = ZTT - ZES
ZESTD = foewa8(ZTD)
ZHU = log( foqfe8(ZESTD,ZPP) )
IF (LLPRINT) THEN
write(nulout,*)' ZES = ',ZES
write(nulout,*)' ZTT = ',ZTT
write(nulout,*)' ZTD = ',ZTD
write(nulout,*)' ZESTD = ',ZESTD
write(nulout,*)' ZHU = ',ZHU
ENDIF
IF ( lladd2 ) THEN
ZVAL2(INDEX1)= ZHU
IMARK2(INDEX1)=0
ELSE
ZVAL (INDEX1)= ZHU
ENDIF
else
IF ( lladd2 ) THEN
ZVAL2(INDEX1)=ppmis
ELSE
ZVAL (INDEX1)=ppmis
ENDIF
endif
C
*=============================================
3 CONTINUE
*
2 CONTINUE
ENDIF
C
C TRANSFER BACK TO INPUT ARRAYS
C
IF ( lladd2 .AND. LLEXPAND ) THEN
DO J1 =1,KNELE
DO J2 =1,KNVAL
DO J3 =1,KINT
INDEX1=J1 + (J2-1)*KNELE +(J3-1)*KNELE*KNVAL
INDEX2=J1 + (J2-1)*KNELOUT +(J3-1)*KNELOUT*KNVAL
ZVAL2 (INDEX2)= ZVAL(INDEX1)
IMARK2(INDEX2)=IMARK(INDEX1)
END DO
END DO
END DO
C
DO JJ =1,KNELOUT*KNVAL*KINT
ZVAL (JJ)= ZVAL2(JJ)
IMARK(JJ)=IMARK2(JJ)
END DO
ELSE
CC NO WORK DONE BY ROUTINE
KNELOUT=KNELE
ENDIF
C
RETURN
END