phylmd/Radlwsw/lwvd.f

module lwvd_m

  IMPLICIT NONE

contains

  SUBROUTINE lwvd(ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, pdisu)
    USE dimens_m
    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 ind1, ind2, ind3, ind4, 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
    ! --------------------


    ind1 = 0
    ind3 = 0
    ind4 = 1
    ind2 = 1


    ! *         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			USE dimens_m
9			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			INTEGER ind1, ind2, ind3, ind4, itt
62			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
98	guez	155	ind1 = 0
99			ind3 = 0
100			ind4 = 1
101			ind2 = 1
102	guez	81
103
104	guez	155	! * 2.2 CONTRIBUTION FROM DISTANT LAYERS
105			! ---------------------------------
106	guez	81
107
108
109	guez	155	! * 2.2.1 DISTANT AND ABOVE LAYERS
110			! ------------------------
111	guez	81
112
113
114
115	guez	155	! * 2.2.2 FIRST UPPER LEVEL
116			! -----------------
117	guez	81
118
119	guez	155	DO jk = 1, kflev - 1
120			ikp1 = jk + 1
121			ikn = (jk-1)*ng1p1 + 1
122			ikd1 = jk*ng1p1 + 1
123	guez	81
124	guez	155	CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
125			ztt1)
126	guez	81
127
128
129	guez	155	! * 2.2.3 HIGHER UP
130			! ---------
131	guez	81
132
133	guez	155	itt = 1
134			DO jkj = ikp1, kflev
135			IF (itt==1) THEN
136			itt = 2
137			ELSE
138			itt = 1
139			END IF
140			ikjp1 = jkj + 1
141			ikd2 = jkj*ng1p1 + 1
142	guez	81
143	guez	155	IF (itt==1) THEN
144			CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
145			pabcu(1,1,ikd2), ztt1)
146			ELSE
147			CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
148			pabcu(1,1,ikd2), ztt2)
149			END IF
150	guez	81
151	guez	155	DO ja = 1, ktraer
152			DO jl = 1, kdlon
153			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
154			END DO
155			END DO
156	guez	81
157	guez	155	DO jl = 1, kdlon
158			zww = pdbdt(jl, 1, jkj)ztt(jl, 1)ztt(jl, 10) + &
159			pdbdt(jl, 2, jkj)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
160			pdbdt(jl, 3, jkj)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
161			pdbdt(jl, 4, jkj)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
162			pdbdt(jl, 5, jkj)ztt(jl, 3)ztt(jl, 14) + &
163			pdbdt(jl, 6, jkj)ztt(jl, 6)ztt(jl, 15)
164			zglayd(jl) = zww
165			zdzxdg = zglayd(jl)
166			pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
167			pcntrb(jl, jk, ikjp1) = zdzxdg
168			END DO
169	guez	81
170
171	guez	155	END DO
172	guez	81	END DO
173
174
175	guez	155	! * 2.2.4 DISTANT AND BELOW LAYERS
176			! ------------------------
177	guez	81
178
179
180
181	guez	155	! * 2.2.5 FIRST LOWER LEVEL
182			! -----------------
183	guez	81
184
185	guez	155	DO jk = 3, kflev + 1
186			ikn = (jk-1)*ng1p1 + 1
187			ikm1 = jk - 1
188			ikj = jk - 2
189			iku1 = ikj*ng1p1 + 1
190	guez	81
191
192	guez	155	CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
193			pabcu(1,1,ikn), ztt1)
194	guez	81
195
196
197	guez	155	! * 2.2.6 DOWN BELOW
198			! ----------
199	guez	81
200
201	guez	155	itt = 1
202			DO jlk = 1, ikj
203			IF (itt==1) THEN
204			itt = 2
205			ELSE
206			itt = 1
207			END IF
208			ijkl = ikm1 - jlk
209			iku2 = (ijkl-1)*ng1p1 + 1
210	guez	81
211
212	guez	155	IF (itt==1) THEN
213			CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
214			pabcu(1,1,ikn), ztt1)
215			ELSE
216			CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
217			pabcu(1,1,ikn), ztt2)
218			END IF
219	guez	81
220	guez	155	DO ja = 1, ktraer
221			DO jl = 1, kdlon
222			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
223			END DO
224			END DO
225	guez	81
226	guez	155	DO jl = 1, kdlon
227			zww = pdbdt(jl, 1, ijkl)ztt(jl, 1)ztt(jl, 10) + &
228			pdbdt(jl, 2, ijkl)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
229			pdbdt(jl, 3, ijkl)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
230			pdbdt(jl, 4, ijkl)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
231			pdbdt(jl, 5, ijkl)ztt(jl, 3)ztt(jl, 14) + &
232			pdbdt(jl, 6, ijkl)ztt(jl, 6)ztt(jl, 15)
233			zglayu(jl) = zww
234			zdzxmg = zglayu(jl)
235			pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
236			pcntrb(jl, jk, ijkl) = zdzxmg
237			END DO
238	guez	81
239
240	guez	155	END DO
241	guez	81	END DO
242
243	guez	155	RETURN
244			END SUBROUTINE lwvd
245
246			end module lwvd_m