phylmd/Radlwsw/sw1s.f90

module sw1s_m

  IMPLICIT NONE

contains

  SUBROUTINE sw1s(knu, flag_aer, tauae, pizae, cgae, 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
    ! -OB
    DOUBLE PRECISION flag_aer
    DOUBLE PRECISION tauae(kdlon, kflev, 2)
    DOUBLE PRECISION pizae(kdlon, kflev, 2)
    DOUBLE PRECISION cgae(kdlon, kflev, 2)
    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, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
         psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
         ztra1, ztra2)


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


    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	178	SUBROUTINE sw1s(knu, flag_aer, tauae, pizae, cgae, palbd, palbp, pcg, &
8			pcld, pclear, pdsig, pomega, poz, prmu, psec, ptau, pud, pfd, &
9			pfu)
10			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			! -OB
50			DOUBLE PRECISION flag_aer
51			DOUBLE PRECISION tauae(kdlon, kflev, 2)
52			DOUBLE PRECISION pizae(kdlon, kflev, 2)
53			DOUBLE PRECISION cgae(kdlon, kflev, 2)
54			DOUBLE PRECISION palbd(kdlon, 2)
55			DOUBLE PRECISION palbp(kdlon, 2)
56			DOUBLE PRECISION pcg(kdlon, 2, kflev)
57			DOUBLE PRECISION pcld(kdlon, kflev)
58			DOUBLE PRECISION pclear(kdlon)
59			DOUBLE PRECISION pdsig(kdlon, kflev)
60			DOUBLE PRECISION pomega(kdlon, 2, kflev)
61			DOUBLE PRECISION poz(kdlon, kflev)
62			DOUBLE PRECISION prmu(kdlon)
63			DOUBLE PRECISION psec(kdlon)
64			DOUBLE PRECISION ptau(kdlon, 2, kflev)
65			DOUBLE PRECISION pud(kdlon, 5, kflev+1)
66	guez	81
67	guez	178	DOUBLE PRECISION pfd(kdlon, kflev+1)
68			DOUBLE PRECISION pfu(kdlon, kflev+1)
69	guez	81
70	guez	178	! * LOCAL VARIABLES:
71	guez	81
72	guez	178	INTEGER iind(4)
73	guez	81
74	guez	178	DOUBLE PRECISION zcgaz(kdlon, kflev)
75			DOUBLE PRECISION zdiff(kdlon)
76			DOUBLE PRECISION zdirf(kdlon)
77			DOUBLE PRECISION zpizaz(kdlon, kflev)
78			DOUBLE PRECISION zrayl(kdlon)
79			DOUBLE PRECISION zray1(kdlon, kflev+1)
80			DOUBLE PRECISION zray2(kdlon, kflev+1)
81			DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
82			DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
83			DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
84			DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
85			DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
86			DOUBLE PRECISION zrmue(kdlon, kflev+1)
87			DOUBLE PRECISION zrmu0(kdlon, kflev+1)
88			DOUBLE PRECISION zr(kdlon, 4)
89			DOUBLE PRECISION ztauaz(kdlon, kflev)
90			DOUBLE PRECISION ztra1(kdlon, kflev+1)
91			DOUBLE PRECISION ztra2(kdlon, kflev+1)
92			DOUBLE PRECISION zw(kdlon, 4)
93	guez	81
94	guez	178	INTEGER jl, jk, k, jaj, ikm1, ikl
95	guez	81
96	guez	178	! Prescribed Data:
97	guez	81
98	guez	178	DOUBLE PRECISION rsun(2)
99			SAVE rsun
100			DOUBLE PRECISION rray(2, 6)
101			SAVE rray
102			DATA rsun(1)/0.441676d0/
103			DATA rsun(2)/0.558324d0/
104			DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
105			.522744d+01, -.469173d+01, .161645d+01/
106			DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
107			.248261d+00, -.302031d+00, .129662d+00/
108			! ------------------------------------------------------------------
109	guez	81
110	guez	178	! * 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
111			! ----------------------- ------------------
112	guez	81
113
114
115	guez	178	! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
116			! -----------------------------------------
117	guez	81
118
119	guez	178	DO jl = 1, kdlon
120			zrayl(jl) = rray(knu, 1) + prmu(jl)(rray(knu,2)+prmu(jl)(rray(knu, &
121			3)+prmu(jl)(rray(knu,4)+prmu(jl)(rray(knu,5)+prmu(jl)*rray(knu,6)))))
122			END DO
123	guez	81
124
125	guez	178	! ------------------------------------------------------------------
126	guez	81
127	guez	178	! * 2. CONTINUUM SCATTERING CALCULATIONS
128			! ---------------------------------
129	guez	81
130
131	guez	178	! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN
132			! --------------------------------
133	guez	81
134
135	guez	178	CALL swclr(knu, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
136			psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
137			ztra1, ztra2)
138	guez	81
139
140	guez	178	! * 2.2 CLOUDY FRACTION OF THE COLUMN
141			! -----------------------------
142	guez	81
143
144	guez	178	CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
145			zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
146	guez	81
147
148	guez	178	! ------------------------------------------------------------------
149	guez	81
150	guez	178	! * 3. OZONE ABSORPTION
151			! ----------------
152	guez	81
153
154	guez	178	iind(1) = 1
155			iind(2) = 3
156			iind(3) = 1
157			iind(4) = 3
158	guez	81
159
160	guez	178	! * 3.1 DOWNWARD FLUXES
161			! ---------------
162	guez	81
163	guez	178
164			jaj = 2
165
166	guez	81	DO jl = 1, kdlon
167	guez	178	zw(jl, 1) = 0.
168			zw(jl, 2) = 0.
169			zw(jl, 3) = 0.
170			zw(jl, 4) = 0.
171			pfd(jl, kflev+1) = ((1.-pclear(jl))zrj(jl,jaj,kflev+1)+pclear(jl)zrj0( &
172			jl,jaj,kflev+1))*rsun(knu)
173	guez	81	END DO
174	guez	178	DO jk = 1, kflev
175			ikl = kflev + 1 - jk
176			DO jl = 1, kdlon
177			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
178			zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
179			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
180			zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
181			END DO
182	guez	81
183	guez	178	CALL swtt1(knu, 4, iind, zw, zr)
184	guez	81
185	guez	178	DO jl = 1, kdlon
186			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrj(jl, jaj, ikl)
187			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrj0(jl, jaj, ikl)
188			pfd(jl, ikl) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
189			rsun(knu)
190			END DO
191	guez	81	END DO
192
193
194	guez	178	! * 3.2 UPWARD FLUXES
195			! -------------
196	guez	81
197
198			DO jl = 1, kdlon
199	guez	178	pfu(jl, 1) = ((1.-pclear(jl))zdiff(jl)palbd(jl,knu)+pclear(jl)*zdirf(jl &
200			)palbp(jl,knu))rsun(knu)
201	guez	81	END DO
202
203	guez	178	DO jk = 2, kflev + 1
204			ikm1 = jk - 1
205			DO jl = 1, kdlon
206			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
207			zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
208			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
209			zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
210			END DO
211	guez	81
212	guez	178	CALL swtt1(knu, 4, iind, zw, zr)
213
214			DO jl = 1, kdlon
215			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrk(jl, jaj, jk)
216			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrk0(jl, jaj, jk)
217			pfu(jl, jk) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
218			rsun(knu)
219			END DO
220	guez	81	END DO
221
222	guez	178	END SUBROUTINE sw1s
223	guez	81
224	guez	178	end module sw1s_m