/[lmdze]/trunk/Sources/phylmd/Radlwsw/lwttm.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/lwttm.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/phylmd/Radlwsw/lwttm.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/phylmd/Radlwsw/lwttm.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)  SUBROUTINE lwttm(pga, pgb, puu1, puu2, ptt)
2        use dimens_m    USE dimens_m
3        use dimphy    USE dimphy
4        use raddim    USE raddim
5              use raddimlw    USE raddimlw
6        IMPLICIT none    IMPLICIT NONE
7  C  
8  C     ------------------------------------------------------------------    ! ------------------------------------------------------------------
9  C     PURPOSE.    ! PURPOSE.
10  C     --------    ! --------
11  C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE    ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
12  C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL    ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
13  C     INTERVALS.    ! INTERVALS.
14  C  
15  C     METHOD.    ! METHOD.
16  C     -------    ! -------
17  C  
18  C          1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE    ! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
19  C     COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.    ! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
20  C          2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.    ! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
21  C          3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN    ! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
22  C     A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.    ! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
23  C  
24  C     REFERENCE.    ! REFERENCE.
25  C     ----------    ! ----------
26  C  
27  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND    ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS    ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29  C  
30  C     AUTHOR.    ! AUTHOR.
31  C     -------    ! -------
32  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! JEAN-JACQUES MORCRETTE  *ECMWF*
33  C  
34  C     MODIFICATIONS.    ! MODIFICATIONS.
35  C     --------------    ! --------------
36  C        ORIGINAL : 88-12-15    ! ORIGINAL : 88-12-15
37  C  
38  C-----------------------------------------------------------------------    ! -----------------------------------------------------------------------
39        DOUBLE PRECISION O1H, O2H    DOUBLE PRECISION o1h, o2h
40        PARAMETER (O1H=2230.)    PARAMETER (o1h=2230.)
41        PARAMETER (O2H=100.)    PARAMETER (o2h=100.)
42        DOUBLE PRECISION RPIALF0    DOUBLE PRECISION rpialf0
43        PARAMETER (RPIALF0=2.0)    PARAMETER (rpialf0=2.0)
44  C  
45  C* ARGUMENTS:    ! * ARGUMENTS:
46  C  
47        DOUBLE PRECISION PGA(KDLON,8,2) ! PADE APPROXIMANTS    DOUBLE PRECISION pga(kdlon, 8, 2) ! PADE APPROXIMANTS
48        DOUBLE PRECISION PGB(KDLON,8,2) ! PADE APPROXIMANTS    DOUBLE PRECISION pgb(kdlon, 8, 2) ! PADE APPROXIMANTS
49        DOUBLE PRECISION PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1    DOUBLE PRECISION puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
50        DOUBLE PRECISION PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2    DOUBLE PRECISION puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
51        DOUBLE PRECISION PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS    DOUBLE PRECISION ptt(kdlon, ntra) ! TRANSMISSION FUNCTIONS
52  C  
53  C* LOCAL VARIABLES:    ! * LOCAL VARIABLES:
54  C  
55        INTEGER ja, jl    INTEGER ja, jl
56        DOUBLE PRECISION zz, zxd, zxn    DOUBLE PRECISION zz, zxd, zxn
57        DOUBLE PRECISION zpu, zpu10, zpu11, zpu12, zpu13    DOUBLE PRECISION zpu, zpu10, zpu11, zpu12, zpu13
58        DOUBLE PRECISION zeu, zeu10, zeu11, zeu12, zeu13    DOUBLE PRECISION zeu, zeu10, zeu11, zeu12, zeu13
59        DOUBLE PRECISION zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1    DOUBLE PRECISION zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1
60        DOUBLE PRECISION zto2    DOUBLE PRECISION zto2
61        DOUBLE PRECISION zxch4, zych4, zsqh41, zodh41    DOUBLE PRECISION zxch4, zych4, zsqh41, zodh41
62        DOUBLE PRECISION zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42    DOUBLE PRECISION zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
63        DOUBLE PRECISION zsqn22, zodn22, za11, zttf11, za12, zttf12    DOUBLE PRECISION zsqn22, zodn22, za11, zttf11, za12, zttf12
64        DOUBLE PRECISION zuu11, zuu12    DOUBLE PRECISION zuu11, zuu12
65  C     ------------------------------------------------------------------    ! ------------------------------------------------------------------
66  C  
67  C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION    ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
68  C                 -----------------------------------------------    ! -----------------------------------------------
69  C  
70   100  CONTINUE  
71  C  
72  C    DO ja = 1, 8
73        DO 130 JA = 1 , 8      DO jl = 1, kdlon
74        DO 120 JL = 1, KDLON        zz = sqrt(puu1(jl,ja)-puu2(jl,ja))
75        ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))        zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
76        ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )        zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
77        ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )        ptt(jl, ja) = zxn/zxd
78        PTT(JL,JA)=ZXN      /ZXD      END DO
79    120 CONTINUE    END DO
80    130 CONTINUE  
81  C    ! ------------------------------------------------------------------
82  C     ------------------------------------------------------------------  
83  C    ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
84  C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS    ! ---------------------------------------------------
85  C                 ---------------------------------------------------  
86  C  
87   200  CONTINUE    DO jl = 1, kdlon
88  C      ptt(jl, 9) = ptt(jl, 8)
89        DO 201 JL = 1, KDLON  
90        PTT(JL, 9) = PTT(JL, 8)      ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
91  C  
92  C-  CONTINUUM ABSORPTION: E- AND P-TYPE      zpu = 0.002*(puu1(jl,10)-puu2(jl,10))
93  C      zpu10 = 112.*zpu
94        ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))      zpu11 = 6.25*zpu
95        ZPU10 = 112. * ZPU      zpu12 = 5.00*zpu
96        ZPU11 = 6.25 * ZPU      zpu13 = 80.0*zpu
97        ZPU12 = 5.00 * ZPU      zeu = (puu1(jl,11)-puu2(jl,11))
98        ZPU13 = 80.0 * ZPU      zeu10 = 12.*zeu
99        ZEU   = (PUU1(JL,11) - PUU2(JL,11))      zeu11 = 6.25*zeu
100        ZEU10 =  12. * ZEU      zeu12 = 5.00*zeu
101        ZEU11 = 6.25 * ZEU      zeu13 = 80.0*zeu
102        ZEU12 = 5.00 * ZEU  
103        ZEU13 = 80.0 * ZEU      ! -  OZONE ABSORPTION
104  C  
105  C-  OZONE ABSORPTION      zx = (puu1(jl,12)-puu2(jl,12))
106  C      zy = (puu1(jl,13)-puu2(jl,13))
107        ZX = (PUU1(JL,12) - PUU2(JL,12))      zuxy = 4.*zx*zx/(rpialf0*zy)
108        ZY = (PUU1(JL,13) - PUU2(JL,13))      zsq1 = sqrt(1.+o1h*zuxy) - 1.
109        ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)      zsq2 = sqrt(1.+o2h*zuxy) - 1.
110        ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.      zvxy = rpialf0*zy/(2.*zx)
111        ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.      zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12
112        ZVXY = RPIALF0 * ZY / (2. * ZX)      zto1 = exp(-zvxy*zsq1-zaercn)
113        ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12      zto2 = exp(-zvxy*zsq2-zaercn)
114        ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )  
115        ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )      ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
116  C  
117  C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)      ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
118  C  
119  C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1      zxch4 = (puu1(jl,19)-puu2(jl,19))
120  C      zych4 = (puu1(jl,20)-puu2(jl,20))
121        ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))      zuxy = 4.*zxch4*zxch4/(0.103*zych4)
122        ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))      zsqh41 = sqrt(1.+33.7*zuxy) - 1.
123        ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)      zvxy = 0.103*zych4/(2.*zxch4)
124        ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.      zodh41 = zvxy*zsqh41
125        ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)  
126        ZODH41 = ZVXY * ZSQH41      ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
127  C  
128  C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1      zxn2o = (puu1(jl,21)-puu2(jl,21))
129  C      zyn2o = (puu1(jl,22)-puu2(jl,22))
130        ZXN2O = (PUU1(JL,21) - PUU2(JL,21))      zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
131        ZYN2O = (PUU1(JL,22) - PUU2(JL,22))      zsqn21 = sqrt(1.+21.3*zuxy) - 1.
132        ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)      zvxy = 0.416*zyn2o/(2.*zxn2o)
133        ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.      zodn21 = zvxy*zsqn21
134        ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)  
135        ZODN21 = ZVXY * ZSQN21      ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
136  C  
137  C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1      zuxy = 4.*zxch4*zxch4/(0.113*zych4)
138  C      zsqh42 = sqrt(1.+400.*zuxy) - 1.
139        ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)      zvxy = 0.113*zych4/(2.*zxch4)
140        ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.      zodh42 = zvxy*zsqh42
141        ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)  
142        ZODH42 = ZVXY * ZSQH42      ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
143  C  
144  C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1      zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
145  C      zsqn22 = sqrt(1.+2000.*zuxy) - 1.
146        ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)      zvxy = 0.197*zyn2o/(2.*zxn2o)
147        ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.      zodn22 = zvxy*zsqn22
148        ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)  
149        ZODN22 = ZVXY * ZSQN22      ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
150  C  
151  C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1      za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05
152  C      zttf11 = 1. - za11*0.003225
153        ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05  
154        ZTTF11 = 1. - ZA11 * 0.003225      ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
155  C  
156  C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1      za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05
157  C      zttf12 = 1. - za12*0.003225
158        ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05  
159        ZTTF12 = 1. - ZA12 * 0.003225      zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10
160  C      zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21
161        ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10      ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14)))
162        ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -      ptt(jl, 11) = exp(zuu11)
163       S         ZODH41 - ZODN21      ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
164        PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )      ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
165        PTT(JL,11) = EXP( ZUU11 )      ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
166        PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12      ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22)
167        PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2    END DO
168        PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )  
169        PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )    RETURN
170   201  CONTINUE  END SUBROUTINE lwttm
 C  
       RETURN  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21