phylmd/Radlwsw/swtt.f

SUBROUTINE swtt(knu, ka, pu, ptr)
  USE dimens_m
  USE dimphy
  USE raddim
  IMPLICIT NONE

  ! -----------------------------------------------------------------------
  ! PURPOSE.
  ! --------
  ! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
  ! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
  ! INTERVALS.

  ! METHOD.
  ! -------

  ! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
  ! AND HORNER'S ALGORITHM.

  ! REFERENCE.
  ! ----------

  ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
  ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS

  ! AUTHOR.
  ! -------
  ! JEAN-JACQUES MORCRETTE  *ECMWF*

  ! MODIFICATIONS.
  ! --------------
  ! ORIGINAL : 88-12-15
  ! -----------------------------------------------------------------------

  ! * ARGUMENTS

  INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
  INTEGER ka ! INDEX OF THE ABSORBER
  DOUBLE PRECISION pu(kdlon) ! ABSORBER AMOUNT

  DOUBLE PRECISION ptr(kdlon) ! TRANSMISSION FUNCTION

  ! * LOCAL VARIABLES:

  DOUBLE PRECISION zr1(kdlon), zr2(kdlon)
  INTEGER jl, i, j

  ! * Prescribed Data:

  DOUBLE PRECISION apad(2, 3, 7), bpad(2, 3, 7), d(2, 3)
  SAVE apad, bpad, d
  DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
    0.925887084E-04, 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, &
    0.596037057E+04, 0.000000000E-00, 0.800821928E+00, 0.000000000E-00, &
    0.000000000E-00, 0.242715973E+02, 0.000000000E-00, 0.000000000E-00, &
    0.878331486E+02, 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, &
    0.000000000E-00, 0.000000000E-00, 0.000000000E+00/
  DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
    0.410177786E+03, 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, &
    0.387714006E+00, 0.437772681E+00, 0.000000000E-00, 0.118461660E+03, &
    0.151345118E+03, 0.000000000E-00, 0.119079797E+04, 0.233628890E+04, &
    0.000000000E-00, 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, &
    0.000000000E+00, 0.000000000E+00, 0.000000000E+00/

  DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
    0.925887084E-04, 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, &
    0.602593328E+04, 0.000000000E-00, 0.812706117E+00, 0.100000000E+01, &
    0.000000000E-00, 0.249863591E+02, 0.000000000E-00, 0.000000000E-00, &
    0.931071925E+02, 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, &
    0.000000000E-00, 0.000000000E-00, 0.100000000E+01/
  DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
    0.410177786E+03, 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, &
    0.388611139E+00, 0.437949001E+00, 0.100000000E+01, 0.120291383E+03, &
    0.151692730E+03, 0.000000000E+00, 0.130531005E+04, 0.237071130E+04, &
    0.000000000E+00, 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, &
    0.100000000E+01, 0.100000000E+01, 0.000000000E+00/

  DATA (d(1,i), i=1, 3)/0.00, 0.00, 0.00/
  DATA (d(2,i), i=1, 3)/0.000000000, 0.000000000, 0.800000000/

  ! -----------------------------------------------------------------------

  ! *         1.      HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION


  DO jl = 1, kdlon
    zr1(jl) = apad(knu, ka, 1) + pu(jl)*(apad(knu,ka,2)+pu(jl)*(apad(knu,ka, &
      3)+pu(jl)*(apad(knu,ka,4)+pu(jl)*(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
      +pu(jl)*(apad(knu,ka,7)))))))

    zr2(jl) = bpad(knu, ka, 1) + pu(jl)*(bpad(knu,ka,2)+pu(jl)*(bpad(knu,ka, &
      3)+pu(jl)*(bpad(knu,ka,4)+pu(jl)*(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
      +pu(jl)*(bpad(knu,ka,7)))))))


    ! *         2.      ADD THE BACKGROUND TRANSMISSION


    ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
  END DO

  RETURN
END SUBROUTINE swtt
1	SUBROUTINE swtt(knu, ka, 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 : 88-12-15
33	! -----------------------------------------------------------------------
34
35	! * ARGUMENTS
36
37	INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
38	INTEGER ka ! INDEX OF THE ABSORBER
39	DOUBLE PRECISION pu(kdlon) ! ABSORBER AMOUNT
40
41	DOUBLE PRECISION ptr(kdlon) ! TRANSMISSION FUNCTION
42
43	! * LOCAL VARIABLES:
44
45	DOUBLE PRECISION zr1(kdlon), zr2(kdlon)
46	INTEGER jl, i, j
47
48	! * Prescribed Data:
49
50	DOUBLE PRECISION apad(2, 3, 7), bpad(2, 3, 7), d(2, 3)
51	SAVE apad, bpad, d
52	DATA ((apad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
53	0.925887084E-04, 0.723613782E+05, 0.000000000E-00, 0.129353723E-01, &
54	0.596037057E+04, 0.000000000E-00, 0.800821928E+00, 0.000000000E-00, &
55	0.000000000E-00, 0.242715973E+02, 0.000000000E-00, 0.000000000E-00, &
56	0.878331486E+02, 0.000000000E-00, 0.000000000E-00, 0.191559725E+02, &
57	0.000000000E-00, 0.000000000E-00, 0.000000000E+00/
58	DATA ((apad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
59	0.410177786E+03, 0.978576773E-04, 0.131849595E-03, 0.672595424E+02, &
60	0.387714006E+00, 0.437772681E+00, 0.000000000E-00, 0.118461660E+03, &
61	0.151345118E+03, 0.000000000E-00, 0.119079797E+04, 0.233628890E+04, &
62	0.000000000E-00, 0.293353397E+03, 0.797219934E+03, 0.000000000E-00, &
63	0.000000000E+00, 0.000000000E+00, 0.000000000E+00/
64
65	DATA ((bpad(1,i,j),i=1,3), j=1, 7)/0.912418292E+05, 0.000000000E-00, &
66	0.925887084E-04, 0.724555318E+05, 0.000000000E-00, 0.131812683E-01, &
67	0.602593328E+04, 0.000000000E-00, 0.812706117E+00, 0.100000000E+01, &
68	0.000000000E-00, 0.249863591E+02, 0.000000000E-00, 0.000000000E-00, &
69	0.931071925E+02, 0.000000000E-00, 0.000000000E-00, 0.252233437E+02, &
70	0.000000000E-00, 0.000000000E-00, 0.100000000E+01/
71	DATA ((bpad(2,i,j),i=1,3), j=1, 7)/0.376655383E-08, 0.739646016E-08, &
72	0.410177786E+03, 0.979023421E-04, 0.131861712E-03, 0.731185438E+02, &
73	0.388611139E+00, 0.437949001E+00, 0.100000000E+01, 0.120291383E+03, &
74	0.151692730E+03, 0.000000000E+00, 0.130531005E+04, 0.237071130E+04, &
75	0.000000000E+00, 0.415049409E+03, 0.867914360E+03, 0.000000000E+00, &
76	0.100000000E+01, 0.100000000E+01, 0.000000000E+00/
77
78	DATA (d(1,i), i=1, 3)/0.00, 0.00, 0.00/
79	DATA (d(2,i), i=1, 3)/0.000000000, 0.000000000, 0.800000000/
80
81	! -----------------------------------------------------------------------
82
83	! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
84
85
86	DO jl = 1, kdlon
87	zr1(jl) = apad(knu, ka, 1) + pu(jl)(apad(knu,ka,2)+pu(jl)(apad(knu,ka, &
88	3)+pu(jl)(apad(knu,ka,4)+pu(jl)(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
89	+pu(jl)*(apad(knu,ka,7)))))))
90
91	zr2(jl) = bpad(knu, ka, 1) + pu(jl)(bpad(knu,ka,2)+pu(jl)(bpad(knu,ka, &
92	3)+pu(jl)(bpad(knu,ka,4)+pu(jl)(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
93	+pu(jl)*(bpad(knu,ka,7)))))))
94
95
96	! * 2. ADD THE BACKGROUND TRANSMISSION
97
98
99
100	ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
101	END DO
102
103	RETURN
104	END SUBROUTINE swtt