*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.33
*IF DEF,A01_3A,OR,DEF,A02_3A GSSAN3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13331
C GTS2F400.13332
C Use, duplication or disclosure of this code is subject to the GTS2F400.13333
C restrictions as set forth in the contract. GTS2F400.13334
C GTS2F400.13335
C Meteorological Office GTS2F400.13336
C London Road GTS2F400.13337
C BRACKNELL GTS2F400.13338
C Berkshire UK GTS2F400.13339
C RG12 2SZ GTS2F400.13340
C GTS2F400.13341
C If no contract has been raised with this copy of the code, the use, GTS2F400.13342
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13343
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13344
C Modelling at the above address. GTS2F400.13345
C ******************************COPYRIGHT****************************** GTS2F400.13346
C GTS2F400.13347
!+ Subroutine to calculate fluxes using Gaussian quadrature. GSSAN3A.3
! GSSAN3A.4
! Method: GSSAN3A.5
! Fluxes are calculated by using Gaussian quadrature for GSSAN3A.6
! the angular integration. This is not a full implementation GSSAN3A.7
! of Gaussian quadrature for multiple scattering, but is GSSAN3A.8
! intended only for non-scattering calculations in the GSSAN3A.9
! infra-red. In this case, the fluxes can be calculated as GSSAN3A.10
! a weighted sum of two-stream fluxes where the diffusivity GSSAN3A.11
! factors for the two-stream approximations are determined GSSAN3A.12
! from the Gaussian points. GSSAN3A.13
! GSSAN3A.14
! Current Owner of Code: J. M. Edwards GSSAN3A.15
! GSSAN3A.16
! History: GSSAN3A.17
! Version Date Comment GSSAN3A.18
! 4.0 27-07-95 Original Code GSSAN3A.19
! (J. M. Edwards) GSSAN3A.20
! GSSAN3A.21
! Description of Code: GSSAN3A.22
! FORTRAN 77 with extensions listed in documentation. GSSAN3A.23
! GSSAN3A.24
!- --------------------------------------------------------------------- GSSAN3A.25
SUBROUTINE GAUSS_ANGLE(N_PROFILE, N_LAYER, L_NET, N_AUGMENT 1,2GSSAN3A.26
& , N_ORDER_GAUSS GSSAN3A.27
& , TAU GSSAN3A.28
& , FLUX_INC_DOWN GSSAN3A.29
& , DIFF_PLANCK, SOURCE_GROUND, ALBEDO_SURFACE_DIFF GSSAN3A.30
& , FLUX_DIFFUSE GSSAN3A.31
& , L_IR_SOURCE_QUAD, DIFF_PLANCK_2 GSSAN3A.32
& , NPD_PROFILE, NPD_LAYER GSSAN3A.33
& ) GSSAN3A.34
! GSSAN3A.35
! GSSAN3A.36
IMPLICIT NONE GSSAN3A.37
! GSSAN3A.38
! GSSAN3A.39
! SIZES OF DUMMY ARRAYS. GSSAN3A.40
INTEGER !, INTENT(IN) GSSAN3A.41
& NPD_PROFILE GSSAN3A.42
! MAXIMUM NUMBER OF PROFILES GSSAN3A.43
& , NPD_LAYER GSSAN3A.44
! MAXIMUM NUMBER OF LAYERS GSSAN3A.45
! GSSAN3A.46
! INCLUDE COMDECKS. GSSAN3A.47
*CALL SPCRG3A 
GSSAN3A.48
*CALL GSSWTP3A GSSAN3A.49
*CALL C_PI GSSAN3A.50
! GSSAN3A.51
! DUMMY VARIABLES. GSSAN3A.52
INTEGER !, INTENT(IN) GSSAN3A.53
& N_PROFILE GSSAN3A.54
! NUMBER OF PROFILES GSSAN3A.55
& , N_LAYER GSSAN3A.56
! NUMBER OF LAYERS GSSAN3A.57
& , N_AUGMENT GSSAN3A.58
! SIZE OF ARRAY TO INCREMENT GSSAN3A.59
& , N_ORDER_GAUSS GSSAN3A.60
! ORDER OF GAUSSIAN INTEGRATION GSSAN3A.61
LOGICAL !, INTENT(IN) GSSAN3A.62
& L_NET GSSAN3A.63
! NET FLUXES REQUIRED GSSAN3A.64
& , L_IR_SOURCE_QUAD GSSAN3A.65
! USE QUADRATIC SOURCE TERM GSSAN3A.66
REAL !, INTENT(IN) GSSAN3A.67
& TAU(NPD_PROFILE, NPD_LAYER) GSSAN3A.68
! OPTICAL DEPTH GSSAN3A.69
& , ALBEDO_SURFACE_DIFF(NPD_PROFILE) GSSAN3A.70
! DIFFUSE ALBEDO GSSAN3A.71
& , FLUX_INC_DOWN(NPD_PROFILE) GSSAN3A.72
! INCIDENT TOTAL FLUX GSSAN3A.73
& , DIFF_PLANCK(NPD_PROFILE, NPD_LAYER) GSSAN3A.74
! DIFFERENCE IN PI*PLANCK FUNCTION GSSAN3A.75
& , SOURCE_GROUND(NPD_PROFILE) GSSAN3A.76
! GROUND SOURCE FUNCTION GSSAN3A.77
& , DIFF_PLANCK_2(NPD_PROFILE, NPD_LAYER) GSSAN3A.78
! 2x2ND DIFFERENCES OF PLANCKIAN GSSAN3A.79
REAL !, INTENT(OUT) GSSAN3A.80
& FLUX_DIFFUSE(NPD_PROFILE, 2*NPD_LAYER+2) GSSAN3A.81
! DIFFUSE FLUXES GSSAN3A.82
! GSSAN3A.83
! LOCAL VARIABALES. GSSAN3A.84
INTEGER GSSAN3A.85
& I GSSAN3A.86
! LOOP VARIABLE GSSAN3A.87
& , L GSSAN3A.88
! LOOP VARIABLE GSSAN3A.89
& , K GSSAN3A.90
! LOOP VARIABLE GSSAN3A.91
REAL GSSAN3A.92
& FLUX_STREAM(NPD_PROFILE, 2*NPD_LAYER+2) GSSAN3A.93
! FLUX IN STREAM GSSAN3A.94
& , FLUX_NULL(NPD_PROFILE, 2*NPD_LAYER+2) GSSAN3A.95
! ARRAY OF NULL FLUXES GSSAN3A.96
& , SECANT_RAY GSSAN3A.97
! SECANT OF ANGLE WITH VERTICAL GSSAN3A.98
& , DIFF_PLANCK_RAD(NPD_PROFILE, NPD_LAYER) GSSAN3A.99
! DIFFERENCE IN PI*PLANCK FUNCTION GSSAN3A.100
& , DIFF_PLANCK_RAD_2(NPD_PROFILE, NPD_LAYER) GSSAN3A.101
! 2x2ND DIFFERENCES OF PLANCKIAN GSSAN3A.102
& , SOURCE_GROUND_RAD(NPD_PROFILE) GSSAN3A.103
! GROUND SOURCE FUNCTION GSSAN3A.104
& , RADIANCE_INC(NPD_PROFILE) GSSAN3A.105
! INCIDNET RADIANCE GSSAN3A.106
& , WEIGHT_STREAM GSSAN3A.107
! WEIGHTING FOR STREAM GSSAN3A.108
! GSSAN3A.109
! SET THE GAUSSIAN WEIGHTS FOR INTEGRATION. GSSAN3A.110
*CALL GSSWTD3A GSSAN3A.111
! GSSAN3A.112
! SUBROUTINES CALLED: GSSAN3A.113
EXTERNAL GSSAN3A.114
& MONOCHROMATIC_IR_RADIANCE, AUGMENT_FLUX GSSAN3A.115
! GSSAN3A.116
! GSSAN3A.117
! GSSAN3A.118
! SET THE SOURCE FUNCTION. GSSAN3A.119
DO L=1, N_PROFILE GSSAN3A.120
SOURCE_GROUND_RAD(L)=SOURCE_GROUND(L)/PI GSSAN3A.121
RADIANCE_INC(L)=FLUX_INC_DOWN(L)/PI GSSAN3A.122
ENDDO GSSAN3A.123
DO I=1, N_LAYER GSSAN3A.124
DO L=1, N_PROFILE GSSAN3A.125
DIFF_PLANCK_RAD(L, I)=DIFF_PLANCK(L, I)/PI GSSAN3A.126
ENDDO GSSAN3A.127
ENDDO GSSAN3A.128
DO I=1, 2*N_LAYER+2 GSSAN3A.129
DO L=1, N_PROFILE GSSAN3A.130
FLUX_DIFFUSE(L, I)=0.0 GSSAN3A.131
ENDDO GSSAN3A.132
ENDDO GSSAN3A.133
IF (L_IR_SOURCE_QUAD) THEN GSSAN3A.134
DO I=1, N_LAYER GSSAN3A.135
DO L=1, N_PROFILE GSSAN3A.136
DIFF_PLANCK_RAD_2(L, I)=DIFF_PLANCK_2(L, I)/PI GSSAN3A.137
ENDDO GSSAN3A.138
ENDDO GSSAN3A.139
ENDIF GSSAN3A.140
! GSSAN3A.141
! CALCULATE THE FLUXES WITH A NUMBER OF DIFFUSIVITY FACTORS GSSAN3A.142
! AND SUM THE RESULTS. GSSAN3A.143
DO K=1, N_ORDER_GAUSS GSSAN3A.144
SECANT_RAY=2.0E+00/(GAUSS_POINT(K, N_ORDER_GAUSS)+1.0E+00) GSSAN3A.145
! GSSAN3A.146
! CALCULATE THE RADIANCE AT THIS ANGLE. GSSAN3A.147
CALL MONOCHROMATIC_IR_RADIANCE(N_PROFILE, N_LAYER GSSAN3A.148
& , L_NET GSSAN3A.149
& , TAU GSSAN3A.150
& , RADIANCE_INC GSSAN3A.151
& , DIFF_PLANCK_RAD, SOURCE_GROUND_RAD, ALBEDO_SURFACE_DIFF GSSAN3A.152
& , SECANT_RAY GSSAN3A.153
& , FLUX_STREAM GSSAN3A.154
& , NPD_PROFILE, NPD_LAYER GSSAN3A.155
& ) GSSAN3A.156
! GSSAN3A.157
! AUGMENT THE FLUX BY THE AMOUNT IN THIS STREAM. GSSAN3A.158
WEIGHT_STREAM=5.0E-01*PI*GAUSS_WEIGHT(K, N_ORDER_GAUSS) GSSAN3A.159
& *(GAUSS_POINT(K, N_ORDER_GAUSS)+1.0E+00) GSSAN3A.160
CALL AUGMENT_FLUX(N_PROFILE, N_LAYER, N_AUGMENT GSSAN3A.161
& , IP_INFRA_RED, .FALSE. GSSAN3A.162
& , WEIGHT_STREAM GSSAN3A.163
& , FLUX_NULL, FLUX_DIFFUSE GSSAN3A.164
& , FLUX_NULL, FLUX_STREAM GSSAN3A.165
& , FLUX_NULL, FLUX_NULL GSSAN3A.166
& , FLUX_NULL, FLUX_NULL GSSAN3A.167
& , NPD_PROFILE, NPD_LAYER GSSAN3A.168
& ) GSSAN3A.169
! GSSAN3A.170
ENDDO GSSAN3A.171
! GSSAN3A.172
! GSSAN3A.173
RETURN GSSAN3A.174
END GSSAN3A.175
*ENDIF DEF,A01_3A,OR,DEF,A02_3A GSSAN3A.176
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.34