phylmd/Radlwsw/lwvn.f90

module lwvn_m

  IMPLICIT NONE

contains

  SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
    USE dimensions
    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 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)/1d0, 1d0/
    ! -----------------------------------------------------------------------

    ! *         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
       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	guez	265	USE dimensions
9	guez	166	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 zuu(kdlon, nua)
59	guez	81
60	guez	166	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
61			INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
62			DOUBLE PRECISION zwtr
63	guez	81
64	guez	166	! * Data Block:
65	guez	81
66	guez	166	DOUBLE PRECISION wg1(2)
67			SAVE wg1
68	guez	178	DATA (wg1(jk), jk=1, 2)/1d0, 1d0/
69	guez	166	! -----------------------------------------------------------------------
70	guez	81
71	guez	166	! * 1. INITIALIZATION
72			! --------------
73	guez	81
74
75	guez	166	! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
76			! ------------------------------
77	guez	81
78	guez	166
79			DO jk = 1, kflev + 1
80			DO jl = 1, kdlon
81			padjd(jl, jk) = 0.
82			padju(jl, jk) = 0.
83			END DO
84	guez	81	END DO
85
86	guez	166	! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
87			! ---------------------------------
88	guez	81
89
90	guez	166	DO ja = 1, ntra
91			DO jl = 1, kdlon
92			ztt(jl, ja) = 1.0
93			END DO
94	guez	81	END DO
95
96	guez	166	DO ja = 1, nua
97			DO jl = 1, kdlon
98			zuu(jl, ja) = 0.
99			END DO
100	guez	81	END DO
101
102	guez	166	! ------------------------------------------------------------------
103	guez	81
104	guez	166	! * 2. VERTICAL INTEGRATION
105			! --------------------
106	guez	81
107
108
109	guez	166	! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS
110			! ---------------------------------
111	guez	81
112
113	guez	166	DO jk = 1, kflev
114	guez	81
115	guez	166	! * 2.1.1 DOWNWARD LAYERS
116			! ---------------
117	guez	81
118
119	guez	166	im12 = 2*(jk-1)
120			ind = (jk-1)*ng1p1 + 1
121			ixd = ind
122			inu = jk*ng1p1 + 1
123			ixu = ind
124	guez	81
125	guez	166	DO jl = 1, kdlon
126			zglayd(jl) = 0.
127			zglayu(jl) = 0.
128			END DO
129	guez	81
130	guez	166	DO jg = 1, ng1
131			ibs = im12 + jg
132			idd = ixd + jg
133			DO ja = 1, kuaer
134			DO jl = 1, kdlon
135			zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
136			END DO
137			END DO
138	guez	81
139
140	guez	166	CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
141	guez	81
142	guez	166	DO jl = 1, kdlon
143			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
144			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
145			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
146			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
147			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
148			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
149			zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
150			END DO
151	guez	81
152	guez	166	! * 2.1.2 DOWNWARD LAYERS
153			! ---------------
154	guez	81
155
156	guez	166	imu = ixu + jg
157			DO ja = 1, kuaer
158			DO jl = 1, kdlon
159			zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
160			END DO
161			END DO
162	guez	81
163
164	guez	166	CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
165	guez	81
166	guez	166	DO jl = 1, kdlon
167			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
168			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
169			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
170			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
171			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
172			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
173			zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
174			END DO
175	guez	81
176	guez	166	END DO
177
178			DO jl = 1, kdlon
179			padjd(jl, jk) = zglayd(jl)
180			pcntrb(jl, jk, jk+1) = zglayd(jl)
181			padju(jl, jk+1) = zglayu(jl)
182			pcntrb(jl, jk+1, jk) = zglayu(jl)
183			pcntrb(jl, jk, jk) = 0.0
184			END DO
185	guez	81	END DO
186
187	guez	166	DO jk = 1, kflev
188			jk2 = 2*jk
189			jk1 = jk2 - 1
190			DO jnu = 1, ninter
191			DO jl = 1, kdlon
192			pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
193			END DO
194			END DO
195	guez	81	END DO
196
197	guez	166	END SUBROUTINE lwvn
198	guez	81
199	guez	166	end module lwvn_m