*IF DEF,A02_1A,OR,DEF,A02_1C AWA1F304.5
C ******************************COPYRIGHT****************************** GTS2F400.5599
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.5600
C GTS2F400.5601
C Use, duplication or disclosure of this code is subject to the GTS2F400.5602
C restrictions as set forth in the contract. GTS2F400.5603
C GTS2F400.5604
C Meteorological Office GTS2F400.5605
C London Road GTS2F400.5606
C BRACKNELL GTS2F400.5607
C Berkshire UK GTS2F400.5608
C RG12 2SZ GTS2F400.5609
C GTS2F400.5610
C If no contract has been raised with this copy of the code, the use, GTS2F400.5611
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.5612
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.5613
C Modelling at the above address. GTS2F400.5614
C ******************************COPYRIGHT****************************** GTS2F400.5615
C GTS2F400.5616
CLL Subroutine LWPLAN ---------------------------------------------- LWPLAN1A.3
CLL LWPLAN1A.4
CLL This version of routine LWPLAN used in LWPLAN1A.5
CLL version 1A (gaseous effects treated as Slingo & Wilderspin, 1986) LWPLAN1A.6
CLL of the UM LW code. LWPLAN1A.7
CLL It calculates Planck ("black-body") fluxes in each longwave band as LWPLAN1A.8
CLL a cubic function of atmospheric (layer centre and boundary) and LWPLAN1A.9
CLL surface temperatures and returns their differences across LWPLAN1A.10
CLL half-layers (and optionally the surface black-body flux) for use by WI200893.34
CLL by LWMAST constructing longwave fluxes. WI200893.35
CLL LWPLAN1A.13
CLL Author: William Ingram LWPLAN1A.14
CLL LWPLAN1A.15
CLL Model Modification history from model version 3.0: LWPLAN1A.16
CLL version Date LWPLAN1A.17
CLL LWPLAN1A.18
CLL Programming standard : LWPLAN1A.19
CLL The code is standard FORTRAN 77 except for having ! comments. LWPLAN1A.20
CLL It conforms with standard A of version 3 (07/9/90) of UMDP 4, and LWPLAN1A.21
CLL contains no 8X-deprecated features. LWPLAN1A.22
CLL LWPLAN1A.23
CLL Logical components covered : P232, D23 LWPLAN1A.24
CLL It is part of component P232 (longwave radiation) LWPLAN1A.25
CLL It also performs some of the functions of D23 LWPLAN1A.26
CLL LWPLAN1A.27
CLL Project task : P23 (radiation) WI200893.36
CLL LWPLAN1A.29
CLL External documentation: UMDP 23. LWPLAN1A.30
CLL LWPLAN1A.31
CLLEND ----------------------------------------------------------------- LWPLAN1A.32
C*L LWPLAN1A.33
SUBROUTINE LWPLAN (TAC, PEXNER, PSTAR, AKH, BKH, TSTAR, AICE, 2LWPLAN1A.34
& SFUP, SFUPON, LWPLAN1A.35
& L2, NLEVS, L1, SEAFX, BHDB, THDB) LWPLAN1A.36
C* LWPLAN1A.37
*CALL LWNBANDS 
LWPLAN1A.38
C*L LWPLAN1A.39
INTEGER!, INTENT (IN) :: LWPLAN1A.40
& L1, ! First dimension of input arrays LWPLAN1A.41
& L2, ! Number of points to be treated LWPLAN1A.42
& NLEVS ! Number of levels LWPLAN1A.43
REAL!, INTENT(IN) :: LWPLAN1A.44
& TAC(L1,NLEVS), ! Atmospheric temperatures at layer LWPLAN1A.45
& PEXNER(L1,NLEVS+1), ! centres and Exner function at LWPLAN1A.46
& ! layer boundaries (to get T there) LWPLAN1A.47
& PSTAR(L1), ! Surface pressure LWPLAN1A.48
& AKH(NLEVS+1), ! AK at layer boundaries LWPLAN1A.49
& BKH(NLEVS+1), ! BK at layer boundaries LWPLAN1A.50
& TSTAR(L1), ! Surface temperature LWPLAN1A.51
& AICE(L1) ! Sea-ice fraction LWPLAN1A.52
LOGICAL!, INTENT(IN) :: LWPLAN1A.53
& SFUPON LWPLAN1A.54
REAL!, INTENT(OUT) :: LWPLAN1A.55
& BHDB(L2,NLEVS,NBANDS), LWPLAN1A.56
& THDB(L2,NLEVS,NBANDS), LWPLAN1A.57
C ! BHDB holds the difference of the Planck functions across the LWPLAN1A.58
C ! bottom half of each layer and THDB across the top half. LWPLAN1A.59
& SEAFX(L1) ! Difference between the open-sea LWPLAN1A.60
C ! and sea-ice upward longwave fluxes at the surface. LWPLAN1A.61
& , SFUP(L1) ! Upward surface flux LWPLAN1A.62
C* LWPLAN1A.63
CL ! LWPLAN has no EXTERNAL calls and no dynamically allocated arrays LWPLAN1A.64
C LWPLAN1A.65
*CALL C_R_CP LWPLAN1A.66
*CALL C_0_DG_C LWPLAN1A.67
*CALL LWPFCO LWPLAN1A.68
C LWPLAN1A.69
INTEGER BAND, LEVEL, J ! Loopers over band, level & point LWPLAN1A.70
REAL TAB, ! Layer boundary temperature LWPLAN1A.71
& WTL, WTU, ! and weights for its calculation LWPLAN1A.72
& BBC, ! Black-body flux at a model layer LWPLAN1A.73
& BBB, ! centre or boundary LWPLAN1A.74
& BBTFS ! or at TFS LWPLAN1A.75
LWPLAN1A.76
REAL LWPLAN1A.77
& PU ! Pressure at upper bdry of layer+1 LWPLAN1A.78
&, PL ! Pressure at upper bdry of layer LWPLAN1A.79
&, PLM1 ! Pressure at lower bdry of layer LWPLAN1A.80
*CALL P_EXNERC LWPLAN1A.81
LWPLAN1A.82
C LWPLAN1A.83
CL ! Section 1 LWPLAN1A.84
CL ! ~~~~~~~~~ LWPLAN1A.85
CL ! First find Planck function for surface temperature: LWPLAN1A.86
C LWPLAN1A.87
DO 1 BAND=1, NBANDS LWPLAN1A.88
BBTFS = ( ( PFCO(1,BAND) * TFS + PFCO(2,BAND) ) LWPLAN1A.89
& * TFS + PFCO(3,BAND) ) * TFS + PFCO(4,BAND) LWPLAN1A.90
Cfpp$ Select(CONCUR) LWPLAN1A.91
DO 11 J=1, L2 LWPLAN1A.92
IF ( AICE(J) .GT. 0. ) THEN LWPLAN1A.93
TAB = ( TSTAR(J) + (AICE(J)-1.) * TFS ) / AICE(J) LWPLAN1A.94
ELSE LWPLAN1A.95
TAB = TSTAR(J) LWPLAN1A.96
ENDIF LWPLAN1A.97
BBB = ( ( PFCO(1,BAND) * TAB + PFCO(2,BAND) ) LWPLAN1A.98
& * TAB + PFCO(3,BAND) ) * TAB + PFCO(4,BAND) LWPLAN1A.99
SEAFX(J) = SEAFX(J) + BBTFS - BBB LWPLAN1A.100
IF ( AICE(J) .GT. 0. ) LWPLAN1A.101
& BBB = AICE(J) * BBB + (1.-AICE(J)) * BBTFS LWPLAN1A.102
BHDB(J,1,BAND) = BBB LWPLAN1A.103
IF ( SFUPON ) SFUP(J) = SFUP(J) + BBB LWPLAN1A.104
11 CONTINUE LWPLAN1A.105
1 CONTINUE LWPLAN1A.106
C LWPLAN1A.107
CL ! Section 2 LWPLAN1A.108
CL ! ~~~~~~~~~ LWPLAN1A.109
CL ! Loop over the model layers finding the dB across each half LWPLAN1A.110
CL ! of each one : LWPLAN1A.111
C LWPLAN1A.112
DO 2 LEVEL=1, NLEVS-1 LWPLAN1A.113
C ! LWPLAN1A.114
C ! First must find TAB for the top of the layer (same for each LWPLAN1A.115
C ! band) and store it in spare space in THDB: LWPLAN1A.116
Cfpp$ Select(CONCUR) LWPLAN1A.117
DO 20 J=1, L2 LWPLAN1A.118
PU = PSTAR(J)*BKH(LEVEL+2) + AKH(LEVEL+2) LWPLAN1A.119
PL = PSTAR(J)*BKH(LEVEL+1) + AKH(LEVEL+1) LWPLAN1A.120
PLM1 = PSTAR(J)*BKH(LEVEL) + AKH(LEVEL) LWPLAN1A.121
WTL = TAC(J,LEVEL+1)*( PEXNER(J,LEVEL+1) / LWPLAN1A.122
& P_EXNER_C(PEXNER(J,LEVEL+2),PEXNER(J,LEVEL+1),PU,PL,KAPPA) LWPLAN1A.123
& - 1.0 ) LWPLAN1A.124
WTU = TAC(J,LEVEL) * ( PEXNER(J,LEVEL) / LWPLAN1A.125
& P_EXNER_C(PEXNER(J,LEVEL+1),PEXNER(J,LEVEL),PL,PLM1,KAPPA) LWPLAN1A.126
& - 1.0 ) LWPLAN1A.127
C LWPLAN1A.128
TAB = LWPLAN1A.129
& ( WTL * TAC(J,LEVEL) + WTU * TAC(J,LEVEL+1) ) / ( WTL + WTU ) LWPLAN1A.130
THDB(J,NLEVS,1) = TAB LWPLAN1A.131
20 CONTINUE LWPLAN1A.132
C ! LWPLAN1A.133
C ! This loop finds the black-body fluxes at the middle & top of LWPLAN1A.134
C ! the layer and sets BHDB & THDB for the layer, using the LWPLAN1A.135
C ! black-body flux for the bottom of the layer which is already LWPLAN1A.136
C ! in BHDB and leaving the value at the top in the next level up LWPLAN1A.137
C ! of BHDB : LWPLAN1A.138
DO 21 BAND=1, NBANDS LWPLAN1A.139
Cfpp$ Select(CONCUR) LWPLAN1A.140
DO 22 J=1, L2 LWPLAN1A.141
BBC = ( ( PFCO(1,BAND) * TAC(J,LEVEL) + PFCO(2,BAND) ) LWPLAN1A.142
& * TAC(J,LEVEL) + PFCO(3,BAND) ) * TAC(J,LEVEL) + PFCO(4,BAND) LWPLAN1A.143
BHDB(J,LEVEL,BAND) = BBC - BHDB(J,LEVEL,BAND) LWPLAN1A.144
TAB = THDB(J,NLEVS,1) LWPLAN1A.145
BBB = ( ( PFCO(1,BAND) * TAB + PFCO(2,BAND) ) LWPLAN1A.146
& * TAB + PFCO(3,BAND) ) * TAB + PFCO(4,BAND) LWPLAN1A.147
THDB(J,LEVEL,BAND) = BBB - BBC LWPLAN1A.148
BHDB(J,LEVEL+1,BAND) = BBB LWPLAN1A.149
22 CONTINUE LWPLAN1A.150
21 CONTINUE LWPLAN1A.151
2 CONTINUE LWPLAN1A.152
C LWPLAN1A.153
CL ! Section 3 LWPLAN1A.154
CL ! ~~~~~~~~~ LWPLAN1A.155
CL ! Finally, the top layer is treated slightly differently because LWPLAN1A.156
CL ! the black-body flux at the top is zero: LWPLAN1A.157
C LWPLAN1A.158
DO 3 BAND=1, NBANDS LWPLAN1A.159
Cfpp$ Select(CONCUR) LWPLAN1A.160
DO 30 J=1, L2 LWPLAN1A.161
BBC = ( ( PFCO(1,BAND) * TAC(J,NLEVS) + PFCO(2,BAND) ) LWPLAN1A.162
& * TAC(J,NLEVS) + PFCO(3,BAND) ) * TAC(J,NLEVS) + PFCO(4,BAND) LWPLAN1A.163
BHDB(J,NLEVS,BAND) = BBC - BHDB(J,NLEVS,BAND) LWPLAN1A.164
THDB(J,NLEVS,BAND) = - BBC LWPLAN1A.165
30 CONTINUE LWPLAN1A.166
3 CONTINUE LWPLAN1A.167
C LWPLAN1A.168
RETURN LWPLAN1A.169
END LWPLAN1A.170
*ENDIF LWPLAN1A.171