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

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

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

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