*IF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A,OR,DEF,A01_2B SWDKDI1A.2
C ******************************COPYRIGHT****************************** SWDKDI1A.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. SWDKDI1A.4
C SWDKDI1A.5
C Use, duplication or disclosure of this code is subject to the SWDKDI1A.6
C restrictions as set forth in the contract. SWDKDI1A.7
C SWDKDI1A.8
C Meteorological Office SWDKDI1A.9
C London Road SWDKDI1A.10
C BRACKNELL SWDKDI1A.11
C Berkshire UK SWDKDI1A.12
C RG12 2SZ SWDKDI1A.13
C SWDKDI1A.14
C If no contract has been raised with this copy of the code, the use, SWDKDI1A.15
C duplication or disclosure of it is strictly prohibited. Permission SWDKDI1A.16
C to do so must first be obtained in writing from the Head of Numerical SWDKDI1A.17
C Modelling at the above address. SWDKDI1A.18
C ******************************COPYRIGHT****************************** SWDKDI1A.19
C SWDKDI1A.20
CLL Subroutine SWDKDI ------------------------------------------------- SWDKDI1A.21
CLL SWDKDI1A.22
CLL Its function is to calculate SW diagnostics (those that are not SWDKDI1A.23
CLL naturally zero at night points) in the case when the entire domain SWDKDI1A.24
CLL is in darkness. It simply reproduces the relevant code from SWRAD, SWDKDI1A.25
CLL which cannot be CALLed itself as it dynamically allocates arrays SWDKDI1A.26
CLL dimensioned by the number of sunlit points. For more information, SWDKDI1A.27
CLL see that routine. SWDKDI1A.28
CLL SWDKDI1A.29
CLL Model Modification history: SWDKDI1A.30
CLL version Date SWDKDI1A.31
CLL 4.3 16/10/96 Written by William Ingram & reviewed by Paul Burton SWDKDI1A.32
CLL SWDKDI1A.33
CLLEND -------------------------------------------------------------- SWDKDI1A.34
C*L SWDKDI1A.35
SUBROUTINE SWDKDI (ABIN, BBIN, LCAIN, CCAIN, 1,2SWDKDI1A.36
& LCA3L, LCA3ON, TCASW, TCASWO, LCLD3, SWDKDI1A.37
& NDO, NLEVS, NCLDS, L1) SWDKDI1A.38
IMPLICIT NONE SWDKDI1A.39
EXTERNAL SWDTCA SWDKDI1A.40
C* SWDKDI1A.41
C SWDKDI1A.42
C ! Dimensions: SWDKDI1A.43
INTEGER!, INTENT(IN) :: SWDKDI1A.44
& L1, ! Number of points in input arrays SWDKDI1A.45
& NDO, ! Number of points to be treated SWDKDI1A.46
& NLEVS, ! Number of levels SWDKDI1A.47
& NCLDS ! Number of possibly cloudy levels SWDKDI1A.48
C ! Physical inputs: SWDKDI1A.49
REAL!, SWDKDI1A.50
& ABIN(NLEVS+1), BBIN(NLEVS+1), ! As and Bs at layer boundaries SWDKDI1A.51
& LCAIN(L1,1/(NCLDS+1)+NCLDS), ! Layer cloud fractional cover SWDKDI1A.52
& CCAIN(L1) ! Convective Cloud Amount SWDKDI1A.53
C ! Control quantities: SWDKDI1A.54
LOGICAL!, INTENT(IN) :: SWDKDI1A.55
& LCLD3, ! Is the 3-cloud trick on (2A SW) ? SWDKDI1A.56
& TCASWO, ! Is TCASW wanted ? SWDKDI1A.57
& LCA3ON ! And LCA3L ? SWDKDI1A.58
C ! Note that if LCLD3, LCA3L is needed to calculate TCASW & so SWDKDI1A.59
C ! will be calculated whenever TCASWO or LCA3ON - so space must SWDKDI1A.60
C ! then be available (via "implied diagnostics" in the std UM). SWDKDI1A.61
C ! And outputs: SWDKDI1A.62
REAL!, INTENT(OUT) :: SWDKDI1A.63
& TCASW(L1), ! Total cloud amount in SW SWDKDI1A.64
C ! (i.e. fraction of the grid-box with cloud at some level) SWDKDI1A.65
& LCA3L(L1,NCLDS) ! Diagnostic of layer cloud amount SWDKDI1A.66
C ! restricted to 3 layers, calculated at all points on SW timesteps SWDKDI1A.67
C* SWDKDI1A.68
C ! Constants: SWDKDI1A.69
*CALL C_R_CP 
SWDKDI1A.70
C*L SWDKDI1A.71
CL ! Dynamically allocated workspace: SWDKDI1A.72
INTEGER INDEX(NDO) SWDKDI1A.73
C ! Index for maximum(input)/only(used) cloud cover for a "type" SWDKDI1A.74
REAL MAXCLD(NDO) ! Maximum cloud cover SWDKDI1A.75
& ! for a "type" SWDKDI1A.76
C* SWDKDI1A.77
INTEGER LEVEL, J, ! Loopers over level and point SWDKDI1A.78
& TYPE, ! & cloud "type" (H/M/L) SWDKDI1A.79
& RANGE(3,2), ! The range of level numbers SWDKDI1A.80
C ! (counting down from the highest potentially cloudy level) for SWDKDI1A.81
C ! the 3 cloud "types" - i.e. the RANGE(n,1)th to RANGE(n,2)th SWDKDI1A.82
C ! potentially cloudy levels are assigned to the nth cloud type. SWDKDI1A.83
C ! The values are set by comparing model eta values with BOUNDS. SWDKDI1A.84
& FSTLEV, ! The equivalent of RANGE for SWDKDI1A.85
& LSTLEV, ! a particular cloud type, but SWDKDI1A.86
C ! counting up from the surface SWDKDI1A.87
& NCLEAR ! NLEVS-NCLDS SWDKDI1A.88
REAL BOUNDS(2), ! Eta values that define where SWDKDI1A.89
C ! cloud changes from "high" to "medium", & from "medium" to "low" SWDKDI1A.90
& ETA, ! Eta at the layer boundary SWDKDI1A.91
C ! ! currently being checked SWDKDI1A.92
& ETALST ! & the previous one SWDKDI1A.93
LOGICAL SET ! Has RANGE been set yet ? SWDKDI1A.94
DATA BOUNDS / .37, .79 / SWDKDI1A.95
DATA SET / .FALSE. / SWDKDI1A.96
SAVE RANGE, SET ! SET must be specified too as SWDKDI1A.97
C ! FORTRAN requires a variable initialized by a DATA statement to SWDKDI1A.98
C ! have the SAVE attribute only if its value has not changed. SWDKDI1A.99
SWDKDI1A.100
CL ! If LCLD3 is on, the first time into the routine, find where SWDKDI1A.101
CL ! cloud type boundaries will lie in terms of the numbering of this SWDKDI1A.102
CL ! run's eta levels: SWDKDI1A.103
C SWDKDI1A.104
IF ( LCLD3 .AND. .NOT. SET ) THEN SWDKDI1A.105
NCLEAR = NLEVS - NCLDS SWDKDI1A.106
RANGE(1,1) = 1 SWDKDI1A.107
LEVEL = NCLEAR + 1 SWDKDI1A.108
DO J=1, 2 SWDKDI1A.109
101 ETA = BBIN(NLEVS+2-LEVEL) + ABIN(NLEVS+2-LEVEL) / PREF SWDKDI1A.110
IF ( ETA .LT. BOUNDS(J) ) THEN SWDKDI1A.111
LEVEL = LEVEL + 1 SWDKDI1A.112
ETALST = ETA SWDKDI1A.113
C ! This assumes the vertical resolution is not too crude in SWDKDI1A.114
C ! the troposphere - but it would have to be rather worse SWDKDI1A.115
C ! even than the old 11-layer Cyber climate model. SWDKDI1A.116
GO TO 101 SWDKDI1A.117
ELSE SWDKDI1A.118
C ! This has found the first layer boundary below BOUNDS - SWDKDI1A.119
C ! is this or the previous one closer ? SWDKDI1A.120
IF ( BOUNDS(J)-ETALST .LT. ETA-BOUNDS(J) ) LEVEL = LEVEL-1 SWDKDI1A.121
RANGE(J+1,1) = LEVEL - NCLEAR SWDKDI1A.122
RANGE(J,2) = RANGE(J+1,1) - 1 SWDKDI1A.123
ENDIF SWDKDI1A.124
ENDDO SWDKDI1A.125
RANGE(3,2) = NCLDS SWDKDI1A.126
SET = .TRUE. SWDKDI1A.127
ENDIF SWDKDI1A.128
C SWDKDI1A.129
C ! Next IF block calculates the diagnostic LCA3L. SWDKDI1A.130
C ! This must be done if this diagnostic is wanted in its own right SWDKDI1A.131
C ! or, when the 3-cloud trick is on, if TCASW is, as then the SWDKDI1A.132
C ! latter is calculated from LCA3L. SWDKDI1A.133
C SWDKDI1A.134
IF ( LCA3ON .OR. TCASWO .AND. LCLD3 ) THEN SWDKDI1A.135
DO TYPE=1, 3 SWDKDI1A.136
FSTLEV = NCLDS + 1 - RANGE(TYPE,2) SWDKDI1A.137
LSTLEV = NCLDS + 1 - RANGE(TYPE,1) SWDKDI1A.138
Cfpp$ Select(CONCUR) SWDKDI1A.139
DO J=1, NDO SWDKDI1A.140
MAXCLD(J) = LCAIN(J,FSTLEV) SWDKDI1A.141
INDEX(J) = FSTLEV SWDKDI1A.142
ENDDO SWDKDI1A.143
DO LEVEL=FSTLEV+1, LSTLEV SWDKDI1A.144
Cfpp$ Select(CONCUR) SWDKDI1A.145
DO 163 J=1, NDO SWDKDI1A.146
IF ( MAXCLD(J) .LT. LCAIN(J,LEVEL) ) THEN SWDKDI1A.147
MAXCLD(J) = LCAIN(J,LEVEL) SWDKDI1A.148
INDEX(J) = LEVEL SWDKDI1A.149
ENDIF SWDKDI1A.150
163 CONTINUE ! Next J SWDKDI1A.151
ENDDO ! Next LEVEL SWDKDI1A.152
DO LEVEL=FSTLEV, LSTLEV SWDKDI1A.153
Cfpp$ Select(CONCUR) SWDKDI1A.154
DO 164 J=1, NDO SWDKDI1A.155
IF ( LEVEL .EQ. INDEX(J) ) THEN SWDKDI1A.156
LCA3L(J,LEVEL) = MAXCLD(J) SWDKDI1A.157
ELSE SWDKDI1A.158
LCA3L(J,LEVEL) = 0. SWDKDI1A.159
ENDIF SWDKDI1A.160
164 CONTINUE ! Next J SWDKDI1A.161
ENDDO ! Next LEVEL SWDKDI1A.162
ENDDO ! Next TYPE SWDKDI1A.163
ENDIF ! LCA3ON .OR. TCASWO .AND. LCLD3 SWDKDI1A.164
C SWDKDI1A.165
C SWDKDI1A.166
CL ! If wanted, diagnose total cloud amount as seen by the SW: SWDKDI1A.167
C SWDKDI1A.168
IF ( TCASWO ) THEN SWDKDI1A.169
IF ( LCLD3 ) THEN SWDKDI1A.170
CALL SWDTCA (LCA3L, CCAIN, NCLDS, L1, NDO, TCASW) SWDKDI1A.171
ELSE SWDKDI1A.172
CALL SWDTCA (LCAIN, CCAIN, NCLDS, L1, NDO, TCASW) SWDKDI1A.173
ENDIF SWDKDI1A.174
ENDIF SWDKDI1A.175
C SWDKDI1A.176
RETURN SWDKDI1A.177
END SWDKDI1A.178
*ENDIF DEF,A01_1A,OR,DEF,A01_1B,OR,DEF,A01_2A,OR,DEF,A01_2B SWDKDI1A.179