*IF DEF,RECON TH_TO_T1.2
C ******************************COPYRIGHT****************************** GTS2F400.10315
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.10316
C GTS2F400.10317
C Use, duplication or disclosure of this code is subject to the GTS2F400.10318
C restrictions as set forth in the contract. GTS2F400.10319
C GTS2F400.10320
C Meteorological Office GTS2F400.10321
C London Road GTS2F400.10322
C BRACKNELL GTS2F400.10323
C Berkshire UK GTS2F400.10324
C RG12 2SZ GTS2F400.10325
C GTS2F400.10326
C If no contract has been raised with this copy of the code, the use, GTS2F400.10327
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.10328
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.10329
C Modelling at the above address. GTS2F400.10330
C ******************************COPYRIGHT****************************** GTS2F400.10331
C GTS2F400.10332
CLL TH_TO_T1.3
CLL SUBROUTINE TH_TO_THL:---------------------------------------- TH_TO_T1.4
CLL TH_TO_T1.5
CLL Purpose: Convert TH & Q to THL & QT. Done only if input TH_TO_T1.6
CLL file contains TH (& therefore Q) but not THL. TH_TO_T1.7
CLL Data on input file is overwritten. TH_TO_T1.8
CLL TH_TO_T1.9
CLL Written by A. Dickinson 27/02/92 TH_TO_T1.10
CLL TH_TO_T1.11
CLL Model Modification history from model version 3.0: TH_TO_T1.12
CLL version date TH_TO_T1.13
CLL 3.3 08/12/93 Extra argument for READ/WRITFLDS. D. Robinson DR081293.123
! 4.1 1 8/06/96 Changes to cope with changes in STASH addressing GDG0F401.1433
! Author D.M. Goddard. GDG0F401.1434
! 4.2 Oct. 96 T3E migration: *DEF CRAY removed GSS9F402.86
! S.J.Swarbrick GSS9F402.87
! 4.4 15/10/97 Correct pointer for reading potential temperature UDG8F404.4
! Author: D.M. Goddard. UDG8F404.5
CLL TH_TO_T1.14
CLL Modification History: TH_TO_T1.15
CLL TH_TO_T1.16
CLL Logical component number: S1 TH_TO_T1.17
CLL TH_TO_T1.18
CLL Documentation: Formula presented in UM Doc Paper 10 TH_TO_T1.19
CLL--------------------------------------------------------------- TH_TO_T1.20
C*L Arguments:---------------------------------------------------- TH_TO_T1.21
SUBROUTINE TH_TO_THL( 1,14GDG0F401.1435
*CALL ARGPPX 
GDG0F401.1436
& FIXHD,LOOKUP,LEVDEPC, ! GDG0F401.1437
& PP_ITEMC,PP_POS,N_TYPES,NFTIN, ! Intent (In) GDG0F401.1438
& P_FIELD,P_LEVELS,Q_LEVELS, ! GDG0F401.1439
& BL_LEVELS) GDG0F401.1440
TH_TO_T1.25
IMPLICIT NONE TH_TO_T1.26
TH_TO_T1.27
INTEGER TH_TO_T1.28
& N_TYPES !IN No of different section/item codes TH_TO_T1.29
&,BL_LEVELS !IN No of b.l. levels TH_TO_T1.30
&,P_LEVELS !IN No of model levels TH_TO_T1.31
&,Q_LEVELS !IN No of moist levels TH_TO_T1.32
&,P_FIELD !IN No of points on p-grid TH_TO_T1.33
&,NFTIN !IN Unit number TH_TO_T1.34
&,LOOKUP(*) !IN Lookup header TH_TO_T1.35
&,FIXHD(*) !IN Fixed length header TH_TO_T1.36
&,PP_ITEMC(N_TYPES) !IN Item codes on file TH_TO_T1.37
&,PP_POS(N_TYPES) !IN Position on file TH_TO_T1.38
TH_TO_T1.39
REAL TH_TO_T1.40
& LEVDEPC(P_LEVELS*2) !IN Level dependent consts TH_TO_T1.41
TH_TO_T1.42
C Local arrays:-------------------------------------------------------- TH_TO_T1.43
REAL TH_TO_T1.44
& PSTAR(P_FIELD) ! PSTAR - surface pressure TH_TO_T1.45
&,TH(P_FIELD) ! TH/THL - potential temperature TH_TO_T1.46
&,Q(P_FIELD) ! Q/QT - specific humidity TH_TO_T1.47
&,QCL(P_FIELD) ! QCL - Cloud water TH_TO_T1.48
&,QCF(P_FIELD) ! QCF - Cloud ice TH_TO_T1.49
&,T(P_FIELD) ! T - Temperature TH_TO_T1.50
&,TEMP(P_FIELD) ! Temporary space TH_TO_T1.51
TH_TO_T1.52
C*L External subroutines called:--------------------------------------- TH_TO_T1.53
EXTERNAL LOCATE,ABORT_IO,READFLDS,INITQLCF TH_TO_T1.54
C*--------------------------------------------------------------------- TH_TO_T1.59
C Local variables:----------------------------------------------------- TH_TO_T1.60
TH_TO_T1.61
INTEGER TH_TO_T1.62
& POSTH,POS,POSQ,POSQCL,POSQCF ! Position indicators TH_TO_T1.63
&,POSTHL ! Position indicators TH_TO_T1.64
&,ICODE ! Return code TH_TO_T1.65
&,K,I ! Loop index TH_TO_T1.66
TH_TO_T1.67
REAL TH_TO_T1.68
& PR ! Pressure TH_TO_T1.69
&,P_EXNER_FULL ! Exner pressure TH_TO_T1.70
TH_TO_T1.71
CHARACTER*80 TH_TO_T1.72
& CMESSAGE ! Message TH_TO_T1.73
C --------------------------------------------------------------------- TH_TO_T1.74
! Comdecks:--------------------------------------------------------- GDG0F401.1441
*CALL CSUBMODL GDG0F401.1442
*CALL CPPXREF GDG0F401.1443
*CALL PPXLOOK GDG0F401.1444
*CALL C_R_CP TH_TO_T1.75
*CALL C_LHEAT TH_TO_T1.76
C---------------------------------------------------------------------- TH_TO_T1.77
TH_TO_T1.78
CALL LOCATE(4,PP_ITEMC,N_TYPES,POSTH) TH_TO_T1.79
CALL LOCATE(5,PP_ITEMC,N_TYPES,POSTHL) TH_TO_T1.80
IF(POSTH.NE.0.AND.POSTHL.EQ.0)THEN TH_TO_T1.81
C Locate PSTAR TH_TO_T1.82
CALL LOCATE(1,PP_ITEMC,N_TYPES,POS) TH_TO_T1.83
C Locate Q, QCF and QCL TH_TO_T1.84
CALL LOCATE(10,PP_ITEMC,N_TYPES,POSQ) TH_TO_T1.85
CALL LOCATE(11,PP_ITEMC,N_TYPES,POSQCL) TH_TO_T1.86
CALL LOCATE(12,PP_ITEMC,N_TYPES,POSQCF) TH_TO_T1.87
TH_TO_T1.88
C Read in PSTAR TH_TO_T1.89
CALL READFLDS(NFTIN,1,PP_POS(POS),LOOKUP,64, GDG0F401.1445
& PSTAR,P_FIELD,FIXHD, GDG0F401.1446
*CALL ARGPPX GDG0F401.1447
& ICODE,CMESSAGE) GDG0F401.1448
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) TH_TO_T1.92
TH_TO_T1.93
TH_TO_T1.94
DO K=1,Q_LEVELS TH_TO_T1.95
TH_TO_T1.96
C Read in TH TH_TO_T1.97
CALL READFLDS(NFTIN,1,PP_POS(POSTH)+K-1,LOOKUP,64, UDG8F404.6
& TH,P_FIELD,FIXHD, GDG0F401.1450
*CALL ARGPPX GDG0F401.1451
& ICODE,CMESSAGE) GDG0F401.1452
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) TH_TO_T1.100
TH_TO_T1.101
C Read in Q TH_TO_T1.102
CALL READFLDS(NFTIN,1,PP_POS(POSQ)+K-1,LOOKUP,64, GDG0F401.1453
& Q,P_FIELD,FIXHD, GDG0F401.1454
*CALL ARGPPX GDG0F401.1455
& ICODE,CMESSAGE) GDG0F401.1456
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) TH_TO_T1.105
TH_TO_T1.106
C Either read in QCL and QCF from input file or estimate from T, Q & P TH_TO_T1.107
TH_TO_T1.108
IF(POSQCL.NE.0)THEN TH_TO_T1.109
C Read in QCL TH_TO_T1.110
CALL READFLDS(NFTIN,1,PP_POS(POSQCL)+K-1,LOOKUP,64, GDG0F401.1457
& QCL,P_FIELD,FIXHD, GDG0F401.1458
*CALL ARGPPX GDG0F401.1459
& ICODE,CMESSAGE) GDG0F401.1460
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) TH_TO_T1.113
TH_TO_T1.114
C Read in QCF TH_TO_T1.115
CALL READFLDS(NFTIN,1,PP_POS(POSQCF)+K-1,LOOKUP,64, GDG0F401.1461
& QCF,P_FIELD,FIXHD, GDG0F401.1462
*CALL ARGPPX GDG0F401.1463
& ICODE,CMESSAGE) GDG0F401.1464
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE,NFTIN) TH_TO_T1.118
TH_TO_T1.119
ELSE TH_TO_T1.120
TH_TO_T1.121
C Convert TH to T TH_TO_T1.122
DO I=1,P_FIELD TH_TO_T1.123
PR=LEVDEPC(K)+PSTAR(I)*LEVDEPC(K+P_LEVELS) TH_TO_T1.124
T(I)=TH(I)*(PR/PREF)**KAPPA GSS9F402.88
ENDDO TH_TO_T1.130
TH_TO_T1.131
C Estimate QCL and QCF from T, Q & P TH_TO_T1.132
CALL INITQLCF TH_TO_T1.133
* (LEVDEPC,LEVDEPC(1+P_LEVELS),PSTAR,Q,T,P_LEVELS,P_FIELD TH_TO_T1.134
* ,TEMP,QCF,QCL,BL_LEVELS,K) TH_TO_T1.135
TH_TO_T1.136
ENDIF TH_TO_T1.137
TH_TO_T1.138
C Convert TH to THL and Q to QT TH_TO_T1.139
DO I=1,P_FIELD TH_TO_T1.140
P_EXNER_FULL=((LEVDEPC(K) TH_TO_T1.145
* +LEVDEPC(K+P_LEVELS)*PSTAR(I))/PREF)**KAPPA TH_TO_T1.146
TH(I)=TH(I)-(LC*QCL(I)+(LC+LF)*QCF(I))/(CP*P_EXNER_FULL) TH_TO_T1.148
Q(I)=Q(I)+QCL(I)+QCF(I) TH_TO_T1.149
ENDDO TH_TO_T1.150
TH_TO_T1.151
TH_TO_T1.152
C Write out THL TH_TO_T1.153
CALL WRITFLDS(NFTIN,1,PP_POS(POSTH)+K-1, GDG0F401.1465
& LOOKUP,64,TH,P_FIELD,FIXHD, GDG0F401.1466
*CALL ARGPPX GDG0F401.1467
& ICODE,CMESSAGE) GDG0F401.1468
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE TH_TO_T1.156
* ,ICODE,NFTIN) TH_TO_T1.157
TH_TO_T1.158
C Write out QT TH_TO_T1.159
CALL WRITFLDS(NFTIN,1,PP_POS(POSQ)+K-1, GDG0F401.1469
& LOOKUP,64,Q,P_FIELD,FIXHD, GDG0F401.1470
*CALL ARGPPX GDG0F401.1471
& ICODE,CMESSAGE) GDG0F401.1472
IF(ICODE.NE.0)CALL ABORT_IO('CONTROL',CMESSAGE,ICODE TH_TO_T1.162
* ,NFTIN) TH_TO_T1.163
TH_TO_T1.164
TH_TO_T1.165
ENDDO TH_TO_T1.166
TH_TO_T1.167
C Change item codes from TH -> THL and Q -> QT TH_TO_T1.168
PP_ITEMC(POSTH)=5 TH_TO_T1.169
PP_ITEMC(POSQ)=11 TH_TO_T1.170
TH_TO_T1.171
ENDIF TH_TO_T1.172
TH_TO_T1.173
RETURN TH_TO_T1.174
END TH_TO_T1.175
*ENDIF TH_TO_T1.176