*IF DEF,SCMA S_STSUBS.2
C *****************************COPYRIGHT****************************** S_STSUBS.3
C (c) CROWN COPYRIGHT 1998, METEOROLOGICAL OFFICE, All Rights Reserved. S_STSUBS.4
C S_STSUBS.5
C Use, duplication or disclosure of this code is subject to the S_STSUBS.6
C restrictions as set forth in the contract. S_STSUBS.7
C S_STSUBS.8
C Meteorological Office S_STSUBS.9
C London Road S_STSUBS.10
C BRACKNELL S_STSUBS.11
C Berkshire UK S_STSUBS.12
C RG12 2SZ S_STSUBS.13
C S_STSUBS.14
C If no contract has been raised with this copy of the code, the use, S_STSUBS.15
C duplication or disclosure of it is strictly prohibited. Permission S_STSUBS.16
C to do so must first be obtained in writing from the Head of Numerical S_STSUBS.17
C Modelling at the above address. S_STSUBS.18
C ******************************COPYRIGHT****************************** S_STSUBS.19
C S_STSUBS.20
C===================================================================== S_STSUBS.21
C Subroutine ABNEW S_STSUBS.22
C Purpose:- To calculate amplitude and mean of sinusoidal S_STSUBS.23
C distribution for stats. Eqns. 10 and 11 S_STSUBS.24
C in SCM documentation. S_STSUBS.25
C Programmer:- J. LEAN - modified code from original SCM to S_STSUBS.26
C meet UM standards S_STSUBS.27
C Modification History: S_STSUBS.28
C Version Date S_STSUBS.29
C 4.5 07/98 SCM integrated as a standard UM configuration S_STSUBS.30
C Introduce multicolumn SCM S_STSUBS.31
C JC Thil. S_STSUBS.32
C S_STSUBS.33
C S_STSUBS.34
C===================================================================== S_STSUBS.35
C S_STSUBS.36
Subroutine ABNEW(x1, x2, xa, xb, points, n) 13S_STSUBS.37
Implicit none S_STSUBS.38
C--------------------------------------------------------------------- S_STSUBS.39
C Arguments S_STSUBS.40
C--------------------------------------------------------------------- S_STSUBS.41
Integer S_STSUBS.42
& i, k, points, n ! Loop counters S_STSUBS.43
Real S_STSUBS.44
& x1(points,n) ! IN SD or mean of forcing variable S_STSUBS.45
! for max. of annual cycle (July) S_STSUBS.46
& ,x2(points,n) ! IN SD or mean of forcing variable S_STSUBS.47
! for min. of annual cycle (Jan) S_STSUBS.48
& ,xa(points,n) ! OUT Amplitude of seasonal variation S_STSUBS.49
! of forcing variable S_STSUBS.50
& ,xb(points,n) ! OUT Mean of seasonal variation S_STSUBS.51
! of forcing variable S_STSUBS.52
C S_STSUBS.53
Do i = 1, points S_STSUBS.54
Do k = 1, n S_STSUBS.55
xa(i,k) = (x1(i,k)-x2(i,k))/2. S_STSUBS.56
xb(i,k) = (x1(i,k)+x2(i,k))/2. S_STSUBS.57
enddo S_STSUBS.58
enddo S_STSUBS.59
Return S_STSUBS.60
End ! Subroutine ABNEW S_STSUBS.61
C S_STSUBS.62
C===================================================================== S_STSUBS.63
C FUNCTION DAYNEW S_STSUBS.64
C PURPOSE:- To calculate SIN of argument (in eqn. 12 S_STSUBS.65
C in SCM doc.) required in calculation of S_STSUBS.66
C mean or SD of variable at day relative to winter S_STSUBS.67
C solstice S_STSUBS.68
C PROGRAMMER:- J. LEAN - modified code from original SCM to S_STSUBS.69
C meet UM standards S_STSUBS.70
C Modification History: S_STSUBS.71
C Version Date S_STSUBS.72
C 4.5 07/98 SCM integrated as a standard UM configuration S_STSUBS.73
C JC Thil. S_STSUBS.74
C===================================================================== S_STSUBS.75
C S_STSUBS.76
Function DAYNEW(at,bt,itd) 3S_STSUBS.77
C--------------------------------------------------------------------- S_STSUBS.78
C Arguments S_STSUBS.79
C--------------------------------------------------------------------- S_STSUBS.80
implicit none S_STSUBS.81
Integer itd ! IN Dayno. relative to winter S_STSUBS.82
! solstice S_STSUBS.83
Real S_STSUBS.84
& at,bt ! IN Constants for calculating annual S_STSUBS.85
! cycle S_STSUBS.86
C--------------------------------------------------------------------- S_STSUBS.87
C Local variables S_STSUBS.88
C--------------------------------------------------------------------- S_STSUBS.89
Real S_STSUBS.90
& arg ! Argument S_STSUBS.91
& ,daynew ! SIN of argument S_STSUBS.92
C S_STSUBS.93
arg = at * float(itd) + bt S_STSUBS.94
daynew = sin(arg) S_STSUBS.95
Return S_STSUBS.96
End ! Function DAYNEW S_STSUBS.97
C S_STSUBS.98
C===================================================================== S_STSUBS.99
C Subroutine XNEW S_STSUBS.100
C Purpose:- To calculate mean or SD of random variable S_STSUBS.101
C at daynumber relative to winter solstice S_STSUBS.102
C (eqn. 12 in SCM doc.) S_STSUBS.103
C Programmer:- J. LEAN - modified code from original SCM to S_STSUBS.104
C meet UM standards S_STSUBS.105
C Modification History: S_STSUBS.106
C Version Date S_STSUBS.107
C 4.5 07/98 SCM integrated as a standard UM configuration S_STSUBS.108
C Introduce multicolumn SCM S_STSUBS.109
C JC Thil. S_STSUBS.110
C S_STSUBS.111
C===================================================================== S_STSUBS.112
C S_STSUBS.113
Subroutine XNEW(x, xa, xb, points, nlevs, xt) 13S_STSUBS.114
C--------------------------------------------------------------------- S_STSUBS.115
C Arguments S_STSUBS.116
C--------------------------------------------------------------------- S_STSUBS.117
Implicit none S_STSUBS.118
Integer S_STSUBS.119
& points , nlevs ! IN # of columns, & model levels S_STSUBS.120
Real S_STSUBS.121
& x(points,nlevs) ! OUT Mean or SD of forcing variable S_STSUBS.122
! at day relative to winter S_STSUBS.123
! solstice S_STSUBS.124
& ,xa(points,nlevs) ! IN Amplitude of seasonal variation S_STSUBS.125
! of forcing variable. S_STSUBS.126
& ,xb(points,nlevs) ! IN Mean of seasonal variation S_STSUBS.127
! of forcing variable. S_STSUBS.128
& ,xt ! IN Sin of argument S_STSUBS.129
C--------------------------------------------------------------------- S_STSUBS.130
C Local variables S_STSUBS.131
C--------------------------------------------------------------------- S_STSUBS.132
Integer S_STSUBS.133
& i,k ! Loop counters S_STSUBS.134
C S_STSUBS.135
do k = 1, nlevs S_STSUBS.136
do i = 1, points S_STSUBS.137
x(i,k) = xa(i, k) * xt + xb(i,k) S_STSUBS.138
enddo S_STSUBS.139
enddo S_STSUBS.140
Return S_STSUBS.141
End ! Subroutine XNEW S_STSUBS.142
C S_STSUBS.143
C===================================================================== S_STSUBS.144
C SUBROUTINE PNEW S_STSUBS.145
C PURPOSE:- To calculate pressure and reciprocal pressure S_STSUBS.146
C coordinates AK and BK values and P* S_STSUBS.147
C PROGRAMMER:- J. LEAN - modified code from original SCM to S_STSUBS.148
C meet UM standards S_STSUBS.149
C S_STSUBS.150
C Modification History: S_STSUBS.151
C Version Date S_STSUBS.152
C 4.5 07/98 SCM integrated as a standard UM configuration S_STSUBS.153
C Introduce multicolumn SCM S_STSUBS.154
C JC Thil. S_STSUBS.155
C S_STSUBS.156
C===================================================================== S_STSUBS.157
C S_STSUBS.158
Subroutine PNEW(nlevs, p, rp, points, n, pstar, ak, bk) 2S_STSUBS.159
C--------------------------------------------------------------------- S_STSUBS.160
C Arguments S_STSUBS.161
C--------------------------------------------------------------------- S_STSUBS.162
implicit none S_STSUBS.163
Integer S_STSUBS.164
& nlevs ! IN no. of levs of the scm. S_STSUBS.165
& ,n ! IN no. of levels to be processed S_STSUBS.166
& ,points ! IN no. of model columns. S_STSUBS.167
Real S_STSUBS.168
& ak(nlevs) S_STSUBS.169
& ,bk(nlevs) ! IN AK and BK values at levels S_STSUBS.170
& ,p(points,n) ! OUT Pressure coordinates (Pa) S_STSUBS.171
& ,pstar(points) ! IN Surface pressure (Pa) S_STSUBS.172
& ,rp(points,n) ! OUT Reciprocal pressure S_STSUBS.173
! coordinates (HPa) S_STSUBS.174
C--------------------------------------------------------------------- S_STSUBS.175
C Local variables S_STSUBS.176
C--------------------------------------------------------------------- S_STSUBS.177
Integer S_STSUBS.178
& i,k ! Loop counters S_STSUBS.179
S_STSUBS.180
C S_STSUBS.181
Do k = 1, n S_STSUBS.182
Do i = 1, points S_STSUBS.183
p(i,k) = ak(k) + bk(k) * pstar(i) S_STSUBS.184
rp(i,k) = 100. / p(i,k) S_STSUBS.185
enddo S_STSUBS.186
enddo S_STSUBS.187
Return S_STSUBS.188
End ! Subroutine PNEW S_STSUBS.189
C S_STSUBS.190
C===================================================================== S_STSUBS.191
C SUBROUTINE ACINIT S_STSUBS.192
C PURPOSE:- To calculate mean and SD of a random variable S_STSUBS.193
C eqns 6 and 7 in SCM doc. S_STSUBS.194
C PROGRAMMER:- J. LEAN - modified code from original SCM to S_STSUBS.195
C meet UM standards S_STSUBS.196
C S_STSUBS.197
C Modification History: S_STSUBS.198
C Version Date S_STSUBS.199
C 4.5 07/98 SCM integrated as a standard UM configuration S_STSUBS.200
C Introduce multicolumn SCM S_STSUBS.201
C JC Thil. S_STSUBS.202
C S_STSUBS.203
C===================================================================== S_STSUBS.204
C S_STSUBS.205
Subroutine ACINIT(xbar, xsd, a, cbar, csd, cor, n, points) 4S_STSUBS.206
C--------------------------------------------------------------------- S_STSUBS.207
C Arguments S_STSUBS.208
C--------------------------------------------------------------------- S_STSUBS.209
Implicit none S_STSUBS.210
Integer S_STSUBS.211
& n, points ! IN no. of model columns & levels S_STSUBS.212
Real S_STSUBS.213
& a(points,n-1) ! OUT term a of eqn. 2.22 S_STSUBS.214
& ,cbar(points,n-1) ! OUT Mean of random variable C S_STSUBS.215
& ,cor(points) ! IN Vertical correlation coefficient S_STSUBS.216
& ,csd(points,n-1) ! OUT SD of random variable C S_STSUBS.217
& ,xbar(points,n) ! IN Mean of forcing variable S_STSUBS.218
& ,xsd(points,n) ! IN SD of forcing variable S_STSUBS.219
C--------------------------------------------------------------------- S_STSUBS.220
C Local variables S_STSUBS.221
C--------------------------------------------------------------------- S_STSUBS.222
Integer S_STSUBS.223
& i, k ! Loop counters S_STSUBS.224
C S_STSUBS.225
Do k = 1 ,n-1 S_STSUBS.226
Do i = 1, points S_STSUBS.227
a(i,k) = cor(i) * xsd(i,k+1) / xsd(i,k) S_STSUBS.228
cbar(i,k) = xbar(i,k+1) - a(i,k) * xbar(i,k) S_STSUBS.229
csd(i,k) = sqrt(1.-cor(i)*cor(i)) * xsd(i,k+1) S_STSUBS.230
enddo S_STSUBS.231
enddo S_STSUBS.232
Return S_STSUBS.233
End ! Subroutine ACINIT S_STSUBS.234
S_STSUBS.235
*ENDIF S_STSUBS.236