1 |
SUBROUTINE swtt1(knu, kabs, kind, pu, ptr) |
2 |
USE dimens_m |
3 |
USE dimphy |
4 |
USE raddim |
5 |
IMPLICIT NONE |
6 |
|
7 |
! ----------------------------------------------------------------------- |
8 |
! PURPOSE. |
9 |
! -------- |
10 |
! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE |
11 |
! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL |
12 |
! INTERVALS. |
13 |
|
14 |
! METHOD. |
15 |
! ------- |
16 |
|
17 |
! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS |
18 |
! AND HORNER'S ALGORITHM. |
19 |
|
20 |
! REFERENCE. |
21 |
! ---------- |
22 |
|
23 |
! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND |
24 |
! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS |
25 |
|
26 |
! AUTHOR. |
27 |
! ------- |
28 |
! JEAN-JACQUES MORCRETTE *ECMWF* |
29 |
|
30 |
! MODIFICATIONS. |
31 |
! -------------- |
32 |
! ORIGINAL : 95-01-20 |
33 |
! ----------------------------------------------------------------------- |
34 |
! * ARGUMENTS: |
35 |
|
36 |
INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL |
37 |
INTEGER kabs ! NUMBER OF ABSORBERS |
38 |
INTEGER kind(kabs) ! INDICES OF THE ABSORBERS |
39 |
DOUBLE PRECISION pu(kdlon, kabs) ! ABSORBER AMOUNT |
40 |
|
41 |
DOUBLE PRECISION ptr(kdlon, kabs) ! TRANSMISSION FUNCTION |
42 |
|
43 |
! * LOCAL VARIABLES: |
44 |
|
45 |
DOUBLE PRECISION zr1(kdlon) |
46 |
DOUBLE PRECISION zr2(kdlon) |
47 |
DOUBLE PRECISION zu(kdlon) |
48 |
INTEGER jl, ja, i, j, ia |
49 |
|
50 |
! * Prescribed Data: |
51 |
|
52 |
DOUBLE PRECISION apad(2, 3, 7), bpad(2, 3, 7), d(2, 3) |
53 |
SAVE apad, bpad, d |
54 |
DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, & |
55 |
0.925887084E-04, 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, & |
56 |
0.596037057E+04, 0.000000000E-00, 0.800821928E+00, 0.000000000E-00, & |
57 |
0.000000000E-00, 0.242715973E+02, 0.000000000E-00, 0.000000000E-00, & |
58 |
0.878331486E+02, 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, & |
59 |
0.000000000E-00, 0.000000000E-00, 0.000000000E+00/ |
60 |
DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, & |
61 |
0.410177786E+03, 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, & |
62 |
0.387714006E+00, 0.437772681E+00, 0.000000000E-00, 0.118461660E+03, & |
63 |
0.151345118E+03, 0.000000000E-00, 0.119079797E+04, 0.233628890E+04, & |
64 |
0.000000000E-00, 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, & |
65 |
0.000000000E+00, 0.000000000E+00, 0.000000000E+00/ |
66 |
|
67 |
DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, & |
68 |
0.925887084E-04, 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, & |
69 |
0.602593328E+04, 0.000000000E-00, 0.812706117E+00, 0.100000000E+01, & |
70 |
0.000000000E-00, 0.249863591E+02, 0.000000000E-00, 0.000000000E-00, & |
71 |
0.931071925E+02, 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, & |
72 |
0.000000000E-00, 0.000000000E-00, 0.100000000E+01/ |
73 |
DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, & |
74 |
0.410177786E+03, 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, & |
75 |
0.388611139E+00, 0.437949001E+00, 0.100000000E+01, 0.120291383E+03, & |
76 |
0.151692730E+03, 0.000000000E+00, 0.130531005E+04, 0.237071130E+04, & |
77 |
0.000000000E+00, 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, & |
78 |
0.100000000E+01, 0.100000000E+01, 0.000000000E+00/ |
79 |
|
80 |
DATA (d(1,i), i=1, 3)/0.00, 0.00, 0.00/ |
81 |
DATA (d(2,i), i=1, 3)/0.000000000, 0.000000000, 0.800000000/ |
82 |
! ----------------------------------------------------------------------- |
83 |
|
84 |
! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION |
85 |
|
86 |
|
87 |
DO ja = 1, kabs |
88 |
ia = kind(ja) |
89 |
DO jl = 1, kdlon |
90 |
zu(jl) = pu(jl, ja) |
91 |
zr1(jl) = apad(knu, ia, 1) + zu(jl)*(apad(knu,ia,2)+zu(jl)*(apad(knu, & |
92 |
ia,3)+zu(jl)*(apad(knu,ia,4)+zu(jl)*(apad(knu,ia,5)+zu(jl)*(apad(knu, & |
93 |
ia,6)+zu(jl)*(apad(knu,ia,7))))))) |
94 |
|
95 |
zr2(jl) = bpad(knu, ia, 1) + zu(jl)*(bpad(knu,ia,2)+zu(jl)*(bpad(knu, & |
96 |
ia,3)+zu(jl)*(bpad(knu,ia,4)+zu(jl)*(bpad(knu,ia,5)+zu(jl)*(bpad(knu, & |
97 |
ia,6)+zu(jl)*(bpad(knu,ia,7))))))) |
98 |
|
99 |
|
100 |
! * 2. ADD THE BACKGROUND TRANSMISSION |
101 |
|
102 |
|
103 |
ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia) |
104 |
END DO |
105 |
END DO |
106 |
|
107 |
RETURN |
108 |
END SUBROUTINE swtt1 |