phylmd/Radlwsw/lwvn.f

module lwvn_m

  IMPLICIT NONE

contains

  SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
    USE dimens_m
    USE dimphy
    USE raddim
    USE raddimlw
    ! -----------------------------------------------------------------------
    ! PURPOSE.
    ! --------
    ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
    ! TO GIVE LONGWAVE FLUXES OR RADIANCES

    ! METHOD.
    ! -------

    ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
    ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE

    ! 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 kuaer

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

    DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
    DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
    DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
    DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT

    ! * LOCAL ARRAYS:

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

    INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
    INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
    DOUBLE PRECISION zwtr

    ! * Data Block:

    DOUBLE PRECISION wg1(2)
    SAVE wg1
    DATA (wg1(jk), jk=1, 2)/1.0, 1.0/
    ! -----------------------------------------------------------------------

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


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


    DO jk = 1, kflev + 1
       DO jl = 1, kdlon
          padjd(jl, jk) = 0.
          padju(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

    DO ja = 1, nua
       DO jl = 1, kdlon
          zuu(jl, ja) = 0.
       END DO
    END DO

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

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


    ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
    ! ---------------------------------


    DO jk = 1, kflev

       ! *         2.1.1   DOWNWARD LAYERS
       ! ---------------


       im12 = 2*(jk-1)
       ind = (jk-1)*ng1p1 + 1
       ixd = ind
       inu = jk*ng1p1 + 1
       ixu = ind

       DO jl = 1, kdlon
          zglayd(jl) = 0.
          zglayu(jl) = 0.
       END DO

       DO jg = 1, ng1
          ibs = im12 + jg
          idd = ixd + jg
          DO ja = 1, kuaer
             DO jl = 1, kdlon
                zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
             END DO
          END DO


          CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)

          DO jl = 1, kdlon
             zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
                  pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
                  pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
                  pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
                  pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
                  pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
             zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
          END DO

          ! *         2.1.2   DOWNWARD LAYERS
          ! ---------------


          imu = ixu + jg
          DO ja = 1, kuaer
             DO jl = 1, kdlon
                zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
             END DO
          END DO


          CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)

          DO jl = 1, kdlon
             zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
                  pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
                  pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
                  pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
                  pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
                  pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
             zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
          END DO

       END DO

       DO jl = 1, kdlon
          padjd(jl, jk) = zglayd(jl)
          pcntrb(jl, jk, jk+1) = zglayd(jl)
          padju(jl, jk+1) = zglayu(jl)
          pcntrb(jl, jk+1, jk) = zglayu(jl)
          pcntrb(jl, jk, jk) = 0.0
       END DO
    END DO

    DO jk = 1, kflev
       jk2 = 2*jk
       jk1 = jk2 - 1
       DO jnu = 1, ninter
          DO jl = 1, kdlon
             pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
          END DO
       END DO
    END DO

  END SUBROUTINE lwvn

end module lwvn_m
1	guez	166	module lwvn_m
2
3	guez	81	IMPLICIT NONE
4
5	guez	166	contains
6	guez	81
7	guez	166	SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
8			USE dimens_m
9			USE dimphy
10			USE raddim
11			USE raddimlw
12			! -----------------------------------------------------------------------
13			! PURPOSE.
14			! --------
15			! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
16			! TO GIVE LONGWAVE FLUXES OR RADIANCES
17	guez	81
18	guez	166	! METHOD.
19			! -------
20	guez	81
21	guez	166	! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
22			! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
23	guez	81
24	guez	166	! REFERENCE.
25			! ----------
26	guez	81
27	guez	166	! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29	guez	81
30	guez	166	! AUTHOR.
31			! -------
32			! JEAN-JACQUES MORCRETTE ECMWF
33	guez	81
34	guez	166	! MODIFICATIONS.
35			! --------------
36			! ORIGINAL : 89-07-14
37			! -----------------------------------------------------------------------
38	guez	81
39	guez	166	! * ARGUMENTS:
40	guez	81
41	guez	166	INTEGER kuaer
42	guez	81
43	guez	166	DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
44			DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
45			DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46			DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
47	guez	81
48	guez	166	DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
49			DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
50			DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
51			DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
52	guez	81
53	guez	166	! * LOCAL ARRAYS:
54	guez	81
55	guez	166	DOUBLE PRECISION zglayd(kdlon)
56			DOUBLE PRECISION zglayu(kdlon)
57			DOUBLE PRECISION ztt(kdlon, ntra)
58			DOUBLE PRECISION ztt1(kdlon, ntra)
59			DOUBLE PRECISION ztt2(kdlon, ntra)
60			DOUBLE PRECISION zuu(kdlon, nua)
61	guez	81
62	guez	166	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
63			INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
64			DOUBLE PRECISION zwtr
65	guez	81
66	guez	166	! * Data Block:
67	guez	81
68	guez	166	DOUBLE PRECISION wg1(2)
69			SAVE wg1
70			DATA (wg1(jk), jk=1, 2)/1.0, 1.0/
71			! -----------------------------------------------------------------------
72	guez	81
73	guez	166	! * 1. INITIALIZATION
74			! --------------
75	guez	81
76
77	guez	166	! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
78			! ------------------------------
79	guez	81
80	guez	166
81			DO jk = 1, kflev + 1
82			DO jl = 1, kdlon
83			padjd(jl, jk) = 0.
84			padju(jl, jk) = 0.
85			END DO
86	guez	81	END DO
87
88	guez	166	! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
89			! ---------------------------------
90	guez	81
91
92	guez	166	DO ja = 1, ntra
93			DO jl = 1, kdlon
94			ztt(jl, ja) = 1.0
95			ztt1(jl, ja) = 1.0
96			ztt2(jl, ja) = 1.0
97			END DO
98	guez	81	END DO
99
100	guez	166	DO ja = 1, nua
101			DO jl = 1, kdlon
102			zuu(jl, ja) = 0.
103			END DO
104	guez	81	END DO
105
106	guez	166	! ------------------------------------------------------------------
107	guez	81
108	guez	166	! * 2. VERTICAL INTEGRATION
109			! --------------------
110	guez	81
111
112
113	guez	166	! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS
114			! ---------------------------------
115	guez	81
116
117	guez	166	DO jk = 1, kflev
118	guez	81
119	guez	166	! * 2.1.1 DOWNWARD LAYERS
120			! ---------------
121	guez	81
122
123	guez	166	im12 = 2*(jk-1)
124			ind = (jk-1)*ng1p1 + 1
125			ixd = ind
126			inu = jk*ng1p1 + 1
127			ixu = ind
128	guez	81
129	guez	166	DO jl = 1, kdlon
130			zglayd(jl) = 0.
131			zglayu(jl) = 0.
132			END DO
133	guez	81
134	guez	166	DO jg = 1, ng1
135			ibs = im12 + jg
136			idd = ixd + jg
137			DO ja = 1, kuaer
138			DO jl = 1, kdlon
139			zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
140			END DO
141			END DO
142	guez	81
143
144	guez	166	CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
145	guez	81
146	guez	166	DO jl = 1, kdlon
147			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
148			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
149			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
150			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
151			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
152			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
153			zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
154			END DO
155	guez	81
156	guez	166	! * 2.1.2 DOWNWARD LAYERS
157			! ---------------
158	guez	81
159
160	guez	166	imu = ixu + jg
161			DO ja = 1, kuaer
162			DO jl = 1, kdlon
163			zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
164			END DO
165			END DO
166	guez	81
167
168	guez	166	CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
169	guez	81
170	guez	166	DO jl = 1, kdlon
171			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
172			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
173			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
174			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
175			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
176			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
177			zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
178			END DO
179	guez	81
180	guez	166	END DO
181
182			DO jl = 1, kdlon
183			padjd(jl, jk) = zglayd(jl)
184			pcntrb(jl, jk, jk+1) = zglayd(jl)
185			padju(jl, jk+1) = zglayu(jl)
186			pcntrb(jl, jk+1, jk) = zglayu(jl)
187			pcntrb(jl, jk, jk) = 0.0
188			END DO
189	guez	81	END DO
190
191	guez	166	DO jk = 1, kflev
192			jk2 = 2*jk
193			jk1 = jk2 - 1
194			DO jnu = 1, ninter
195			DO jl = 1, kdlon
196			pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
197			END DO
198			END DO
199	guez	81	END DO
200
201	guez	166	END SUBROUTINE lwvn
202	guez	81
203	guez	166	end module lwvn_m