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

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

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

trunk/phylmd/Radlwsw/swtt1.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/phylmd/Radlwsw/swtt1.f90 revision 81 by guez, Wed Mar 5 14:38:41 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        DOUBLE PRECISION PU(KDLON,KABS)  ! ABSORBER AMOUNT    DOUBLE PRECISION pu(kdlon, kabs) ! ABSORBER AMOUNT
40  C  
41        DOUBLE PRECISION PTR(KDLON,KABS) ! TRANSMISSION FUNCTION    DOUBLE PRECISION ptr(kdlon, kabs) ! TRANSMISSION FUNCTION
42  C  
43  C* LOCAL VARIABLES:    ! * LOCAL VARIABLES:
44  C  
45        DOUBLE PRECISION ZR1(KDLON)    DOUBLE PRECISION zr1(kdlon)
46        DOUBLE PRECISION ZR2(KDLON)    DOUBLE PRECISION zr2(kdlon)
47        DOUBLE PRECISION 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        DOUBLE PRECISION 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.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21