*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.89
*IF DEF,A01_3A,OR,DEF,A02_3A SLHGDR3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. SLHGDR3A.3
C SLHGDR3A.4
C Use, duplication or disclosure of this code is subject to the SLHGDR3A.5
C restrictions as set forth in the contract. SLHGDR3A.6
C SLHGDR3A.7
C Meteorological Office SLHGDR3A.8
C London Road SLHGDR3A.9
C BRACKNELL SLHGDR3A.10
C Berkshire UK SLHGDR3A.11
C RG12 2SZ SLHGDR3A.12
C SLHGDR3A.13
C If no contract has been raised with this copy of the code, the use, SLHGDR3A.14
C duplication or disclosure of it is strictly prohibited. Permission SLHGDR3A.15
C to do so must first be obtained in writing from the Head of Numerical SLHGDR3A.16
C Modelling at the above address. SLHGDR3A.17
C ******************************COPYRIGHT****************************** SLHGDR3A.18
C SLHGDR3A.19
!+ Subroutine to calculate fluxes in a homogeneous column directly. SLHGDR3A.20
! SLHGDR3A.21
! Method: SLHGDR3A.22
! Straightforward. SLHGDR3A.23
! SLHGDR3A.24
! Current Owner of Code: J. M. Edwards SLHGDR3A.25
! SLHGDR3A.26
! History: SLHGDR3A.27
! Version Date Comment SLHGDR3A.28
! 4.1 09-04-96 Original Code SLHGDR3A.29
! (J. M. Edwards) SLHGDR3A.30
! SLHGDR3A.31
! Description of Code: SLHGDR3A.32
! FORTRAN 77 with extensions listed in documentation. SLHGDR3A.33
! SLHGDR3A.34
!- --------------------------------------------------------------------- SLHGDR3A.35
SUBROUTINE SOLVER_HOMOGEN_DIRECT(N_PROFILE, N_LAYER 3SLHGDR3A.36
& , TRANS, REFLECT SLHGDR3A.37
& , S_DOWN, S_UP SLHGDR3A.38
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR SLHGDR3A.39
& , FLUX_DIRECT_GROUND, FLUX_INC_DOWN SLHGDR3A.40
& , SOURCE_GROUND SLHGDR3A.41
& , FLUX_TOTAL SLHGDR3A.42
& , NPD_PROFILE, NPD_LAYER SLHGDR3A.43
& ) SLHGDR3A.44
! SLHGDR3A.45
! SLHGDR3A.46
IMPLICIT NONE SLHGDR3A.47
! SLHGDR3A.48
! SLHGDR3A.49
! SIZES OF DUMMY ARRAYS. SLHGDR3A.50
INTEGER !, INTENT(IN) SLHGDR3A.51
& NPD_PROFILE SLHGDR3A.52
! MAXIMUM NUMBER OF PROFILES SLHGDR3A.53
& , NPD_LAYER SLHGDR3A.54
! MAXIMUM NUMBER OF LAYERS SLHGDR3A.55
! SLHGDR3A.56
! SLHGDR3A.57
! DUMMY ARGUMENTS. SLHGDR3A.58
INTEGER !, INTENT(IN) SLHGDR3A.59
& N_PROFILE SLHGDR3A.60
! NUMBER OF PROFILES SLHGDR3A.61
& , N_LAYER SLHGDR3A.62
! NUMBER OF LAYERS SLHGDR3A.63
REAL !, INTENT(IN) SLHGDR3A.64
& TRANS(NPD_PROFILE, NPD_LAYER) SLHGDR3A.65
! TRANSMISSION COEFFICIENT SLHGDR3A.66
& , REFLECT(NPD_PROFILE, NPD_LAYER) SLHGDR3A.67
! REFLECTION COEFFICIENT SLHGDR3A.68
& , S_DOWN(NPD_PROFILE, NPD_LAYER) SLHGDR3A.69
! DOWNWARD DIFFUSE SOURCE SLHGDR3A.70
& , S_UP(NPD_PROFILE, NPD_LAYER) SLHGDR3A.71
! UPWARD DIFFUSE SOURCE SLHGDR3A.72
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) SLHGDR3A.73
! DIFFUSE SURFACE ALBEDO SLHGDR3A.74
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) SLHGDR3A.75
! DIRECT SURFACE ALBEDO SLHGDR3A.76
& , SOURCE_GROUND(NPD_PROFILE) SLHGDR3A.77
! SOURCE FUNCTION OF GROUND SLHGDR3A.78
& , FLUX_INC_DOWN(NPD_PROFILE) SLHGDR3A.79
! INCIDENT TOTAL FLUX SLHGDR3A.80
& , FLUX_DIRECT_GROUND(NPD_PROFILE) SLHGDR3A.81
! DIRECT FLUX AT SLHGDR3A.82
! GROUND LEVEL SLHGDR3A.83
! SLHGDR3A.84
REAL !, INTENT(OUT) SLHGDR3A.85
& FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) SLHGDR3A.86
! TOTAL FLUX SLHGDR3A.87
! SLHGDR3A.88
! DECLARATION OF LOCAL VARIABLES. SLHGDR3A.89
INTEGER SLHGDR3A.90
& I SLHGDR3A.91
! LOOP VARIABLE SLHGDR3A.92
& , L SLHGDR3A.93
! LOOP VARIABLE SLHGDR3A.94
! SLHGDR3A.95
REAL SLHGDR3A.96
& ALPHA(NPD_PROFILE, NPD_LAYER+1) SLHGDR3A.97
! COMBINED ALBEDO OF LOWER LAYERS SLHGDR3A.98
& , BETA(NPD_PROFILE, NPD_LAYER) SLHGDR3A.99
! WORKING ARRAY SLHGDR3A.100
& , GAMMA(NPD_PROFILE, NPD_LAYER) SLHGDR3A.101
! WORKING ARRAY SLHGDR3A.102
& , H(NPD_PROFILE, NPD_LAYER) SLHGDR3A.103
! WORKING ARRAY SLHGDR3A.104
& , S_UP_PRIME(NPD_PROFILE, NPD_LAYER+1) SLHGDR3A.105
! MODIFIED UPWARD SOURCE FUNCTION SLHGDR3A.106
! SLHGDR3A.107
! SLHGDR3A.108
! SLHGDR3A.109
! INITIALIZATION AT THE BOTTOM FOR UPWARD ELIMINATION: SLHGDR3A.110
DO L=1, N_PROFILE SLHGDR3A.111
ALPHA(L, N_LAYER+1)=ALBEDO_SURFACE_DIFF(L) SLHGDR3A.112
S_UP_PRIME(L, N_LAYER+1)=SOURCE_GROUND(L) SLHGDR3A.113
& +(ALBEDO_SURFACE_DIR(L)-ALBEDO_SURFACE_DIFF(L)) SLHGDR3A.114
& *FLUX_DIRECT_GROUND(L) SLHGDR3A.115
ENDDO SLHGDR3A.116
! SLHGDR3A.117
! ELIMINATING LOOP: SLHGDR3A.118
DO I=N_LAYER, 1, -1 SLHGDR3A.119
DO L=1, N_PROFILE SLHGDR3A.120
BETA(L, I)=1.0E+00/(1.0E+00-ALPHA(L, I+1)*REFLECT(L, I)) SLHGDR3A.121
GAMMA(L, I)=ALPHA(L, I+1)*TRANS(L, I) SLHGDR3A.122
H(L, I)=S_UP_PRIME(L, I+1)+ALPHA(L, I+1)*S_DOWN(L, I) SLHGDR3A.123
ALPHA(L, I)=REFLECT(L, I) SLHGDR3A.124
& +BETA(L, I)*GAMMA(L, I)*TRANS(L, I) SLHGDR3A.125
S_UP_PRIME(L, I)=S_UP(L, I)+BETA(L, I)*TRANS(L, I)*H(L, I) SLHGDR3A.126
ENDDO SLHGDR3A.127
ENDDO SLHGDR3A.128
! SLHGDR3A.129
! INITIALIZE FOR BACKWARD SUBSTITUTION. SLHGDR3A.130
DO L=1, N_PROFILE SLHGDR3A.131
FLUX_TOTAL(L, 2)=FLUX_INC_DOWN(L) SLHGDR3A.132
FLUX_TOTAL(L, 1)=ALPHA(L, 1)*FLUX_TOTAL(L, 2)+S_UP_PRIME(L, 1) SLHGDR3A.133
ENDDO SLHGDR3A.134
! SLHGDR3A.135
! BACKWARD SUBSTITUTION: SLHGDR3A.136
DO I=1, N_LAYER SLHGDR3A.137
DO L=1, N_PROFILE SLHGDR3A.138
! UPWARD FLUX SLHGDR3A.139
FLUX_TOTAL(L, 2*I+1) SLHGDR3A.140
& =BETA(L, I)*(H(L, I)+GAMMA(L, I)*FLUX_TOTAL(L, 2*I)) SLHGDR3A.141
! DOWNWARD FLUX SLHGDR3A.142
FLUX_TOTAL(L, 2*I+2)=S_DOWN(L, I) SLHGDR3A.143
& +TRANS(L, I)*FLUX_TOTAL(L, 2*I) SLHGDR3A.144
& +REFLECT(L, I)*FLUX_TOTAL(L, 2*I+1) SLHGDR3A.145
ENDDO SLHGDR3A.146
ENDDO SLHGDR3A.147
! SLHGDR3A.148
! SLHGDR3A.149
! SLHGDR3A.150
RETURN SLHGDR3A.151
END SLHGDR3A.152
*ENDIF DEF,A01_3A,OR,DEF,A02_3A SLHGDR3A.153
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.90