phylmd/Radlwsw/lwvd.f

module lwvd_m

  IMPLICIT NONE

contains

  SUBROUTINE lwvd(ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, pdisu)
    USE dimensions
    USE dimphy
    USE raddim
    USE raddimlw

    ! -----------------------------------------------------------------------
    ! PURPOSE.
    ! --------
    ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS

    ! METHOD.
    ! -------

    ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
    ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE

    ! 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 : 89-07-14
    ! -----------------------------------------------------------------------
    ! * ARGUMENTS:

    INTEGER ktraer

    DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
    DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
    DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
    DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS

    DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
    DOUBLE PRECISION pdisd(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
    DOUBLE PRECISION pdisu(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS

    ! * LOCAL VARIABLES:

    DOUBLE PRECISION zglayd(kdlon)
    DOUBLE PRECISION zglayu(kdlon)
    DOUBLE PRECISION ztt(kdlon, ntra)
    DOUBLE PRECISION ztt1(kdlon, ntra)
    DOUBLE PRECISION ztt2(kdlon, ntra)

    INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
    INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
    INTEGER itt
    DOUBLE PRECISION zww, zdzxdg, zdzxmg

    ! *         1.    INITIALIZATION
    ! --------------


    ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
    ! ------------------------------


    DO jk = 1, kflev + 1
       DO jl = 1, kdlon
          pdisd(jl, jk) = 0.
          pdisu(jl, jk) = 0.
       END DO
    END DO

    ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
    ! ---------------------------------


    DO ja = 1, ntra
       DO jl = 1, kdlon
          ztt(jl, ja) = 1.0
          ztt1(jl, ja) = 1.0
          ztt2(jl, ja) = 1.0
       END DO
    END DO

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

    ! *         2.      VERTICAL INTEGRATION
    ! --------------------

    ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
    ! ---------------------------------


    ! *         2.2.1   DISTANT AND ABOVE LAYERS
    ! ------------------------


    ! *         2.2.2   FIRST UPPER LEVEL
    ! -----------------


    DO jk = 1, kflev - 1
       ikp1 = jk + 1
       ikn = (jk-1)*ng1p1 + 1
       ikd1 = jk*ng1p1 + 1

       CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
            ztt1)


       ! *         2.2.3   HIGHER UP
       ! ---------


       itt = 1
       DO jkj = ikp1, kflev
          IF (itt==1) THEN
             itt = 2
          ELSE
             itt = 1
          END IF
          ikjp1 = jkj + 1
          ikd2 = jkj*ng1p1 + 1

          IF (itt==1) THEN
             CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
                  pabcu(1,1,ikd2), ztt1)
          ELSE
             CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
                  pabcu(1,1,ikd2), ztt2)
          END IF

          DO ja = 1, ktraer
             DO jl = 1, kdlon
                ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
             END DO
          END DO

          DO jl = 1, kdlon
             zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
                  pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
                  pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
                  pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
                  pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
                  pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
             zglayd(jl) = zww
             zdzxdg = zglayd(jl)
             pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
             pcntrb(jl, jk, ikjp1) = zdzxdg
          END DO


       END DO
    END DO


    ! *         2.2.4   DISTANT AND BELOW LAYERS
    ! ------------------------


    ! *         2.2.5   FIRST LOWER LEVEL
    ! -----------------


    DO jk = 3, kflev + 1
       ikn = (jk-1)*ng1p1 + 1
       ikm1 = jk - 1
       ikj = jk - 2
       iku1 = ikj*ng1p1 + 1


       CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
            pabcu(1,1,ikn), ztt1)


       ! *         2.2.6   DOWN BELOW
       ! ----------


       itt = 1
       DO jlk = 1, ikj
          IF (itt==1) THEN
             itt = 2
          ELSE
             itt = 1
          END IF
          ijkl = ikm1 - jlk
          iku2 = (ijkl-1)*ng1p1 + 1


          IF (itt==1) THEN
             CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
                  pabcu(1,1,ikn), ztt1)
          ELSE
             CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
                  pabcu(1,1,ikn), ztt2)
          END IF

          DO ja = 1, ktraer
             DO jl = 1, kdlon
                ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
             END DO
          END DO

          DO jl = 1, kdlon
             zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
                  pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
                  pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
                  pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
                  pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
                  pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
             zglayu(jl) = zww
             zdzxmg = zglayu(jl)
             pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
             pcntrb(jl, jk, ijkl) = zdzxmg
          END DO


       END DO
    END DO

    RETURN
  END SUBROUTINE lwvd

end module lwvd_m
1	guez	155	module lwvd_m
2
3	guez	81	IMPLICIT NONE
4
5	guez	155	contains
6	guez	81
7	guez	155	SUBROUTINE lwvd(ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, pdisu)
8	guez	265	USE dimensions
9	guez	155	USE dimphy
10			USE raddim
11			USE raddimlw
12	guez	81
13	guez	155	! -----------------------------------------------------------------------
14			! PURPOSE.
15			! --------
16			! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
17	guez	81
18	guez	155	! METHOD.
19			! -------
20	guez	81
21	guez	155	! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
22			! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
23	guez	81
24	guez	155	! REFERENCE.
25			! ----------
26	guez	81
27	guez	155	! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29	guez	81
30	guez	155	! AUTHOR.
31			! -------
32			! JEAN-JACQUES MORCRETTE ECMWF
33	guez	81
34	guez	155	! MODIFICATIONS.
35			! --------------
36			! ORIGINAL : 89-07-14
37			! -----------------------------------------------------------------------
38			! * ARGUMENTS:
39	guez	81
40	guez	155	INTEGER ktraer
41	guez	81
42	guez	155	DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
43			DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
44			DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
45			DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46	guez	81
47	guez	155	DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
48			DOUBLE PRECISION pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
49			DOUBLE PRECISION pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
50	guez	81
51	guez	155	! * LOCAL VARIABLES:
52	guez	81
53	guez	155	DOUBLE PRECISION zglayd(kdlon)
54			DOUBLE PRECISION zglayu(kdlon)
55			DOUBLE PRECISION ztt(kdlon, ntra)
56			DOUBLE PRECISION ztt1(kdlon, ntra)
57			DOUBLE PRECISION ztt2(kdlon, ntra)
58	guez	81
59	guez	155	INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
60			INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
61	guez	178	INTEGER itt
62	guez	155	DOUBLE PRECISION zww, zdzxdg, zdzxmg
63	guez	81
64	guez	155	! * 1. INITIALIZATION
65			! --------------
66	guez	81
67
68	guez	155	! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
69			! ------------------------------
70
71
72			DO jk = 1, kflev + 1
73			DO jl = 1, kdlon
74			pdisd(jl, jk) = 0.
75			pdisu(jl, jk) = 0.
76			END DO
77	guez	81	END DO
78
79	guez	155	! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
80			! ---------------------------------
81	guez	81
82
83
84	guez	155	DO ja = 1, ntra
85			DO jl = 1, kdlon
86			ztt(jl, ja) = 1.0
87			ztt1(jl, ja) = 1.0
88			ztt2(jl, ja) = 1.0
89			END DO
90	guez	81	END DO
91
92	guez	155	! ------------------------------------------------------------------
93	guez	81
94	guez	155	! * 2. VERTICAL INTEGRATION
95			! --------------------
96	guez	81
97	guez	155	! * 2.2 CONTRIBUTION FROM DISTANT LAYERS
98			! ---------------------------------
99	guez	81
100
101
102	guez	155	! * 2.2.1 DISTANT AND ABOVE LAYERS
103			! ------------------------
104	guez	81
105
106
107
108	guez	155	! * 2.2.2 FIRST UPPER LEVEL
109			! -----------------
110	guez	81
111
112	guez	155	DO jk = 1, kflev - 1
113			ikp1 = jk + 1
114			ikn = (jk-1)*ng1p1 + 1
115			ikd1 = jk*ng1p1 + 1
116	guez	81
117	guez	155	CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
118			ztt1)
119	guez	81
120
121
122	guez	155	! * 2.2.3 HIGHER UP
123			! ---------
124	guez	81
125
126	guez	155	itt = 1
127			DO jkj = ikp1, kflev
128			IF (itt==1) THEN
129			itt = 2
130			ELSE
131			itt = 1
132			END IF
133			ikjp1 = jkj + 1
134			ikd2 = jkj*ng1p1 + 1
135	guez	81
136	guez	155	IF (itt==1) THEN
137			CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
138			pabcu(1,1,ikd2), ztt1)
139			ELSE
140			CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
141			pabcu(1,1,ikd2), ztt2)
142			END IF
143	guez	81
144	guez	155	DO ja = 1, ktraer
145			DO jl = 1, kdlon
146			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
147			END DO
148			END DO
149	guez	81
150	guez	155	DO jl = 1, kdlon
151			zww = pdbdt(jl, 1, jkj)ztt(jl, 1)ztt(jl, 10) + &
152			pdbdt(jl, 2, jkj)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
153			pdbdt(jl, 3, jkj)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
154			pdbdt(jl, 4, jkj)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
155			pdbdt(jl, 5, jkj)ztt(jl, 3)ztt(jl, 14) + &
156			pdbdt(jl, 6, jkj)ztt(jl, 6)ztt(jl, 15)
157			zglayd(jl) = zww
158			zdzxdg = zglayd(jl)
159			pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
160			pcntrb(jl, jk, ikjp1) = zdzxdg
161			END DO
162	guez	81
163
164	guez	155	END DO
165	guez	81	END DO
166
167
168	guez	155	! * 2.2.4 DISTANT AND BELOW LAYERS
169			! ------------------------
170	guez	81
171
172
173
174	guez	155	! * 2.2.5 FIRST LOWER LEVEL
175			! -----------------
176	guez	81
177
178	guez	155	DO jk = 3, kflev + 1
179			ikn = (jk-1)*ng1p1 + 1
180			ikm1 = jk - 1
181			ikj = jk - 2
182			iku1 = ikj*ng1p1 + 1
183	guez	81
184
185	guez	155	CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
186			pabcu(1,1,ikn), ztt1)
187	guez	81
188
189
190	guez	155	! * 2.2.6 DOWN BELOW
191			! ----------
192	guez	81
193
194	guez	155	itt = 1
195			DO jlk = 1, ikj
196			IF (itt==1) THEN
197			itt = 2
198			ELSE
199			itt = 1
200			END IF
201			ijkl = ikm1 - jlk
202			iku2 = (ijkl-1)*ng1p1 + 1
203	guez	81
204
205	guez	155	IF (itt==1) THEN
206			CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
207			pabcu(1,1,ikn), ztt1)
208			ELSE
209			CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
210			pabcu(1,1,ikn), ztt2)
211			END IF
212	guez	81
213	guez	155	DO ja = 1, ktraer
214			DO jl = 1, kdlon
215			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
216			END DO
217			END DO
218	guez	81
219	guez	155	DO jl = 1, kdlon
220			zww = pdbdt(jl, 1, ijkl)ztt(jl, 1)ztt(jl, 10) + &
221			pdbdt(jl, 2, ijkl)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
222			pdbdt(jl, 3, ijkl)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
223			pdbdt(jl, 4, ijkl)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
224			pdbdt(jl, 5, ijkl)ztt(jl, 3)ztt(jl, 14) + &
225			pdbdt(jl, 6, ijkl)ztt(jl, 6)ztt(jl, 15)
226			zglayu(jl) = zww
227			zdzxmg = zglayu(jl)
228			pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
229			pcntrb(jl, jk, ijkl) = zdzxmg
230			END DO
231	guez	81
232
233	guez	155	END DO
234	guez	81	END DO
235
236	guez	155	RETURN
237			END SUBROUTINE lwvd
238
239			end module lwvd_m