*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.49
*IF DEF,A01_3A,OR,DEF,A02_3A MXCOF3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13501
C GTS2F400.13502
C Use, duplication or disclosure of this code is subject to the GTS2F400.13503
C restrictions as set forth in the contract. GTS2F400.13504
C GTS2F400.13505
C Meteorological Office GTS2F400.13506
C London Road GTS2F400.13507
C BRACKNELL GTS2F400.13508
C Berkshire UK GTS2F400.13509
C RG12 2SZ GTS2F400.13510
C GTS2F400.13511
C If no contract has been raised with this copy of the code, the use, GTS2F400.13512
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13513
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13514
C Modelling at the above address. GTS2F400.13515
C ******************************COPYRIGHT****************************** GTS2F400.13516
C GTS2F400.13517
!+ Subroutine implementing an endekadiagonal solution of the equations. MXCOF3A.3
! MXCOF3A.4
! Method: MXCOF3A.5
! This subroutine calls subroutines to set the endekadiagonal MXCOF3A.6
! matrix for the clear and cloudy upward and downward fluxes MXCOF3A.7
! and to solve those equations. It is kept separate to avoid MXCOF3A.8
! allocating space for so large a matrix in the upper routine MXCOF3A.9
! when that is used in a GCM and this routine is very MXCOF3A.10
! unlikely to be used. MXCOF3A.11
! MXCOF3A.12
! Current Owner of Code: J. M. Edwards MXCOF3A.13
! MXCOF3A.14
! History: MXCOF3A.15
! Version Date Comment MXCOF3A.16
! 4.0 27-07-95 Original Code MXCOF3A.17
! (J. M. Edwards) MXCOF3A.18
! MXCOF3A.19
! Description of Code: MXCOF3A.20
! FORTRAN 77 with extensions listed in documentation. MXCOF3A.21
! MXCOF3A.22
!- --------------------------------------------------------------------- MXCOF3A.23
SUBROUTINE MIX_COLUMN_FULL(N_PROFILE, N_LAYER, N_CLOUD_TOP 1,2MXCOF3A.24
& , T_FREE, R_FREE, S_DOWN_FREE, S_UP_FREE MXCOF3A.25
& , T_CLOUD, R_CLOUD, S_DOWN_CLOUD, S_UP_CLOUD MXCOF3A.26
& , G_M, G_P, B_M, B_P MXCOF3A.27
& , FLUX_INC_DOWN MXCOF3A.28
& , SOURCE_GROUND, ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR MXCOF3A.29
& , FLUX_DIRECT_GROUND MXCOF3A.30
& , FLUX_TOTAL MXCOF3A.31
& , NPD_PROFILE, NPD_LAYER MXCOF3A.32
& ) MXCOF3A.33
! MXCOF3A.34
! MXCOF3A.35
! MXCOF3A.36
IMPLICIT NONE MXCOF3A.37
! MXCOF3A.38
! MXCOF3A.39
! SIZES OF DUMMY ARRAYS. MXCOF3A.40
INTEGER !, INTENT(IN) MXCOF3A.41
& NPD_PROFILE MXCOF3A.42
! MAXIMUM NUMBER OF PROFILES MXCOF3A.43
& , NPD_LAYER MXCOF3A.44
! MAXIMUM NUMBER OF LAYERS MXCOF3A.45
! MXCOF3A.46
! MXCOF3A.47
! DUMMY ARGUMENTS. MXCOF3A.48
INTEGER !, INTENT(IN) MXCOF3A.49
& N_PROFILE MXCOF3A.50
! NUMBER OF PROFILES MXCOF3A.51
& , N_LAYER MXCOF3A.52
! NUMBER OF LAYERS MXCOF3A.53
& , N_CLOUD_TOP MXCOF3A.54
! TOPMOST CLOUDY LAYER MXCOF3A.55
REAL !, INTENT(IN) MXCOF3A.56
& T_FREE(NPD_PROFILE, NPD_LAYER) MXCOF3A.57
! FREE TRANSMISSION MXCOF3A.58
& , R_FREE(NPD_PROFILE, NPD_LAYER) MXCOF3A.59
! FREE REFLECTION MXCOF3A.60
& , S_DOWN_FREE(NPD_PROFILE, NPD_LAYER) MXCOF3A.61
! FREE DOWNWARD SOURCE FUNCTION MXCOF3A.62
& , S_UP_FREE(NPD_PROFILE, NPD_LAYER) MXCOF3A.63
! FREE UPWARD SOURCE FUNCTION MXCOF3A.64
& , T_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOF3A.65
! CLOUDY TRANSMISSION MXCOF3A.66
& , R_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOF3A.67
! CLOUDY REFLECTION MXCOF3A.68
& , S_DOWN_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOF3A.69
! DOWNWARD CLOUDY SOURCE FUNCTION MXCOF3A.70
& , S_UP_CLOUD(NPD_PROFILE, NPD_LAYER) MXCOF3A.71
! UPWARD CLOUDY SOURCE FUNCTION MXCOF3A.72
REAL !, INTENT(IN) MXCOF3A.73
& B_M(NPD_PROFILE, 0: NPD_LAYER) MXCOF3A.74
! ENERGY TRANSFER COEFFICIENT MXCOF3A.75
& , B_P(NPD_PROFILE, 0: NPD_LAYER) MXCOF3A.76
! ENERGY TRANSFER COEFFICIENT MXCOF3A.77
& , G_M(NPD_PROFILE, 0: NPD_LAYER) MXCOF3A.78
! ENERGY TRANSFER COEFFICIENT MXCOF3A.79
& , G_P(NPD_PROFILE, 0: NPD_LAYER) MXCOF3A.80
! ENERGY TRANSFER COEFFICIENT MXCOF3A.81
REAL !, INTENT(IN) MXCOF3A.82
& FLUX_INC_DOWN(NPD_PROFILE) MXCOF3A.83
! INCIDENT TOTAL FLUX MXCOF3A.84
& , SOURCE_GROUND(NPD_PROFILE) MXCOF3A.85
! SOURCE FROM GROUND MXCOF3A.86
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) MXCOF3A.87
! DIFFUSE ALBEDO MXCOF3A.88
& , ALBEDO_SURFACE_DIR(NPD_PROFILE) MXCOF3A.89
! DIRECT ALBEDO MXCOF3A.90
& , FLUX_DIRECT_GROUND(NPD_PROFILE) MXCOF3A.91
! DIRECT FLUX AT GROUND MXCOF3A.92
REAL !, INTENT(OUT) MXCOF3A.93
& FLUX_TOTAL(NPD_PROFILE, 2*NPD_LAYER+2) MXCOF3A.94
! TOTAL FLUX MXCOF3A.95
! MXCOF3A.96
! LOCAL VARIABLES. MXCOF3A.97
INTEGER MXCOF3A.98
& I MXCOF3A.99
! LOOP VARIABLE MXCOF3A.100
& , L MXCOF3A.101
! LOOP VARIABLE MXCOF3A.102
& , N_EQUATION MXCOF3A.103
! NUMBER OF EQUATIONS MXCOF3A.104
REAL MXCOF3A.105
& A11(NPD_PROFILE, 11, 4*NPD_LAYER+4) MXCOF3A.106
! MATRIX TO BE SOLVED MXCOF3A.107
& , B(NPD_PROFILE, 4*NPD_LAYER+4) MXCOF3A.108
! RIGHT-HAND SIDE OF EQUATION MXCOF3A.109
& , X(NPD_PROFILE, 4*NPD_LAYER+4) MXCOF3A.110
! SOLUTION TO MATRIX EQUATION MXCOF3A.111
& , WORK(NPD_PROFILE) MXCOF3A.112
! WORKING ARRAY MXCOF3A.113
! MXCOF3A.114
! SUBROUTINES CALLED: MXCOF3A.115
EXTERNAL MXCOF3A.116
& MIX_MATRIX_ELEM, BAND_SOLVER MXCOF3A.117
! MXCOF3A.118
! MXCOF3A.119
! MXCOF3A.120
! ASSIGN THE ELEMENTS OF THE MATRIX A11 AND THE VECTOR B. MXCOF3A.121
CALL MIX_MATRIX_ELEM
(N_PROFILE, N_LAYER, N_CLOUD_TOP MXCOF3A.122
& , T_FREE, R_FREE, S_DOWN_FREE, S_UP_FREE MXCOF3A.123
& , T_CLOUD, R_CLOUD, S_DOWN_CLOUD, S_UP_CLOUD MXCOF3A.124
& , G_M, G_P, B_M, B_P MXCOF3A.125
& , FLUX_INC_DOWN MXCOF3A.126
& , SOURCE_GROUND, ALBEDO_SURFACE_DIFF, ALBEDO_SURFACE_DIR MXCOF3A.127
& , FLUX_DIRECT_GROUND MXCOF3A.128
& , A11, B MXCOF3A.129
& , NPD_PROFILE, NPD_LAYER MXCOF3A.130
& ) MXCOF3A.131
! MXCOF3A.132
N_EQUATION=4*N_LAYER+4 MXCOF3A.133
CALL BAND_SOLVER(N_PROFILE, N_EQUATION MXCOF3A.134
& , 5, 5 MXCOF3A.135
& , A11, B MXCOF3A.136
& , X MXCOF3A.137
& , NPD_PROFILE, 4*NPD_LAYER+4 MXCOF3A.138
& , WORK MXCOF3A.139
& ) MXCOF3A.140
! MXCOF3A.141
! PICK OUT THE SUMMED FLUXES FROM THE LONG VECTOR MXCOF3A.142
DO I=1, 2*N_LAYER+2 MXCOF3A.143
DO L=1, N_PROFILE MXCOF3A.144
FLUX_TOTAL(L, I)=X(L, 2*I) MXCOF3A.145
ENDDO MXCOF3A.146
ENDDO MXCOF3A.147
! MXCOF3A.148
! MXCOF3A.149
RETURN MXCOF3A.150
END MXCOF3A.151
*ENDIF DEF,A01_3A,OR,DEF,A02_3A MXCOF3A.152
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.50