phylmd/Radlwsw/sw1s.f

module sw1s_m

  IMPLICIT NONE

contains

  SUBROUTINE sw1s(knu, palbd, palbp, pcg, pcld, pclear, pdsig, pomega, poz, &
       prmu, psec, ptau, pud, pfd, pfu)
    
    USE dimens_m
    USE dimphy
    USE raddim
    use swclr_m, only: swclr
    use swr_m, only: swr

    ! ------------------------------------------------------------------
    ! PURPOSE.
    ! --------

    ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
    ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).

    ! METHOD.
    ! -------

    ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
    ! CONTINUUM SCATTERING
    ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION

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

    ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
    ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)

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

    ! MODIFICATIONS.
    ! --------------
    ! ORIGINAL : 89-07-14
    ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
    ! ------------------------------------------------------------------

    ! * ARGUMENTS:

    INTEGER knu
    DOUBLE PRECISION palbd(kdlon, 2)
    DOUBLE PRECISION palbp(kdlon, 2)
    DOUBLE PRECISION pcg(kdlon, 2, kflev)
    DOUBLE PRECISION pcld(kdlon, kflev)
    DOUBLE PRECISION pclear(kdlon)
    DOUBLE PRECISION pdsig(kdlon, kflev)
    DOUBLE PRECISION pomega(kdlon, 2, kflev)
    DOUBLE PRECISION poz(kdlon, kflev)
    DOUBLE PRECISION prmu(kdlon)
    DOUBLE PRECISION psec(kdlon)
    DOUBLE PRECISION ptau(kdlon, 2, kflev)
    DOUBLE PRECISION pud(kdlon, 5, kflev+1)

    DOUBLE PRECISION pfd(kdlon, kflev+1)
    DOUBLE PRECISION pfu(kdlon, kflev+1)

    ! * LOCAL VARIABLES:

    INTEGER iind(4)

    DOUBLE PRECISION zcgaz(kdlon, kflev)
    DOUBLE PRECISION zdiff(kdlon)
    DOUBLE PRECISION zdirf(kdlon)
    DOUBLE PRECISION zpizaz(kdlon, kflev)
    DOUBLE PRECISION zrayl(kdlon)
    DOUBLE PRECISION zray1(kdlon, kflev+1)
    DOUBLE PRECISION zray2(kdlon, kflev+1)
    DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
    DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
    DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
    DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
    DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
    DOUBLE PRECISION zrmue(kdlon, kflev+1)
    DOUBLE PRECISION zrmu0(kdlon, kflev+1)
    DOUBLE PRECISION zr(kdlon, 4)
    DOUBLE PRECISION ztauaz(kdlon, kflev)
    DOUBLE PRECISION ztra1(kdlon, kflev+1)
    DOUBLE PRECISION ztra2(kdlon, kflev+1)
    DOUBLE PRECISION zw(kdlon, 4)

    INTEGER jl, jk, k, jaj, ikm1, ikl

    ! Prescribed Data:

    DOUBLE PRECISION rsun(2)
    SAVE rsun
    DOUBLE PRECISION rray(2, 6)
    SAVE rray
    DATA rsun(1)/0.441676d0/
    DATA rsun(2)/0.558324d0/
    DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
         .522744d+01, -.469173d+01, .161645d+01/
    DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
         .248261d+00, -.302031d+00, .129662d+00/
    ! ------------------------------------------------------------------

    ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
    ! ----------------------- ------------------


    ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
    ! -----------------------------------------


    DO jl = 1, kdlon
       zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
            3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
    END DO


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

    ! *         2.    CONTINUUM SCATTERING CALCULATIONS
    ! ---------------------------------


    ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
    ! --------------------------------


    CALL swclr(knu, palbp, pdsig, zrayl, psec, zpizaz, zray1, zray2, zrefz, &
         zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)


    ! *         2.2   CLOUDY FRACTION OF THE COLUMN
    ! -----------------------------

    zcgaz = 0d0
    CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
         zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)


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

    ! *         3.    OZONE ABSORPTION
    ! ----------------


    iind(1) = 1
    iind(2) = 3
    iind(3) = 1
    iind(4) = 3


    ! *         3.1   DOWNWARD FLUXES
    ! ---------------


    jaj = 2

    DO jl = 1, kdlon
       zw(jl, 1) = 0.
       zw(jl, 2) = 0.
       zw(jl, 3) = 0.
       zw(jl, 4) = 0.
       pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
            jl,jaj,kflev+1))*rsun(knu)
    END DO
    DO jk = 1, kflev
       ikl = kflev + 1 - jk
       DO jl = 1, kdlon
          zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
          zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
          zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
          zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
       END DO

       CALL swtt1(knu, 4, iind, zw, zr)

       DO jl = 1, kdlon
          zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
          zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
          pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
               rsun(knu)
       END DO
    END DO


    ! *         3.2   UPWARD FLUXES
    ! -------------


    DO jl = 1, kdlon
       pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
            )*palbp(jl,knu))*rsun(knu)
    END DO

    DO jk = 2, kflev + 1
       ikm1 = jk - 1
       DO jl = 1, kdlon
          zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
          zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
          zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
          zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
       END DO

       CALL swtt1(knu, 4, iind, zw, zr)

       DO jl = 1, kdlon
          zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
          zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
          pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
               rsun(knu)
       END DO
    END DO

  END SUBROUTINE sw1s

end module sw1s_m
1	guez	178	module sw1s_m
2
3	guez	81	IMPLICIT NONE
4
5	guez	178	contains
6	guez	81
7	guez	219	SUBROUTINE sw1s(knu, palbd, palbp, pcg, pcld, pclear, pdsig, pomega, poz, &
8			prmu, psec, ptau, pud, pfd, pfu)
9	guez	217
10	guez	178	USE dimens_m
11			USE dimphy
12			USE raddim
13			use swclr_m, only: swclr
14			use swr_m, only: swr
15	guez	81
16	guez	178	! ------------------------------------------------------------------
17			! PURPOSE.
18			! --------
19	guez	81
20	guez	178	! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
21			! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
22	guez	81
23	guez	178	! METHOD.
24			! -------
25	guez	81
26	guez	178	! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
27			! CONTINUUM SCATTERING
28			! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
29	guez	81
30	guez	178	! REFERENCE.
31			! ----------
32	guez	81
33	guez	178	! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
34			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
35	guez	81
36	guez	178	! AUTHOR.
37			! -------
38			! JEAN-JACQUES MORCRETTE ECMWF
39	guez	81
40	guez	178	! MODIFICATIONS.
41			! --------------
42			! ORIGINAL : 89-07-14
43			! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
44			! ------------------------------------------------------------------
45	guez	81
46	guez	178	! * ARGUMENTS:
47	guez	81
48	guez	178	INTEGER knu
49			DOUBLE PRECISION palbd(kdlon, 2)
50			DOUBLE PRECISION palbp(kdlon, 2)
51			DOUBLE PRECISION pcg(kdlon, 2, kflev)
52			DOUBLE PRECISION pcld(kdlon, kflev)
53			DOUBLE PRECISION pclear(kdlon)
54			DOUBLE PRECISION pdsig(kdlon, kflev)
55			DOUBLE PRECISION pomega(kdlon, 2, kflev)
56			DOUBLE PRECISION poz(kdlon, kflev)
57			DOUBLE PRECISION prmu(kdlon)
58			DOUBLE PRECISION psec(kdlon)
59			DOUBLE PRECISION ptau(kdlon, 2, kflev)
60			DOUBLE PRECISION pud(kdlon, 5, kflev+1)
61	guez	81
62	guez	178	DOUBLE PRECISION pfd(kdlon, kflev+1)
63			DOUBLE PRECISION pfu(kdlon, kflev+1)
64	guez	81
65	guez	178	! * LOCAL VARIABLES:
66	guez	81
67	guez	178	INTEGER iind(4)
68	guez	81
69	guez	178	DOUBLE PRECISION zcgaz(kdlon, kflev)
70			DOUBLE PRECISION zdiff(kdlon)
71			DOUBLE PRECISION zdirf(kdlon)
72			DOUBLE PRECISION zpizaz(kdlon, kflev)
73			DOUBLE PRECISION zrayl(kdlon)
74			DOUBLE PRECISION zray1(kdlon, kflev+1)
75			DOUBLE PRECISION zray2(kdlon, kflev+1)
76			DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
77			DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
78			DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
79			DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
80			DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
81			DOUBLE PRECISION zrmue(kdlon, kflev+1)
82			DOUBLE PRECISION zrmu0(kdlon, kflev+1)
83			DOUBLE PRECISION zr(kdlon, 4)
84			DOUBLE PRECISION ztauaz(kdlon, kflev)
85			DOUBLE PRECISION ztra1(kdlon, kflev+1)
86			DOUBLE PRECISION ztra2(kdlon, kflev+1)
87			DOUBLE PRECISION zw(kdlon, 4)
88	guez	81
89	guez	178	INTEGER jl, jk, k, jaj, ikm1, ikl
90	guez	81
91	guez	178	! Prescribed Data:
92	guez	81
93	guez	178	DOUBLE PRECISION rsun(2)
94			SAVE rsun
95			DOUBLE PRECISION rray(2, 6)
96			SAVE rray
97			DATA rsun(1)/0.441676d0/
98			DATA rsun(2)/0.558324d0/
99			DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
100			.522744d+01, -.469173d+01, .161645d+01/
101			DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
102			.248261d+00, -.302031d+00, .129662d+00/
103			! ------------------------------------------------------------------
104	guez	81
105	guez	178	! * 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
106			! ----------------------- ------------------
107	guez	81
108
109
110	guez	178	! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
111			! -----------------------------------------
112	guez	81
113
114	guez	178	DO jl = 1, kdlon
115			zrayl(jl) = rray(knu, 1) + prmu(jl)(rray(knu,2)+prmu(jl)(rray(knu, &
116			3)+prmu(jl)(rray(knu,4)+prmu(jl)(rray(knu,5)+prmu(jl)*rray(knu,6)))))
117			END DO
118	guez	81
119
120	guez	178	! ------------------------------------------------------------------
121	guez	81
122	guez	178	! * 2. CONTINUUM SCATTERING CALCULATIONS
123			! ---------------------------------
124	guez	81
125
126	guez	178	! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN
127			! --------------------------------
128	guez	81
129
130	guez	219	CALL swclr(knu, palbp, pdsig, zrayl, psec, zpizaz, zray1, zray2, zrefz, &
131			zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)
132	guez	81
133
134	guez	178	! * 2.2 CLOUDY FRACTION OF THE COLUMN
135			! -----------------------------
136	guez	81
137	guez	219	zcgaz = 0d0
138	guez	178	CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
139			zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
140	guez	81
141
142	guez	178	! ------------------------------------------------------------------
143	guez	81
144	guez	178	! * 3. OZONE ABSORPTION
145			! ----------------
146	guez	81
147
148	guez	178	iind(1) = 1
149			iind(2) = 3
150			iind(3) = 1
151			iind(4) = 3
152	guez	81
153
154	guez	178	! * 3.1 DOWNWARD FLUXES
155			! ---------------
156	guez	81
157	guez	178
158			jaj = 2
159
160	guez	81	DO jl = 1, kdlon
161	guez	178	zw(jl, 1) = 0.
162			zw(jl, 2) = 0.
163			zw(jl, 3) = 0.
164			zw(jl, 4) = 0.
165			pfd(jl, kflev+1) = ((1.-pclear(jl))zrj(jl,jaj,kflev+1)+pclear(jl)zrj0( &
166			jl,jaj,kflev+1))*rsun(knu)
167	guez	81	END DO
168	guez	178	DO jk = 1, kflev
169			ikl = kflev + 1 - jk
170			DO jl = 1, kdlon
171			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
172			zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
173			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
174			zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
175			END DO
176	guez	81
177	guez	178	CALL swtt1(knu, 4, iind, zw, zr)
178	guez	81
179	guez	178	DO jl = 1, kdlon
180			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrj(jl, jaj, ikl)
181			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrj0(jl, jaj, ikl)
182			pfd(jl, ikl) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
183			rsun(knu)
184			END DO
185	guez	81	END DO
186
187
188	guez	178	! * 3.2 UPWARD FLUXES
189			! -------------
190	guez	81
191
192			DO jl = 1, kdlon
193	guez	178	pfu(jl, 1) = ((1.-pclear(jl))zdiff(jl)palbd(jl,knu)+pclear(jl)*zdirf(jl &
194			)palbp(jl,knu))rsun(knu)
195	guez	81	END DO
196
197	guez	178	DO jk = 2, kflev + 1
198			ikm1 = jk - 1
199			DO jl = 1, kdlon
200			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
201			zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
202			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
203			zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
204			END DO
205	guez	81
206	guez	178	CALL swtt1(knu, 4, iind, zw, zr)
207
208			DO jl = 1, kdlon
209			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrk(jl, jaj, jk)
210			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrk0(jl, jaj, jk)
211			pfu(jl, jk) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
212			rsun(knu)
213			END DO
214	guez	81	END DO
215
216	guez	178	END SUBROUTINE sw1s
217	guez	81
218	guez	178	end module sw1s_m