*IF DEF,C90_1A,OR,DEF,C90_2A,OR,DEF,C90_2B AAD2F404.297
C ******************************COPYRIGHT****************************** GTS2F400.1963
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.1964
C GTS2F400.1965
C Use, duplication or disclosure of this code is subject to the GTS2F400.1966
C restrictions as set forth in the contract. GTS2F400.1967
C GTS2F400.1968
C Meteorological Office GTS2F400.1969
C London Road GTS2F400.1970
C BRACKNELL GTS2F400.1971
C Berkshire UK GTS2F400.1972
C RG12 2SZ GTS2F400.1973
C GTS2F400.1974
C If no contract has been raised with this copy of the code, the use, GTS2F400.1975
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.1976
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.1977
C Modelling at the above address. GTS2F400.1978
C ******************************COPYRIGHT****************************** GTS2F400.1979
C GTS2F400.1980
C*LL SUBROUTINE DEWPNT------------------------------------------------- DEWPNT1A.3
CLL DEWPNT1A.4
CLL Purpose: Calculates the 1.5 metre dewpoint from 1.5 metre specific DEWPNT1A.5
CLL humidity, 1.5 metre temperature and 1.5 metre pressure. DEWPNT1A.6
CLL DEWPNT1A.7
CLL Suitable for single column usage. DEWPNT1A.8
CLL DEWPNT1A.9
CLL Model Modification history: DEWPNT1A.10
CLL version Date DEWPNT1A.11
CLL DEWPNT1A.12
CLL 3.3 28/04/94 Created by Steve Woltering DEWPNT1A.13
CLL 4.4 Sept 97 Avoid crash if negative Q input. Damian Wilson. ADM2F404.1
CLL DEWPNT1A.14
CLL Programming standard: Unified Model Documentation Paper No 3, DEWPNT1A.15
CLL Version 5, dated 08/12/92 DEWPNT1A.16
CLL Documentation: To be added to UM Doc Paper ? DEWPNT1A.17
CLL DEWPNT1A.18
CLLEND----------------------------------------------------------------- DEWPNT1A.19
C DEWPNT1A.20
C*L DEWPNT1A.21
C*LArguments:---------------------------------------------------------- DEWPNT1A.22
SUBROUTINE DEWPNT( 1,1DEWPNT1A.23
+ Q, P, T, ! IN DEWPNT1A.24
+ P_FIELD, ! IN DEWPNT1A.25
+ TD ! OUT DEWPNT1A.26
+) DEWPNT1A.27
IMPLICIT NONE DEWPNT1A.28
*CALL C_EPSLON 
DEWPNT1A.29
*CALL C_R_CP DEWPNT1A.30
*CALL C_LHEAT DEWPNT1A.31
*CALL C_0_DG_C DEWPNT1A.32
INTEGER P_FIELD ! IN Size of field arrays. DEWPNT1A.33
REAL P(P_FIELD), ! IN Pressure. DEWPNT1A.34
+ Q(P_FIELD), ! IN Specific humidity. DEWPNT1A.35
+ T(P_FIELD) ! IN Temperature. DEWPNT1A.36
REAL RV, ! LOCAL Gas constant for water vapour. DEWPNT1A.37
+ RL1, ! LOCAL Latent heat of evaporation. DEWPNT1A.38
+ RT, ! LOCAL. DEWPNT1A.39
+ P1(P_FIELD), ! LOCAL Pressure. DEWPNT1A.40
C j/Kg at 0 deg C. DEWPNT1A.41
+ RL(P_FIELD), ! LOCAL. DEWPNT1A.42
+ Q0(P_FIELD), ! LOCAL local SH. DEWPNT1A.43
+ ES0, ! LOCAL Saturated vapour pressure. DEWPNT1A.44
+ V_PRES(P_FIELD) ! LOCAL Vapour pressure. DEWPNT1A.45
INTEGER I ! LOCAL loop variable. DEWPNT1A.46
REAL TD(P_FIELD) ! OUT Dew point. DEWPNT1A.47
PARAMETER ( RV = R / EPSILON ) DEWPNT1A.48
PARAMETER ( RL1 = -2.73E3 ) DEWPNT1A.49
C*---------------------------------------------------------------------- DEWPNT1A.50
C*L EXTERNAL SUBROUTINES CALLED----------------------------------------- DEWPNT1A.51
EXTERNAL QSAT_WAT DEWPNT1A.52
C---------------------------------------------------------------------- DEWPNT1A.53
C Calculate P in HPa. DEWPNT1A.54
C DEWPNT1A.55
DO I=1,P_FIELD DEWPNT1A.56
P1(I) = P(I) / 100.0 DEWPNT1A.57
C---------------------------------------------------------------------- DEWPNT1A.58
C Calculate RL - The latent heat of evaporation. DEWPNT1A.59
RL(I) = LC + RL1 * ( T(I) - TM ) DEWPNT1A.60
C---------------------------------------------------------------------- DEWPNT1A.61
C Calculate Vapour pressure, and from that the dewpoint in Kelvins. DEWPNT1A.62
V_PRES(I) = Q(I) * P1(I) / ( EPSILON + Q(I)) DEWPNT1A.63
ENDDO DEWPNT1A.64
CALL QSAT_WAT(Q0,T,P,P_FIELD) DEWPNT1A.65
DO I=1,P_FIELD DEWPNT1A.66
IF (V_PRES(I) .GT. 0.0) THEN ADM2F404.2
ES0=(Q0(I) * P1(I)) / (EPSILON + Q0(I)) ADM2F404.3
RT = (1 / T(I)) - ( RV * ALOG(V_PRES(I)/ES0) )/RL(I) ADM2F404.4
TD(I)=1.0/RT ADM2F404.5
IF (TD(I) .GT. T(I)) TD(I) = T(I) ADM2F404.6
ELSE ADM2F404.7
TD(I)=0.0 ADM2F404.8
! print*,'WARNING. Neg or zero Q in dewpoint calc.' ADM2F404.9
ENDIF ADM2F404.10
ENDDO DEWPNT1A.71
RETURN DEWPNT1A.72
END DEWPNT1A.73
*ENDIF DEWPNT1A.74