*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.113
*IF DEF,A01_3A,OR,DEF,A02_3A STMTF3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.14062
C GTS2F400.14063
C Use, duplication or disclosure of this code is subject to the GTS2F400.14064
C restrictions as set forth in the contract. GTS2F400.14065
C GTS2F400.14066
C Meteorological Office GTS2F400.14067
C London Road GTS2F400.14068
C BRACKNELL GTS2F400.14069
C Berkshire UK GTS2F400.14070
C RG12 2SZ GTS2F400.14071
C GTS2F400.14072
C If no contract has been raised with this copy of the code, the use, GTS2F400.14073
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.14074
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.14075
C Modelling at the above address. GTS2F400.14076
C ******************************COPYRIGHT****************************** GTS2F400.14077
C GTS2F400.14078
!+ Subroutine to set the matrix equations for the fluxes. ADB1F401.996
! STMTF3A.4
! Method: STMTF3A.5
! Straightforward. STMTF3A.6
! STMTF3A.7
! Current Owner of Code: J. M. Edwards STMTF3A.8
! STMTF3A.9
! History: STMTF3A.10
! Version Date Comment STMTF3A.11
! 4.0 27-07-95 Original Code STMTF3A.12
! (J. M. Edwards) STMTF3A.13
! 4.1 05-03-96 Surface albedo and ADB1F401.997
! reflection coefficients ADB1F401.998
! perturbed to avoid ADB1F401.999
! failure above a ADB1F401.1000
! non-reflecting surface ADB1F401.1001
! or in a strongly ADB1F401.1002
! absorbing atmosphere. ADB1F401.1003
! STMTF3A.14
! Description of Code: STMTF3A.15
! FORTRAN 77 with extensions listed in documentation. STMTF3A.16
! STMTF3A.17
!- --------------------------------------------------------------------- STMTF3A.18
SUBROUTINE SET_MATRIX_FULL(N_PROFILE, N_LAYER STMTF3A.19
& , TRANS, REFLECT STMTF3A.20
& , S_DOWN, S_UP STMTF3A.21
& , ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR STMTF3A.22
& , FLUX_DIRECT_GROUND, FLUX_INC_DOWN STMTF3A.23
& , SOURCE_GROUND STMTF3A.24
& , A3, B STMTF3A.25
& , NPD_PROFILE, NPD_LAYER STMTF3A.26
& ) STMTF3A.27
! STMTF3A.28
! STMTF3A.29
IMPLICIT NONE STMTF3A.30
! STMTF3A.31
! STMTF3A.32
! COMDECKS INCLUDED. ADB1F401.1004
*CALL PRMCH3A 
ADB1F401.1005
! ADB1F401.1006
! SIZES OF DUMMY ARRAYS. STMTF3A.33
INTEGER !, INTENT(IN) STMTF3A.34
& NPD_PROFILE STMTF3A.35
! MAXIMUM NUMBER OF PROFILES STMTF3A.36
& , NPD_LAYER STMTF3A.37
! MAXIMUM NUMBER OF LAYERS STMTF3A.38
! STMTF3A.39
! DUMMY ARGUMENTS. STMTF3A.40
INTEGER !, INTENT(IN) STMTF3A.41
& N_PROFILE STMTF3A.42
! NUMBER OF PROFILES STMTF3A.43
& , N_LAYER STMTF3A.44
! NUMBER OF LAYERS STMTF3A.45
REAL !, INTENT(IN) STMTF3A.46
& TRANS(NPD_PROFILE, NPD_LAYER) STMTF3A.47
! TRANSMISSION COEFFICIENTS STMTF3A.48
& , REFLECT(NPD_PROFILE, NPD_LAYER) STMTF3A.49
! REFLECT COEFFICIENTS STMTF3A.50
& , S_UP(NPD_PROFILE, NPD_LAYER) STMTF3A.51
! UPWARD SOURCE FUNCTION STMTF3A.52
& , S_DOWN(NPD_PROFILE, NPD_LAYER) STMTF3A.53
! DOWNWARD SOURCE FUNCTION STMTF3A.54
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) STMTF3A.55
! DIFFUSE REFLECTION COEFFICIENTS STMTF3A.56
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) STMTF3A.57
! DIRECT REFLECTION COEFFICIENTS STMTF3A.58
& , FLUX_DIRECT_GROUND(NPD_PROFILE) STMTF3A.59
! DIRECT FLUX AT SURFACE STMTF3A.60
& , FLUX_INC_DOWN(NPD_PROFILE) STMTF3A.61
! INCIDENT DOWNWARD FLUX STMTF3A.62
& , SOURCE_GROUND(NPD_PROFILE) STMTF3A.63
! SOURCE FROM GROUND STMTF3A.64
REAL !, INTENT(OUT) STMTF3A.65
& A3(NPD_PROFILE, 3, 2*NPD_LAYER+2) STMTF3A.66
! TRIDIAGONAL MATRIX STMTF3A.67
& , B(NPD_PROFILE, 2*NPD_LAYER+2) STMTF3A.68
! RHS OF EQUATIONS STMTF3A.69
! STMTF3A.70
! LOCAL VARIABLES. STMTF3A.71
INTEGER STMTF3A.72
& I STMTF3A.73
! LOOP VARIABLE STMTF3A.74
& , L STMTF3A.75
! LOOP VARIABLE STMTF3A.76
REAL ADB1F401.1007
& PERTURBATION ADB1F401.1008
! PERTURBATION TO RESTORE CONDITIONING ADB1F401.1009
! STMTF3A.77
! STMTF3A.78
! CODE THE EQUATIONS INTO THE MATRIX: STMTF3A.79
! UPPER SURFACE: STMTF3A.80
DO L=1, N_PROFILE STMTF3A.81
A3(L, 2, 1)=0.0E+00 STMTF3A.82
A3(L, 3, 1)=1.0E+00 STMTF3A.83
B(L, 1)=FLUX_INC_DOWN(L) STMTF3A.84
ENDDO STMTF3A.85
! THE INTERIOR EQUATIONS: STMTF3A.86
DO I=1, N_LAYER STMTF3A.87
DO L=1, N_PROFILE STMTF3A.88
PERTURBATION=(1.0E+00-TRANS(L, I)-REFLECT(L, I)) ADB1F401.1010
& *TOL_MACHINE/(SQRT_TOL_MACHINE+REFLECT(L, I)) ADB1F401.1011
A3(L, 1, 2*I)=1.0E+00 STMTF3A.89
A3(L, 2, 2*I)=-REFLECT(L, I)-PERTURBATION ADB1F401.1012
A3(L, 3, 2*I)=-TRANS(L, I) STMTF3A.91
B(L, 2*I)=S_UP(L, I) STMTF3A.92
A3(L, 1, 2*I+1)=-TRANS(L, I) STMTF3A.93
A3(L, 2, 2*I+1)=-REFLECT(L, I)-PERTURBATION ADB1F401.1013
A3(L, 3, 2*I+1)=1.0E+00 STMTF3A.95
B(L, 2*I+1)=S_DOWN(L, I) STMTF3A.96
ENDDO STMTF3A.97
ENDDO STMTF3A.98
! LOWER BOUNDARY STMTF3A.99
DO L=1, N_PROFILE STMTF3A.100
A3(L, 1, 2*N_LAYER+2)=1.0E+00 STMTF3A.101
A3(L, 2, 2*N_LAYER+2)=-ALBEDO_SURFACE_DIFF(L) STMTF3A.102
& -TOL_MACHINE/(ALBEDO_SURFACE_DIFF(L)+SQRT_TOL_MACHINE) ADB1F401.1014
B(L, 2*N_LAYER+2) STMTF3A.103
& =(ALBEDO_SURFACE_DIR(L)-ALBEDO_SURFACE_DIFF(L)) STMTF3A.104
& *FLUX_DIRECT_GROUND(L)+SOURCE_GROUND(L) STMTF3A.105
ENDDO STMTF3A.106
! STMTF3A.107
! STMTF3A.108
RETURN STMTF3A.109
END STMTF3A.110
*ENDIF DEF,A01_3A,OR,DEF,A02_3A STMTF3A.111
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.114