phylmd/Radlwsw/swu.f90

module swu_m

  IMPLICIT NONE

contains

  SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &
       pcld, pclear, pdsig, pfact, prmu, psec, pud)

    USE clesphys, only: rco2
    USE suphec_m, only: rg
    USE raddim, only: kdlon, kflev
    USE radepsi, only: zepscq, zepsec
    USE radopt, only: novlp

    ! ARGUMENTS:

    DOUBLE PRECISION, intent(in):: psct
    DOUBLE PRECISION, intent(in):: pcldsw(kdlon, kflev)
    DOUBLE PRECISION, intent(in):: ppmb(kdlon, kflev + 1)
    DOUBLE PRECISION, intent(in):: ppsol(kdlon)
    DOUBLE PRECISION, intent(in):: prmu0(kdlon)
    DOUBLE PRECISION, intent(in):: pfrac(kdlon)
    DOUBLE PRECISION, intent(in):: ptave(kdlon, kflev)
    DOUBLE PRECISION, intent(in):: pwv(kdlon, kflev)

    DOUBLE PRECISION paki(kdlon, 2)
    DOUBLE PRECISION pcld(kdlon, kflev)
    DOUBLE PRECISION pclear(kdlon)
    DOUBLE PRECISION pdsig(kdlon, kflev)
    DOUBLE PRECISION pfact(kdlon)
    DOUBLE PRECISION prmu(kdlon)
    DOUBLE PRECISION psec(kdlon)
    DOUBLE PRECISION pud(kdlon, 5, kflev + 1)

    ! Local:

    INTEGER iind(2)
    DOUBLE PRECISION zc1j(kdlon, kflev + 1)
    DOUBLE PRECISION zclear(kdlon)
    DOUBLE PRECISION zcloud(kdlon)
    DOUBLE PRECISION zn175(kdlon)
    DOUBLE PRECISION zn190(kdlon)
    DOUBLE PRECISION zo175(kdlon)
    DOUBLE PRECISION zo190(kdlon)
    DOUBLE PRECISION zsign(kdlon)
    DOUBLE PRECISION zr(kdlon, 2)
    DOUBLE PRECISION zsigo(kdlon)
    DOUBLE PRECISION zud(kdlon, 2)
    DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
    INTEGER jl, jk, jkp1, jkl, ja

    ! Prescribed Data:

    DOUBLE PRECISION zpdh2o, zpdumg
    SAVE zpdh2o, zpdumg
    DOUBLE PRECISION zprh2o, zprumg
    SAVE zprh2o, zprumg
    DOUBLE PRECISION rtdh2o, rtdumg
    SAVE rtdh2o, rtdumg
    DOUBLE PRECISION rth2o, rtumg
    SAVE rth2o, rtumg
    DATA zpdh2o, zpdumg /0.8d0, 0.75d0/
    DATA zprh2o, zprumg /30000.d0, 30000.d0/
    DATA rtdh2o, rtdumg /0.40d0, 0.375d0/
    DATA rth2o, rtumg /240.d0, 240.d0/

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

    ! 1. COMPUTES AMOUNTS OF ABSORBERS

    iind(1) = 1
    iind(2) = 2

    ! 1.1 INITIALIZES QUANTITIES

    DO jl = 1, kdlon
       pud(jl, 1, kflev + 1) = 0.
       pud(jl, 2, kflev + 1) = 0.
       pud(jl, 3, kflev + 1) = 0.
       pud(jl, 4, kflev + 1) = 0.
       pud(jl, 5, kflev + 1) = 0.
       pfact(jl) = prmu0(jl) * pfrac(jl) * psct
       prmu(jl) = sqrt(1224. * prmu0(jl) * prmu0(jl) + 1.) / 35.
       psec(jl) = 1. / prmu(jl)
       zc1j(jl, kflev + 1) = 0.
    END DO

    ! 1.3 AMOUNTS OF ABSORBERS

    DO jl = 1, kdlon
       zud(jl, 1) = 0.
       zud(jl, 2) = 0.
       zo175(jl) = ppsol(jl)**(zpdumg + 1.)
       zo190(jl) = ppsol(jl)**(zpdh2o + 1.)
       zsigo(jl) = ppsol(jl)
       zclear(jl) = 1.
       zcloud(jl) = 0.
    END DO

    DO jk = 1, kflev
       jkp1 = jk + 1
       jkl = kflev + 1 - jk
       DO jl = 1, kdlon
          zrth = (rth2o / ptave(jl, jk))**rtdh2o
          zrtu = (rtumg / ptave(jl, jk))**rtdumg
          zwh2o = max(pwv(jl, jk), zepscq)
          zsign(jl) = 100. * ppmb(jl, jkp1)
          pdsig(jl, jk) = (zsigo(jl) - zsign(jl)) / ppsol(jl)
          zn175(jl) = zsign(jl)**(zpdumg + 1.)
          zn190(jl) = zsign(jl)**(zpdh2o + 1.)
          zdsco2 = zo175(jl) - zn175(jl)
          zdsh2o = zo190(jl) - zn190(jl)
          pud(jl, 1, jk) = 1. / (10. * rg * (zpdh2o + 1.)) / zprh2o**zpdh2o &
               * zdsh2o * zwh2o * zrth
          pud(jl, 2, jk) = 1. / (10. * rg * (zpdumg + 1.)) / zprumg**zpdumg &
               * zdsco2 * rco2 * zrtu
          zfppw = 1.6078 * zwh2o / (1. + 0.608 * zwh2o)
          pud(jl, 4, jk) = pud(jl, 1, jk) * zfppw
          pud(jl, 5, jk) = pud(jl, 1, jk) * (1. - zfppw)
          zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
          zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
          zsigo(jl) = zsign(jl)
          zo175(jl) = zn175(jl)
          zo190(jl) = zn190(jl)

          IF (novlp==1) THEN
             zclear(jl) = zclear(jl) &
                  * (1. - max(pcldsw(jl, jkl), zcloud(jl))) &
                  / (1. - min(zcloud(jl), 1. - zepsec))
             zc1j(jl, jkl) = 1.0 - zclear(jl)
             zcloud(jl) = pcldsw(jl, jkl)
          ELSE IF (novlp==2) THEN
             zcloud(jl) = max(pcldsw(jl, jkl), zcloud(jl))
             zc1j(jl, jkl) = zcloud(jl)
          ELSE IF (novlp==3) THEN
             zclear(jl) = zclear(jl) * (1. - pcldsw(jl, jkl))
             zcloud(jl) = 1.0 - zclear(jl)
             zc1j(jl, jkl) = zcloud(jl)
          END IF
       END DO
    END DO
    DO jl = 1, kdlon
       pclear(jl) = 1. - zc1j(jl, 1)
    END DO
    DO jk = 1, kflev
       DO jl = 1, kdlon
          IF (pclear(jl)<1.) THEN
             pcld(jl, jk) = pcldsw(jl, jk) / (1. - pclear(jl))
          ELSE
             pcld(jl, jk) = 0.
          END IF
       END DO
    END DO

    ! 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS

    DO ja = 1, 2
       DO jl = 1, kdlon
          zud(jl, ja) = zud(jl, ja) * psec(jl)
       END DO
    END DO

    CALL swtt1(2, 2, iind, zud, zr)

    DO ja = 1, 2
       DO jl = 1, kdlon
          paki(jl, ja) = - log(zr(jl, ja)) / zud(jl, ja)
       END DO
    END DO

  END SUBROUTINE swu

end module swu_m
1	guez	220	module swu_m
2	guez	118
3	guez	81	IMPLICIT NONE
4
5	guez	220	contains
6	guez	81
7	guez	220	SUBROUTINE swu(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, paki, &
8			pcld, pclear, pdsig, pfact, prmu, psec, pud)
9	guez	81
10	guez	220	USE clesphys, only: rco2
11			USE suphec_m, only: rg
12			USE raddim, only: kdlon, kflev
13			USE radepsi, only: zepscq, zepsec
14			USE radopt, only: novlp
15	guez	81
16	guez	220	! ARGUMENTS:
17	guez	81
18	guez	220	DOUBLE PRECISION, intent(in):: psct
19			DOUBLE PRECISION, intent(in):: pcldsw(kdlon, kflev)
20			DOUBLE PRECISION, intent(in):: ppmb(kdlon, kflev + 1)
21			DOUBLE PRECISION, intent(in):: ppsol(kdlon)
22			DOUBLE PRECISION, intent(in):: prmu0(kdlon)
23			DOUBLE PRECISION, intent(in):: pfrac(kdlon)
24			DOUBLE PRECISION, intent(in):: ptave(kdlon, kflev)
25			DOUBLE PRECISION, intent(in):: pwv(kdlon, kflev)
26	guez	81
27	guez	220	DOUBLE PRECISION paki(kdlon, 2)
28			DOUBLE PRECISION pcld(kdlon, kflev)
29			DOUBLE PRECISION pclear(kdlon)
30			DOUBLE PRECISION pdsig(kdlon, kflev)
31			DOUBLE PRECISION pfact(kdlon)
32			DOUBLE PRECISION prmu(kdlon)
33			DOUBLE PRECISION psec(kdlon)
34			DOUBLE PRECISION pud(kdlon, 5, kflev + 1)
35	guez	81
36	guez	220	! Local:
37	guez	81
38	guez	220	INTEGER iind(2)
39			DOUBLE PRECISION zc1j(kdlon, kflev + 1)
40			DOUBLE PRECISION zclear(kdlon)
41			DOUBLE PRECISION zcloud(kdlon)
42			DOUBLE PRECISION zn175(kdlon)
43			DOUBLE PRECISION zn190(kdlon)
44			DOUBLE PRECISION zo175(kdlon)
45			DOUBLE PRECISION zo190(kdlon)
46			DOUBLE PRECISION zsign(kdlon)
47			DOUBLE PRECISION zr(kdlon, 2)
48			DOUBLE PRECISION zsigo(kdlon)
49			DOUBLE PRECISION zud(kdlon, 2)
50			DOUBLE PRECISION zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
51			INTEGER jl, jk, jkp1, jkl, ja
52	guez	81
53	guez	220	! Prescribed Data:
54	guez	81
55	guez	220	DOUBLE PRECISION zpdh2o, zpdumg
56			SAVE zpdh2o, zpdumg
57			DOUBLE PRECISION zprh2o, zprumg
58			SAVE zprh2o, zprumg
59			DOUBLE PRECISION rtdh2o, rtdumg
60			SAVE rtdh2o, rtdumg
61			DOUBLE PRECISION rth2o, rtumg
62			SAVE rth2o, rtumg
63			DATA zpdh2o, zpdumg /0.8d0, 0.75d0/
64			DATA zprh2o, zprumg /30000.d0, 30000.d0/
65			DATA rtdh2o, rtdumg /0.40d0, 0.375d0/
66			DATA rth2o, rtumg /240.d0, 240.d0/
67	guez	81
68	guez	220	!------------------------------------------------------------------
69	guez	81
70	guez	220	! 1. COMPUTES AMOUNTS OF ABSORBERS
71	guez	81
72	guez	220	iind(1) = 1
73			iind(2) = 2
74	guez	81
75	guez	220	! 1.1 INITIALIZES QUANTITIES
76	guez	81
77	guez	220	DO jl = 1, kdlon
78			pud(jl, 1, kflev + 1) = 0.
79			pud(jl, 2, kflev + 1) = 0.
80			pud(jl, 3, kflev + 1) = 0.
81			pud(jl, 4, kflev + 1) = 0.
82			pud(jl, 5, kflev + 1) = 0.
83			pfact(jl) = prmu0(jl) * pfrac(jl) * psct
84			prmu(jl) = sqrt(1224. * prmu0(jl) * prmu0(jl) + 1.) / 35.
85			psec(jl) = 1. / prmu(jl)
86			zc1j(jl, kflev + 1) = 0.
87			END DO
88	guez	81
89	guez	220	! 1.3 AMOUNTS OF ABSORBERS
90	guez	81
91			DO jl = 1, kdlon
92	guez	220	zud(jl, 1) = 0.
93			zud(jl, 2) = 0.
94			zo175(jl) = ppsol(jl)**(zpdumg + 1.)
95			zo190(jl) = ppsol(jl)**(zpdh2o + 1.)
96			zsigo(jl) = ppsol(jl)
97			zclear(jl) = 1.
98			zcloud(jl) = 0.
99			END DO
100	guez	81
101	guez	220	DO jk = 1, kflev
102			jkp1 = jk + 1
103			jkl = kflev + 1 - jk
104			DO jl = 1, kdlon
105			zrth = (rth2o / ptave(jl, jk))**rtdh2o
106			zrtu = (rtumg / ptave(jl, jk))**rtdumg
107			zwh2o = max(pwv(jl, jk), zepscq)
108			zsign(jl) = 100. * ppmb(jl, jkp1)
109			pdsig(jl, jk) = (zsigo(jl) - zsign(jl)) / ppsol(jl)
110			zn175(jl) = zsign(jl)**(zpdumg + 1.)
111			zn190(jl) = zsign(jl)**(zpdh2o + 1.)
112			zdsco2 = zo175(jl) - zn175(jl)
113			zdsh2o = zo190(jl) - zn190(jl)
114			pud(jl, 1, jk) = 1. / (10. * rg * (zpdh2o + 1.)) / zprh2o**zpdh2o &
115			* zdsh2o * zwh2o * zrth
116			pud(jl, 2, jk) = 1. / (10. * rg * (zpdumg + 1.)) / zprumg**zpdumg &
117			* zdsco2 * rco2 * zrtu
118			zfppw = 1.6078 * zwh2o / (1. + 0.608 * zwh2o)
119			pud(jl, 4, jk) = pud(jl, 1, jk) * zfppw
120			pud(jl, 5, jk) = pud(jl, 1, jk) * (1. - zfppw)
121			zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
122			zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
123			zsigo(jl) = zsign(jl)
124			zo175(jl) = zn175(jl)
125			zo190(jl) = zn190(jl)
126
127			IF (novlp==1) THEN
128			zclear(jl) = zclear(jl) &
129			* (1. - max(pcldsw(jl, jkl), zcloud(jl))) &
130			/ (1. - min(zcloud(jl), 1. - zepsec))
131			zc1j(jl, jkl) = 1.0 - zclear(jl)
132			zcloud(jl) = pcldsw(jl, jkl)
133			ELSE IF (novlp==2) THEN
134			zcloud(jl) = max(pcldsw(jl, jkl), zcloud(jl))
135			zc1j(jl, jkl) = zcloud(jl)
136			ELSE IF (novlp==3) THEN
137			zclear(jl) = zclear(jl) * (1. - pcldsw(jl, jkl))
138			zcloud(jl) = 1.0 - zclear(jl)
139			zc1j(jl, jkl) = zcloud(jl)
140			END IF
141			END DO
142	guez	81	END DO
143			DO jl = 1, kdlon
144	guez	220	pclear(jl) = 1. - zc1j(jl, 1)
145	guez	81	END DO
146	guez	220	DO jk = 1, kflev
147			DO jl = 1, kdlon
148			IF (pclear(jl)<1.) THEN
149			pcld(jl, jk) = pcldsw(jl, jk) / (1. - pclear(jl))
150			ELSE
151			pcld(jl, jk) = 0.
152			END IF
153			END DO
154			END DO
155	guez	81
156	guez	220	! 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
157	guez	81
158	guez	220	DO ja = 1, 2
159			DO jl = 1, kdlon
160			zud(jl, ja) = zud(jl, ja) * psec(jl)
161			END DO
162			END DO
163	guez	81
164	guez	220	CALL swtt1(2, 2, iind, zud, zr)
165	guez	81
166	guez	220	DO ja = 1, 2
167			DO jl = 1, kdlon
168			paki(jl, ja) = - log(zr(jl, ja)) / zud(jl, ja)
169			END DO
170	guez	81	END DO
171
172	guez	220	END SUBROUTINE swu
173	guez	81
174	guez	220	end module swu_m