/[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/libf/phylmd/Radlwsw/lwttm.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/Sources/phylmd/Radlwsw/lwttm.f revision 134 by guez, Wed Apr 29 15:47:56 2015 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        REAL*8 O1H, O2H    DOUBLE PRECISION o1h, o2h
40        PARAMETER (O1H=2230.)    PARAMETER (o1h=2230.)
41        PARAMETER (O2H=100.)    PARAMETER (o2h=100.)
42        REAL*8 RPIALF0    DOUBLE PRECISION rpialf0
43        PARAMETER (RPIALF0=2.0)    PARAMETER (rpialf0=2.0)
44  C  
45  C* ARGUMENTS:    ! * ARGUMENTS:
46  C  
47        REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS    DOUBLE PRECISION pga(kdlon, 8, 2) ! PADE APPROXIMANTS
48        REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS    DOUBLE PRECISION pgb(kdlon, 8, 2) ! PADE APPROXIMANTS
49        REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1    DOUBLE PRECISION puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
50        REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2    DOUBLE PRECISION puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
51        REAL*8 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        REAL*8 zz, zxd, zxn    DOUBLE PRECISION zz, zxd, zxn
57        REAL*8 zpu, zpu10, zpu11, zpu12, zpu13    DOUBLE PRECISION zpu, zpu10, zpu11, zpu12, zpu13
58        REAL*8 zeu, zeu10, zeu11, zeu12, zeu13    DOUBLE PRECISION zeu, zeu10, zeu11, zeu12, zeu13
59        REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2    DOUBLE PRECISION zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1
60        REAL*8 zxch4, zych4, zsqh41, zodh41    DOUBLE PRECISION zto2
61        REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42    DOUBLE PRECISION zxch4, zych4, zsqh41, zodh41
62        REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12    DOUBLE PRECISION zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
63        REAL*8 zuu11, zuu12    DOUBLE PRECISION zsqn22, zodn22, za11, zttf11, za12, zttf12
64  C     ------------------------------------------------------------------    DOUBLE PRECISION zuu11, zuu12
65  C    ! ------------------------------------------------------------------
66  C*         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION  
67  C                 -----------------------------------------------    ! *         1.     HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
68  C    ! -----------------------------------------------
69   100  CONTINUE  
70  C  
71  C  
72        DO 130 JA = 1 , 8    DO ja = 1, 8
73        DO 120 JL = 1, KDLON      DO jl = 1, kdlon
74        ZZ      =SQRT(PUU1(JL,JA) - PUU2(JL,JA))        zz = sqrt(puu1(jl,ja)-puu2(jl,ja))
75        ZXD      =PGB( JL,JA,1) + ZZ       *(PGB( JL,JA,2) + ZZ       )        zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
76        ZXN      =PGA( JL,JA,1) + ZZ       *(PGA( JL,JA,2) )        zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
77        PTT(JL,JA)=ZXN      /ZXD        ptt(jl, ja) = zxn/zxd
78    120 CONTINUE      END DO
79    130 CONTINUE    END DO
80  C  
81  C     ------------------------------------------------------------------    ! ------------------------------------------------------------------
82  C  
83  C*         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS    ! *         2.     CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
84  C                 ---------------------------------------------------    ! ---------------------------------------------------
85  C  
86   200  CONTINUE  
87  C    DO jl = 1, kdlon
88        DO 201 JL = 1, KDLON      ptt(jl, 9) = ptt(jl, 8)
89        PTT(JL, 9) = PTT(JL, 8)  
90  C      ! -  CONTINUUM ABSORPTION: E- AND P-TYPE
91  C-  CONTINUUM ABSORPTION: E- AND P-TYPE  
92  C      zpu = 0.002*(puu1(jl,10)-puu2(jl,10))
93        ZPU   = 0.002 * (PUU1(JL,10) - PUU2(JL,10))      zpu10 = 112.*zpu
94        ZPU10 = 112. * ZPU      zpu11 = 6.25*zpu
95        ZPU11 = 6.25 * ZPU      zpu12 = 5.00*zpu
96        ZPU12 = 5.00 * ZPU      zpu13 = 80.0*zpu
97        ZPU13 = 80.0 * ZPU      zeu = (puu1(jl,11)-puu2(jl,11))
98        ZEU   = (PUU1(JL,11) - PUU2(JL,11))      zeu10 = 12.*zeu
99        ZEU10 =  12. * ZEU      zeu11 = 6.25*zeu
100        ZEU11 = 6.25 * ZEU      zeu12 = 5.00*zeu
101        ZEU12 = 5.00 * ZEU      zeu13 = 80.0*zeu
102        ZEU13 = 80.0 * ZEU  
103  C      ! -  OZONE ABSORPTION
104  C-  OZONE ABSORPTION  
105  C      zx = (puu1(jl,12)-puu2(jl,12))
106        ZX = (PUU1(JL,12) - PUU2(JL,12))      zy = (puu1(jl,13)-puu2(jl,13))
107        ZY = (PUU1(JL,13) - PUU2(JL,13))      zuxy = 4.*zx*zx/(rpialf0*zy)
108        ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)      zsq1 = sqrt(1.+o1h*zuxy) - 1.
109        ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.      zsq2 = sqrt(1.+o2h*zuxy) - 1.
110        ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.      zvxy = rpialf0*zy/(2.*zx)
111        ZVXY = RPIALF0 * ZY / (2. * ZX)      zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12
112        ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12      zto1 = exp(-zvxy*zsq1-zaercn)
113        ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )      zto2 = exp(-zvxy*zsq2-zaercn)
114        ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )  
115  C      ! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
116  C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)  
117  C      ! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
118  C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1  
119  C      zxch4 = (puu1(jl,19)-puu2(jl,19))
120        ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))      zych4 = (puu1(jl,20)-puu2(jl,20))
121        ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))      zuxy = 4.*zxch4*zxch4/(0.103*zych4)
122        ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)      zsqh41 = sqrt(1.+33.7*zuxy) - 1.
123        ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.      zvxy = 0.103*zych4/(2.*zxch4)
124        ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)      zodh41 = zvxy*zsqh41
125        ZODH41 = ZVXY * ZSQH41  
126  C      ! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
127  C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1  
128  C      zxn2o = (puu1(jl,21)-puu2(jl,21))
129        ZXN2O = (PUU1(JL,21) - PUU2(JL,21))      zyn2o = (puu1(jl,22)-puu2(jl,22))
130        ZYN2O = (PUU1(JL,22) - PUU2(JL,22))      zuxy = 4.*zxn2o*zxn2o/(0.416*zyn2o)
131        ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)      zsqn21 = sqrt(1.+21.3*zuxy) - 1.
132        ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.      zvxy = 0.416*zyn2o/(2.*zxn2o)
133        ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)      zodn21 = zvxy*zsqn21
134        ZODN21 = ZVXY * ZSQN21  
135  C      ! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
136  C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1  
137  C      zuxy = 4.*zxch4*zxch4/(0.113*zych4)
138        ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)      zsqh42 = sqrt(1.+400.*zuxy) - 1.
139        ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.      zvxy = 0.113*zych4/(2.*zxch4)
140        ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)      zodh42 = zvxy*zsqh42
141        ZODH42 = ZVXY * ZSQH42  
142  C      ! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
143  C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1  
144  C      zuxy = 4.*zxn2o*zxn2o/(0.197*zyn2o)
145        ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)      zsqn22 = sqrt(1.+2000.*zuxy) - 1.
146        ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.      zvxy = 0.197*zyn2o/(2.*zxn2o)
147        ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)      zodn22 = zvxy*zsqn22
148        ZODN22 = ZVXY * ZSQN22  
149  C      ! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
150  C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1  
151  C      za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05
152        ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05      zttf11 = 1. - za11*0.003225
153        ZTTF11 = 1. - ZA11 * 0.003225  
154  C      ! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
155  C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1  
156  C      za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05
157        ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05      zttf12 = 1. - za12*0.003225
158        ZTTF12 = 1. - ZA12 * 0.003225  
159  C      zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10
160        ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10      zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21
161        ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -      ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14)))
162       S         ZODH41 - ZODN21      ptt(jl, 11) = exp(zuu11)
163        PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )      ptt(jl, 12) = exp(zuu12)*zttf11*zttf12
164        PTT(JL,11) = EXP( ZUU11 )      ptt(jl, 13) = 0.7554*zto1 + 0.2446*zto2
165        PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12      ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
166        PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2      ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22)
167        PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )    END DO
168        PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )  
169   201  CONTINUE    RETURN
170  C  END SUBROUTINE lwttm
       RETURN  
       END  
Legend:
Removed from v.24  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.21