*IF DEF,A70_1A,OR,DEF,A70_1B APB4F405.29
*IF DEF,A01_3A,OR,DEF,A02_3A GASOP3A.2
C (c) CROWN COPYRIGHT 1995, METEOROLOGICAL OFFICE, All Rights Reserved. GTS2F400.13297
C GTS2F400.13298
C Use, duplication or disclosure of this code is subject to the GTS2F400.13299
C restrictions as set forth in the contract. GTS2F400.13300
C GTS2F400.13301
C Meteorological Office GTS2F400.13302
C London Road GTS2F400.13303
C BRACKNELL GTS2F400.13304
C Berkshire UK GTS2F400.13305
C RG12 2SZ GTS2F400.13306
C GTS2F400.13307
C If no contract has been raised with this copy of the code, the use, GTS2F400.13308
C duplication or disclosure of it is strictly prohibited. Permission GTS2F400.13309
C to do so must first be obtained in writing from the Head of Numerical GTS2F400.13310
C Modelling at the above address. GTS2F400.13311
C ******************************COPYRIGHT****************************** GTS2F400.13312
C GTS2F400.13313
!+ Subroutine to calculate the absorptive extinctions of gases. GASOP3A.3
! GASOP3A.4
! Method: GASOP3A.5
! Straightforward. GASOP3A.6
! GASOP3A.7
! Current Owner of Code: J. M. Edwards GASOP3A.8
! GASOP3A.9
! History: GASOP3A.10
! Version Date Comment GASOP3A.11
! 4.0 27-07-95 Original Code GASOP3A.12
! (J. M. Edwards) GASOP3A.13
! GASOP3A.14
! Description of Code: GASOP3A.15
! FORTRAN 77 with extensions listed in documentation. GASOP3A.16
! GASOP3A.17
!- --------------------------------------------------------------------- GASOP3A.18
SUBROUTINE GAS_OPTICAL_PROPERTIES(N_PROFILE, N_LAYER 5GASOP3A.19
& , N_GAS, I_GAS_POINTER, K_ESFT_MONO, GAS_MIX_RATIO GASOP3A.20
& , K_GAS_ABS GASOP3A.21
& , NPD_PROFILE, NPD_LAYER, NPD_SPECIES GASOP3A.22
& ) GASOP3A.23
! GASOP3A.24
! GASOP3A.25
IMPLICIT NONE GASOP3A.26
! GASOP3A.27
! GASOP3A.28
! SIZES OF DUMMY ARRAYS. GASOP3A.29
INTEGER !, INTENT(IN) GASOP3A.30
& NPD_PROFILE GASOP3A.31
! MAXIMUM NUMBER OF PROFILES GASOP3A.32
& , NPD_LAYER GASOP3A.33
! MAXIMUM NUMBER OF LAYERS GASOP3A.34
& , NPD_SPECIES GASOP3A.35
! MAXIMUM NUMBER OF GASEOUS SPECIES GASOP3A.36
! GASOP3A.37
! DUMMY VARIABLES. GASOP3A.38
INTEGER !, INTENT(IN) GASOP3A.39
& N_PROFILE GASOP3A.40
! NUMBER OF PROFILES GASOP3A.41
& , N_LAYER GASOP3A.42
! NUMBER OF LAYERS GASOP3A.43
& , N_GAS GASOP3A.44
! NUMBER OF GASES GASOP3A.45
& , I_GAS_POINTER(NPD_SPECIES) GASOP3A.46
! POINTERS TO ACTIVE GASES GASOP3A.47
REAL !, INTENT(IN) GASOP3A.48
& K_ESFT_MONO(NPD_SPECIES) GASOP3A.49
! ESFT EXPONENTS FOR EACH GAS GASOP3A.50
& , GAS_MIX_RATIO(NPD_PROFILE, 0: NPD_LAYER, NPD_SPECIES) GASOP3A.51
! GAS MIXING RATIOS GASOP3A.52
REAL !, INTENT(OUT) GASOP3A.53
& K_GAS_ABS(NPD_PROFILE, NPD_LAYER) GASOP3A.54
! CLEAR ABSORPTIVE EXTINCTION GASOP3A.55
! GASOP3A.56
! LOCAL VARIABLES. GASOP3A.57
INTEGER GASOP3A.58
& I_GAS GASOP3A.59
! TEMPORARY GAS INDEX GASOP3A.60
& , L GASOP3A.61
! LOOP VARIABLE GASOP3A.62
& , I GASOP3A.63
! LOOP VARIABLE GASOP3A.64
& , J GASOP3A.65
! LOOP VARIABLE GASOP3A.66
! GASOP3A.67
! GASOP3A.68
! CALCULATE THE ABSORPTION FOR THE FIRST GAS AND ADD ON THE REST. GASOP3A.69
I_GAS=I_GAS_POINTER(1) GASOP3A.70
DO J=1, N_LAYER GASOP3A.71
DO L=1, N_PROFILE GASOP3A.72
K_GAS_ABS(L, J) GASOP3A.73
& =K_ESFT_MONO(I_GAS)*GAS_MIX_RATIO(L, J, I_GAS) GASOP3A.74
ENDDO GASOP3A.75
ENDDO GASOP3A.76
DO I=2, N_GAS GASOP3A.77
I_GAS=I_GAS_POINTER(I) GASOP3A.78
DO J=1, N_LAYER GASOP3A.79
DO L=1, N_PROFILE GASOP3A.80
K_GAS_ABS(L, J)=K_GAS_ABS(L, J) GASOP3A.81
& +K_ESFT_MONO(I_GAS)*GAS_MIX_RATIO(L, J, I_GAS) GASOP3A.82
ENDDO GASOP3A.83
ENDDO GASOP3A.84
ENDDO GASOP3A.85
! GASOP3A.86
! GASOP3A.87
RETURN GASOP3A.88
END GASOP3A.89
*ENDIF DEF,A01_3A,OR,DEF,A02_3A GASOP3A.90
*ENDIF DEF,A70_1A,OR,DEF,A70_1B APB4F405.30