/[lmdze]/trunk/phylmd/Radlwsw/swtt.f
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/swtt.f

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

trunk/libf/phylmd/Radlwsw/swtt.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/phylmd/Radlwsw/swtt.f revision 265 by guez, Tue Mar 20 09:35:59 2018 UTC
# Line 1  Line 1 
1        SUBROUTINE SWTT (KNU,KA,PU,PTR)  SUBROUTINE swtt(knu, ka, pu, ptr)
2        use dimens_m    USE dimensions
3        use dimphy    USE dimphy
4        use raddim    USE raddim
5        IMPLICIT none    IMPLICIT NONE
6  C  
7  C-----------------------------------------------------------------------    ! -----------------------------------------------------------------------
8  C     PURPOSE.    ! PURPOSE.
9  C     --------    ! --------
10  C           THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE    ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
11  C     ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL    ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
12  C     INTERVALS.    ! INTERVALS.
13  C  
14  C     METHOD.    ! METHOD.
15  C     -------    ! -------
16  C  
17  C          TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS    ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
18  C     AND HORNER'S ALGORITHM.    ! AND HORNER'S ALGORITHM.
19  C  
20  C     REFERENCE.    ! REFERENCE.
21  C     ----------    ! ----------
22  C  
23  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND    ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
24  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS    ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
25  C  
26  C     AUTHOR.    ! AUTHOR.
27  C     -------    ! -------
28  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! JEAN-JACQUES MORCRETTE  *ECMWF*
29  C  
30  C     MODIFICATIONS.    ! MODIFICATIONS.
31  C     --------------    ! --------------
32  C        ORIGINAL : 88-12-15    ! ORIGINAL : 88-12-15
33  C-----------------------------------------------------------------------    ! -----------------------------------------------------------------------
34  C  
35  C* ARGUMENTS    ! * ARGUMENTS
36  C  
37        INTEGER KNU     ! INDEX OF THE SPECTRAL INTERVAL    INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
38        INTEGER KA      ! INDEX OF THE ABSORBER    INTEGER ka ! INDEX OF THE ABSORBER
39        REAL*8 PU(KDLON)  ! ABSORBER AMOUNT    DOUBLE PRECISION pu(kdlon) ! ABSORBER AMOUNT
40  C  
41        REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION    DOUBLE PRECISION ptr(kdlon) ! TRANSMISSION FUNCTION
42  C  
43  C* LOCAL VARIABLES:    ! * LOCAL VARIABLES:
44  C  
45        REAL*8 ZR1(KDLON), ZR2(KDLON)    DOUBLE PRECISION zr1(kdlon), zr2(kdlon)
46        INTEGER jl, i,j    INTEGER jl, i, j
47  C  
48  C* Prescribed Data:    ! * Prescribed Data:
49  C  
50        REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)    DOUBLE PRECISION apad(2, 3, 7), bpad(2, 3, 7), d(2, 3)
51        SAVE APAD, BPAD, D    SAVE apad, bpad, d
52        DATA ((APAD(1,I,J),I=1,3),J=1,7) /    DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292D+05, 0.000000000D-00, &
53       S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,      0.925887084D-04, 0.723613782D+05, 0.000000000D-00, 0.129353723D-01, &
54       S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,      0.596037057D+04, 0.000000000D-00, 0.800821928D+00, 0.000000000D-00, &
55       S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,      0.000000000D-00, 0.242715973D+02, 0.000000000D-00, 0.000000000D-00, &
56       S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,      0.878331486D+02, 0.000000000D-00, 0.000000000D-00, 0.191559725D+02, &
57       S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,      0.000000000D-00, 0.000000000D-00, 0.000000000D+00/
58       S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,    DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383D-08, 0.739646016D-08, &
59       S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /      0.410177786D+03, 0.978576773D-04, 0.131849595D-03, 0.672595424D+02, &
60        DATA ((APAD(2,I,J),I=1,3),J=1,7) /      0.387714006D+00, 0.437772681D+00, 0.000000000D-00, 0.118461660D+03, &
61       S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,      0.151345118D+03, 0.000000000D-00, 0.119079797D+04, 0.233628890D+04, &
62       S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,      0.000000000D-00, 0.293353397D+03, 0.797219934D+03, 0.000000000D-00, &
63       S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,      0.000000000D+00, 0.000000000D+00, 0.000000000D+00/
64       S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,  
65       S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,    DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292D+05, 0.000000000D-00, &
66       S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,      0.925887084D-04, 0.724555318D+05, 0.000000000D-00, 0.131812683D-01, &
67       S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /      0.602593328D+04, 0.000000000D-00, 0.812706117D+00, 0.100000000D+01, &
68  C      0.000000000D-00, 0.249863591D+02, 0.000000000D-00, 0.000000000D-00, &
69        DATA ((BPAD(1,I,J),I=1,3),J=1,7) /      0.931071925D+02, 0.000000000D-00, 0.000000000D-00, 0.252233437D+02, &
70       S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,      0.000000000D-00, 0.000000000D-00, 0.100000000D+01/
71       S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,    DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383D-08, 0.739646016D-08, &
72       S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,      0.410177786D+03, 0.979023421D-04, 0.131861712D-03, 0.731185438D+02, &
73       S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,      0.388611139D+00, 0.437949001D+00, 0.100000000D+01, 0.120291383D+03, &
74       S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,      0.151692730D+03, 0.000000000D+00, 0.130531005D+04, 0.237071130D+04, &
75       S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,      0.000000000D+00, 0.415049409D+03, 0.867914360D+03, 0.000000000D+00, &
76       S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /      0.100000000D+01, 0.100000000D+01, 0.000000000D+00/
77        DATA ((BPAD(2,I,J),I=1,3),J=1,7) /  
78       S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,    DATA (d(1,i), i=1, 3)/0.00d0, 0.00d0, 0.00d0/
79       S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,    DATA (d(2,i), i=1, 3)/0.000000000d0, 0.000000000d0, 0.800000000d0/
80       S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,  
81       S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,    ! -----------------------------------------------------------------------
82       S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,  
83       S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,    ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
84       S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /  
85  c  
86        DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /    DO jl = 1, kdlon
87        DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /      zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, &
88  C        3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
89  C-----------------------------------------------------------------------        +pu(jl)*(apad(knu,ka,7)))))))
90  C  
91  C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION      zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, &
92  C        3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
93   100  CONTINUE        +pu(jl)*(bpad(knu,ka,7)))))))
94  C  
95        DO 201 JL = 1, KDLON  
96        ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)      ! *         2.      ADD THE BACKGROUND TRANSMISSION
97       S      * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)  
98       S      * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)  
99       S      * ( APAD(KNU,KA,7) ))))))  
100  C      ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
101        ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)    END DO
102       S      * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)  
103       S      * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)    RETURN
104       S      * ( BPAD(KNU,KA,7) ))))))  END SUBROUTINE swtt
 C      
 C  
 C*         2.      ADD THE BACKGROUND TRANSMISSION  
 C  
  200  CONTINUE  
 C  
 C  
       PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)  
  201  CONTINUE  
 C  
       RETURN  
       END  
Legend:
Removed from v.24  
changed lines
  Added in v.265
  ViewVC Help
Powered by ViewVC 1.1.21