1 |
SUBROUTINE SWTT (KNU,KA,PU,PTR) |
SUBROUTINE swtt(knu, ka, 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 : 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 |
DOUBLE PRECISION PU(KDLON) ! ABSORBER AMOUNT |
DOUBLE PRECISION pu(kdlon) ! ABSORBER AMOUNT |
40 |
C |
|
41 |
DOUBLE PRECISION PTR(KDLON) ! TRANSMISSION FUNCTION |
DOUBLE PRECISION ptr(kdlon) ! TRANSMISSION FUNCTION |
42 |
C |
|
43 |
C* LOCAL VARIABLES: |
! * LOCAL VARIABLES: |
44 |
C |
|
45 |
DOUBLE PRECISION 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 |
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) |
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 |
|