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

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

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

trunk/libf/phylmd/Radlwsw/swtt1.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/phylmd/Radlwsw/swtt1.f revision 82 by guez, Wed Mar 5 14:57:53 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)  SUBROUTINE swtt1(knu, kabs, kind, pu, ptr)
2        use dimens_m    USE dimens_m
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 : 95-01-20    ! ORIGINAL : 95-01-20
33  C-----------------------------------------------------------------------    ! -----------------------------------------------------------------------
34  C* ARGUMENTS:    ! * ARGUMENTS:
35  C  
36        INTEGER KNU          ! INDEX OF THE SPECTRAL INTERVAL    INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
37        INTEGER KABS         ! NUMBER OF ABSORBERS    INTEGER kabs ! NUMBER OF ABSORBERS
38        INTEGER KIND(KABS)   ! INDICES OF THE ABSORBERS    INTEGER kind(kabs) ! INDICES OF THE ABSORBERS
39        REAL*8 PU(KDLON,KABS)  ! ABSORBER AMOUNT    DOUBLE PRECISION pu(kdlon, kabs) ! ABSORBER AMOUNT
40  C  
41        REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION    DOUBLE PRECISION ptr(kdlon, kabs) ! TRANSMISSION FUNCTION
42  C  
43  C* LOCAL VARIABLES:    ! * LOCAL VARIABLES:
44  C  
45        REAL*8 ZR1(KDLON)    DOUBLE PRECISION zr1(kdlon)
46        REAL*8 ZR2(KDLON)    DOUBLE PRECISION zr2(kdlon)
47        REAL*8 ZU(KDLON)    DOUBLE PRECISION zu(kdlon)
48        INTEGER jl, ja, i, j, ia    INTEGER jl, ja, i, j, ia
49  C  
50  C* Prescribed Data:    ! * Prescribed Data:
51  C  
52        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)
53        SAVE APAD, BPAD, D    SAVE apad, bpad, d
54        DATA ((APAD(1,I,J),I=1,3),J=1,7) /    DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
55       S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,      0.925887084E-04, 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, &
56       S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,      0.596037057E+04, 0.000000000E-00, 0.800821928E+00, 0.000000000E-00, &
57       S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,      0.000000000E-00, 0.242715973E+02, 0.000000000E-00, 0.000000000E-00, &
58       S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,      0.878331486E+02, 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, &
59       S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,      0.000000000E-00, 0.000000000E-00, 0.000000000E+00/
60       S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,    DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
61       S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /      0.410177786E+03, 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, &
62        DATA ((APAD(2,I,J),I=1,3),J=1,7) /      0.387714006E+00, 0.437772681E+00, 0.000000000E-00, 0.118461660E+03, &
63       S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,      0.151345118E+03, 0.000000000E-00, 0.119079797E+04, 0.233628890E+04, &
64       S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,      0.000000000E-00, 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, &
65       S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,      0.000000000E+00, 0.000000000E+00, 0.000000000E+00/
66       S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,  
67       S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,    DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
68       S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,      0.925887084E-04, 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, &
69       S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /      0.602593328E+04, 0.000000000E-00, 0.812706117E+00, 0.100000000E+01, &
70  C      0.000000000E-00, 0.249863591E+02, 0.000000000E-00, 0.000000000E-00, &
71        DATA ((BPAD(1,I,J),I=1,3),J=1,7) /      0.931071925E+02, 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, &
72       S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,      0.000000000E-00, 0.000000000E-00, 0.100000000E+01/
73       S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,    DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
74       S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,      0.410177786E+03, 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, &
75       S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,      0.388611139E+00, 0.437949001E+00, 0.100000000E+01, 0.120291383E+03, &
76       S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,      0.151692730E+03, 0.000000000E+00, 0.130531005E+04, 0.237071130E+04, &
77       S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,      0.000000000E+00, 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, &
78       S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /      0.100000000E+01, 0.100000000E+01, 0.000000000E+00/
79        DATA ((BPAD(2,I,J),I=1,3),J=1,7) /  
80       S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,    DATA (d(1,i), i=1, 3)/0.00, 0.00, 0.00/
81       S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,    DATA (d(2,i), i=1, 3)/0.000000000, 0.000000000, 0.800000000/
82       S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,    ! -----------------------------------------------------------------------
83       S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,  
84       S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,    ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
85       S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,  
86       S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /  
87  c    DO ja = 1, kabs
88        DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /      ia = kind(ja)
89        DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /      DO jl = 1, kdlon
90  C-----------------------------------------------------------------------        zu(jl) = pu(jl, ja)
91  C        zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, &
92  C*         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION          ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, &
93  C          ia,6)+zu(jl)*(apad(knu,ia,7)))))))
94   100  CONTINUE  
95  C        zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, &
96        DO 202 JA = 1,KABS          ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, &
97        IA=KIND(JA)          ia,6)+zu(jl)*(bpad(knu,ia,7)))))))
98        DO 201 JL = 1, KDLON  
99        ZU(JL) = PU(JL,JA)  
100        ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)        ! *         2.      ADD THE BACKGROUND TRANSMISSION
101       S      * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)  
102       S      * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)  
103       S      * ( APAD(KNU,IA,7) ))))))        ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia)
104  C      END DO
105        ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)    END DO
106       S      * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)  
107       S      * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)    RETURN
108       S      * ( BPAD(KNU,IA,7) ))))))  END SUBROUTINE swtt1
 C      
 C  
 C*         2.      ADD THE BACKGROUND TRANSMISSION  
 C  
  200  CONTINUE  
 C  
       PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)  
  201  CONTINUE  
  202  CONTINUE  
 C  
       RETURN  
       END  
Legend:
Removed from v.24  
changed lines
  Added in v.82
  ViewVC Help
Powered by ViewVC 1.1.21