*IF DEF,RECON THLQTADJ.2
C *****************************COPYRIGHT****************************** THLQTADJ.3
C (c) CROWN COPYRIGHT 1997, METEOROLOGICAL OFFICE, All Rights Reserved. THLQTADJ.4
C THLQTADJ.5
C Use, duplication or disclosure of this code is subject to the THLQTADJ.6
C restrictions as set forth in the contract. THLQTADJ.7
C THLQTADJ.8
C Meteorological Office THLQTADJ.9
C London Road THLQTADJ.10
C BRACKNELL THLQTADJ.11
C Berkshire UK THLQTADJ.12
C RG12 2SZ THLQTADJ.13
C THLQTADJ.14
C If no contract has been raised with this copy of the code, the use, THLQTADJ.15
C duplication or disclosure of it is strictly prohibited. Permission THLQTADJ.16
C to do so must first be obtained in writing from the Head of Numerical THLQTADJ.17
C Modelling at the above address. THLQTADJ.18
C ******************************COPYRIGHT****************************** THLQTADJ.19
SUBROUTINE THL_QT_ADJ(N_TYPES,P_FIELD,P_LEVELS,Q_LEVELS, 1,10THLQTADJ.20
! NFTIN,L_MP_PRECIP,LOOKUP,FIXHD, THLQTADJ.21
! LEN1_LEVDEPC,LEN2_LEVDEPC,LEVDEPC, THLQTADJ.22
*CALL ARGPPX 
THLQTADJ.23
! PP_ITEMC,PP_POS) THLQTADJ.24
THLQTADJ.25
! Subroutine arguments THLQTADJ.26
! Scalar arguments with intent(in): THLQTADJ.27
INTEGER N_TYPES !No of different THLQTADJ.28
!section/item codes THLQTADJ.29
INTEGER P_FIELD !No of points on p-grid THLQTADJ.30
INTEGER P_LEVELS !No of model levels THLQTADJ.31
INTEGER Q_LEVELS !No of moist levels THLQTADJ.32
INTEGER NFTIN !Unit number THLQTADJ.33
INTEGER LEN1_LEVDEPC !1st dim of level dep consts THLQTADJ.34
INTEGER LEN2_LEVDEPC !1st dim of level dep consts THLQTADJ.35
LOGICAL L_MP_PRECIP !T= mixed phase precip (output) THLQTADJ.36
THLQTADJ.37
! Array arguments with intent(in): THLQTADJ.38
INTEGER LOOKUP(*) !Lookup header THLQTADJ.39
INTEGER FIXHD(*) !Fixed length header THLQTADJ.40
INTEGER PP_ITEMC(N_TYPES) !IN Item codes on file THLQTADJ.41
INTEGER PP_POS(N_TYPES) !IN Position on file THLQTADJ.42
REAL LEVDEPC(LEN1_LEVDEPC,LEN2_LEVDEPC) THLQTADJ.43
THLQTADJ.44
C Local arrays:-------------------------------------------------------- THLQTADJ.45
REAL PSTAR(P_FIELD) ! PSTAR - surface pressure THLQTADJ.46
REAL QCF(P_FIELD) ! QCF - Cloud ice THLQTADJ.47
REAL QT(P_FIELD) ! QT - Humidity plus cloud water THLQTADJ.48
REAL THL(P_FIELD) ! THL - Thetal THLQTADJ.49
C*L External subroutines called:--------------------------------------- THLQTADJ.50
EXTERNAL LOCATE,ABORT_IO,READFLDS THLQTADJ.51
C Local variables:----------------------------------------------------- THLQTADJ.52
INTEGER I,K ! Loop indices THLQTADJ.53
INTEGER POS,POSTHL ! Position indicators THLQTADJ.54
INTEGER POSQT,POSQCF ! Position indicators THLQTADJ.55
INTEGER P_EXNER_FULL ! Exner pressure THLQTADJ.56
INTEGER ICODE ! Return code THLQTADJ.57
THLQTADJ.58
CHARACTER*80 CMESSAGE ! Error message THLQTADJ.59
! --------------------------------------------------------------------- THLQTADJ.60
! Comdecks:------------------------------------------------------------ THLQTADJ.61
*CALL CSUBMODL THLQTADJ.62
*CALL CPPXREF THLQTADJ.63
*CALL PPXLOOK THLQTADJ.64
*CALL C_R_CP THLQTADJ.65
*CALL C_LHEAT THLQTADJ.66
!---------------------------------------------------------------------- THLQTADJ.67
THLQTADJ.68
CALL LOCATE(1,PP_ITEMC,N_TYPES,POS) THLQTADJ.69
CALL LOCATE(5,PP_ITEMC,N_TYPES,POSTHL) THLQTADJ.70
CALL LOCATE(11,PP_ITEMC,N_TYPES,POSQT) THLQTADJ.71
CALL LOCATE(12,PP_ITEMC,N_TYPES,POSQCF) THLQTADJ.72
THLQTADJ.73
IF(POSQCF.NE.0.AND..NOT.L_MP_PRECIP)THEN THLQTADJ.74
! Read in PSTAR THLQTADJ.75
CALL READFLDS(NFTIN,1,PP_POS(POS),LOOKUP,64, THLQTADJ.76
& PSTAR,P_FIELD,FIXHD, THLQTADJ.77
*CALL ARGPPX THLQTADJ.78
& ICODE,CMESSAGE) THLQTADJ.79
THLQTADJ.80
DO K=1,Q_LEVELS THLQTADJ.81
! Read in THL THLQTADJ.82
CALL READFLDS(NFTIN,1,PP_POS(POSTHL)+K-1,LOOKUP,64, THLQTADJ.83
& THL,P_FIELD,FIXHD, THLQTADJ.84
*CALL ARGPPX THLQTADJ.85
& ICODE,CMESSAGE) THLQTADJ.86
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) THLQTADJ.87
! Read in QT THLQTADJ.88
CALL READFLDS(NFTIN,1,PP_POS(POSQT)+K-1,LOOKUP,64, THLQTADJ.89
& QT,P_FIELD,FIXHD, THLQTADJ.90
*CALL ARGPPX THLQTADJ.91
& ICODE,CMESSAGE) THLQTADJ.92
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) THLQTADJ.93
! Read in QCF THLQTADJ.94
CALL READFLDS(NFTIN,1,PP_POS(POSQCF)+K-1,LOOKUP,64, THLQTADJ.95
& QCF,P_FIELD,FIXHD, THLQTADJ.96
*CALL ARGPPX THLQTADJ.97
& ICODE,CMESSAGE) THLQTADJ.98
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) THLQTADJ.99
THLQTADJ.100
! Add Cloud ice to QT and subtract latent heat correction to THL THLQTADJ.101
! to compensate THLQTADJ.102
DO I=1,P_FIELD THLQTADJ.103
P_EXNER_FULL = LEVDEPC(K,1)+LEVDEPC(K,2)*PSTAR(I) THLQTADJ.104
QT(I)=QT(I)+QCF(I) THLQTADJ.105
THL(I)=THL(I)-(LC+LF)*QCF(I)/(CP*P_EXNER_FULL) THLQTADJ.106
END DO THLQTADJ.107
THLQTADJ.108
! Write out THL THLQTADJ.109
CALL WRITFLDS(NFTIN,1,PP_POS(POSTHL)+K-1,LOOKUP,64, THLQTADJ.110
& THL,P_FIELD,FIXHD, THLQTADJ.111
*CALL ARGPPX THLQTADJ.112
& ICODE,CMESSAGE) THLQTADJ.113
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) THLQTADJ.114
! Write out QT THLQTADJ.115
CALL WRITFLDS(NFTIN,1,PP_POS(POSQT)+K-1,LOOKUP,64, THLQTADJ.116
& QT,P_FIELD,FIXHD, THLQTADJ.117
*CALL ARGPPX THLQTADJ.118
& ICODE,CMESSAGE) THLQTADJ.119
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) THLQTADJ.120
THLQTADJ.121
END DO THLQTADJ.122
ENDIF THLQTADJ.123
RETURN THLQTADJ.124
END THLQTADJ.125
*ENDIF THLQTADJ.126