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

Contents of /trunk/libf/phylmd/Radlwsw/swtt1.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 71 - (show annotations)
Mon Jul 8 18:12:18 2013 UTC (10 years, 9 months ago) by guez
File size: 4312 byte(s) 
No reason to call inidissip in ce0l.

In inidissip, set random seed to 1 beacuse PGI compiler does not
accept all zeros.

dq was computed needlessly in caladvtrac. Arguments masse and dq of
calfis not used.

Replaced real*8 by double precision.

Pass arrays with inverted order of vertical levels to conflx instead
of creating local variables for this inside conflx.
1 SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
2 use dimens_m
3 use dimphy
4 use raddim
5 IMPLICIT none
6 C
7 C-----------------------------------------------------------------------
8 C PURPOSE.
9 C --------
10 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
11 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
12 C INTERVALS.
13 C
14 C METHOD.
15 C -------
16 C
17 C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
18 C AND HORNER'S ALGORITHM.
19 C
20 C REFERENCE.
21 C ----------
22 C
23 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
24 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
25 C
26 C AUTHOR.
27 C -------
28 C JEAN-JACQUES MORCRETTE *ECMWF*
29 C
30 C MODIFICATIONS.
31 C --------------
32 C ORIGINAL : 95-01-20
33 C-----------------------------------------------------------------------
34 C* ARGUMENTS:
35 C
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 C
41 DOUBLE PRECISION PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
42 C
43 C* LOCAL VARIABLES:
44 C
45 DOUBLE PRECISION ZR1(KDLON)
46 DOUBLE PRECISION ZR2(KDLON)
47 DOUBLE PRECISION ZU(KDLON)
48 INTEGER jl, ja, i, j, ia
49 C
50 C* Prescribed Data:
51 C
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) /
55 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
56 S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
57 S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
58 S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
59 S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
60 S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
61 S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
62 DATA ((APAD(2,I,J),I=1,3),J=1,7) /
63 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
64 S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
65 S 0.387714006E+00, 0.437772681E+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,
68 S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
69 S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
70 C
71 DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
72 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
73 S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
74 S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
75 S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
76 S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
77 S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
78 S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
79 DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
80 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
81 S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
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,
85 S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
86 S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
87 c
88 DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
89 DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
90 C-----------------------------------------------------------------------
91 C
92 C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
93 C
94 100 CONTINUE
95 C
96 DO 202 JA = 1,KABS
97 IA=KIND(JA)
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)
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) ))))))
104 C
105 ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
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)
108 S * ( BPAD(KNU,IA,7) ))))))
109 C
110 C
111 C* 2. ADD THE BACKGROUND TRANSMISSION
112 C
113 200 CONTINUE
114 C
115 PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
116 201 CONTINUE
117 202 CONTINUE
118 C
119 RETURN
120 END
  ViewVC Help
Powered by ViewVC 1.1.21