phylmd/Radlwsw/lwvn.f

      SUBROUTINE LWVN(KUAER,KTRAER
     R  , PABCU,PDBSL,PGA,PGB
     S  , PADJD,PADJU,PCNTRB,PDBDT)
      use dimens_m
      use dimphy
      use raddim
            use raddimlw
      IMPLICIT none
C
C-----------------------------------------------------------------------
C     PURPOSE.
C     --------
C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
C           TO GIVE LONGWAVE FLUXES OR RADIANCES
C
C     METHOD.
C     -------
C
C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
C
C     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C-----------------------------------------------------------------------
C
C* ARGUMENTS:
C
      INTEGER KUAER,KTRAER
C
      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
      REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
C
      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
      REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
      REAL*8 PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT
C
C* LOCAL ARRAYS:
C
      REAL*8 ZGLAYD(KDLON)
      REAL*8 ZGLAYU(KDLON)
      REAL*8 ZTT(KDLON,NTRA)
      REAL*8 ZTT1(KDLON,NTRA)
      REAL*8 ZTT2(KDLON,NTRA)
      REAL*8 ZUU(KDLON,NUA)
C
      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
      REAL*8 zwtr
c
C* Data Block:
c
      REAL*8 WG1(2)
      SAVE WG1
      DATA (WG1(jk),jk=1,2) /1.0, 1.0/
C-----------------------------------------------------------------------
C
C*         1.    INITIALIZATION
C                --------------
C
 100  CONTINUE
C
C*         1.1     INITIALIZE LAYER CONTRIBUTIONS
C                  ------------------------------
C
 110  CONTINUE
C
      DO 112 JK = 1 , KFLEV+1
      DO 111 JL = 1, KDLON
      PADJD(JL,JK) = 0.
      PADJU(JL,JK) = 0.
 111  CONTINUE
 112  CONTINUE
C
C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
C                  ---------------------------------
C
 120  CONTINUE
C
      DO 122 JA = 1 , NTRA
      DO 121 JL = 1, KDLON
      ZTT (JL,JA) = 1.0
      ZTT1(JL,JA) = 1.0
      ZTT2(JL,JA) = 1.0
 121  CONTINUE
 122  CONTINUE
C
      DO 124 JA = 1 , NUA
      DO 123 JL = 1, KDLON
      ZUU(JL,JA) = 0.
 123  CONTINUE
 124  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         2.      VERTICAL INTEGRATION
C                  --------------------
C
 200  CONTINUE
C
C
C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS
C                  ---------------------------------
C
 210  CONTINUE
C
      DO 215 JK = 1 , KFLEV
C
C*         2.1.1   DOWNWARD LAYERS
C                  ---------------
C
 2110 CONTINUE
C
      IM12 = 2 * (JK - 1)
      IND = (JK - 1) * NG1P1 + 1
      IXD = IND
      INU = JK * NG1P1 + 1
      IXU = IND
C
      DO 2111 JL = 1, KDLON
      ZGLAYD(JL) = 0.
      ZGLAYU(JL) = 0.
 2111 CONTINUE
C
      DO 213 JG = 1 , NG1
      IBS = IM12 + JG
      IDD = IXD + JG
      DO 2113 JA = 1 , KUAER
      DO 2112 JL = 1, KDLON
      ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
 2112 CONTINUE
 2113 CONTINUE
C
C
      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
C
      DO 2114 JL = 1, KDLON
      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
      ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
 2114 CONTINUE
C
C*         2.1.2   DOWNWARD LAYERS
C                  ---------------
C
 2120 CONTINUE
C
      IMU = IXU + JG
      DO 2122 JA = 1 , KUAER
      DO 2121 JL = 1, KDLON
      ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
 2121 CONTINUE
 2122 CONTINUE
C
C
      CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
C
      DO 2123 JL = 1, KDLON
      ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)
     S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)
     S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)
      ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
 2123 CONTINUE
C
 213  CONTINUE
C
      DO 214 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
 214  CONTINUE
C
 215  CONTINUE
C
      DO 218 JK = 1 , KFLEV
      JK2 = 2 * JK
      JK1 = JK2 - 1
      DO 217 JNU = 1 , Ninter
      DO 216 JL = 1, KDLON
      PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
 216  CONTINUE
 217  CONTINUE
 218  CONTINUE
C
      RETURN
C
      END
1	guez	24	SUBROUTINE LWVN(KUAER,KTRAER
2			R , PABCU,PDBSL,PGA,PGB
3			S , PADJD,PADJU,PCNTRB,PDBDT)
4			use dimens_m
5			use dimphy
6			use raddim
7			use raddimlw
8			IMPLICIT none
9			C
10			C-----------------------------------------------------------------------
11			C PURPOSE.
12			C --------
13			C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
14			C TO GIVE LONGWAVE FLUXES OR RADIANCES
15			C
16			C METHOD.
17			C -------
18			C
19			C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
20			C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
21			C
22			C REFERENCE.
23			C ----------
24			C
25			C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
26			C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
27			C
28			C AUTHOR.
29			C -------
30			C JEAN-JACQUES MORCRETTE ECMWF
31			C
32			C MODIFICATIONS.
33			C --------------
34			C ORIGINAL : 89-07-14
35			C-----------------------------------------------------------------------
36			C
37			C* ARGUMENTS:
38			C
39			INTEGER KUAER,KTRAER
40			C
41			REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
42			REAL8 PDBSL(KDLON,Ninter,KFLEV2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
43			REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
44			REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
45			C
46			REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
47			REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
48			REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
49			REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
50			C
51			C* LOCAL ARRAYS:
52			C
53			REAL*8 ZGLAYD(KDLON)
54			REAL*8 ZGLAYU(KDLON)
55			REAL*8 ZTT(KDLON,NTRA)
56			REAL*8 ZTT1(KDLON,NTRA)
57			REAL*8 ZTT2(KDLON,NTRA)
58			REAL*8 ZUU(KDLON,NUA)
59			C
60			INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
61			INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
62			REAL*8 zwtr
63			c
64			C* Data Block:
65			c
66			REAL*8 WG1(2)
67			SAVE WG1
68			DATA (WG1(jk),jk=1,2) /1.0, 1.0/
69			C-----------------------------------------------------------------------
70			C
71			C* 1. INITIALIZATION
72			C --------------
73			C
74			100 CONTINUE
75			C
76			C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
77			C ------------------------------
78			C
79			110 CONTINUE
80			C
81			DO 112 JK = 1 , KFLEV+1
82			DO 111 JL = 1, KDLON
83			PADJD(JL,JK) = 0.
84			PADJU(JL,JK) = 0.
85			111 CONTINUE
86			112 CONTINUE
87			C
88			C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
89			C ---------------------------------
90			C
91			120 CONTINUE
92			C
93			DO 122 JA = 1 , NTRA
94			DO 121 JL = 1, KDLON
95			ZTT (JL,JA) = 1.0
96			ZTT1(JL,JA) = 1.0
97			ZTT2(JL,JA) = 1.0
98			121 CONTINUE
99			122 CONTINUE
100			C
101			DO 124 JA = 1 , NUA
102			DO 123 JL = 1, KDLON
103			ZUU(JL,JA) = 0.
104			123 CONTINUE
105			124 CONTINUE
106			C
107			C ------------------------------------------------------------------
108			C
109			C* 2. VERTICAL INTEGRATION
110			C --------------------
111			C
112			200 CONTINUE
113			C
114			C
115			C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
116			C ---------------------------------
117			C
118			210 CONTINUE
119			C
120			DO 215 JK = 1 , KFLEV
121			C
122			C* 2.1.1 DOWNWARD LAYERS
123			C ---------------
124			C
125			2110 CONTINUE
126			C
127			IM12 = 2 * (JK - 1)
128			IND = (JK - 1) * NG1P1 + 1
129			IXD = IND
130			INU = JK * NG1P1 + 1
131			IXU = IND
132			C
133			DO 2111 JL = 1, KDLON
134			ZGLAYD(JL) = 0.
135			ZGLAYU(JL) = 0.
136			2111 CONTINUE
137			C
138			DO 213 JG = 1 , NG1
139			IBS = IM12 + JG
140			IDD = IXD + JG
141			DO 2113 JA = 1 , KUAER
142			DO 2112 JL = 1, KDLON
143			ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
144			2112 CONTINUE
145			2113 CONTINUE
146			C
147			C
148			CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
149			C
150			DO 2114 JL = 1, KDLON
151			ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
152			S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
153			S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
154			S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
155			S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
156			S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
157			ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
158			2114 CONTINUE
159			C
160			C* 2.1.2 DOWNWARD LAYERS
161			C ---------------
162			C
163			2120 CONTINUE
164			C
165			IMU = IXU + JG
166			DO 2122 JA = 1 , KUAER
167			DO 2121 JL = 1, KDLON
168			ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
169			2121 CONTINUE
170			2122 CONTINUE
171			C
172			C
173			CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
174			C
175			DO 2123 JL = 1, KDLON
176			ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
177			S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
178			S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
179			S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
180			S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
181			S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
182			ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
183			2123 CONTINUE
184			C
185			213 CONTINUE
186			C
187			DO 214 JL = 1, KDLON
188			PADJD(JL,JK) = ZGLAYD(JL)
189			PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
190			PADJU(JL,JK+1) = ZGLAYU(JL)
191			PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
192			PCNTRB(JL,JK ,JK) = 0.0
193			214 CONTINUE
194			C
195			215 CONTINUE
196			C
197			DO 218 JK = 1 , KFLEV
198			JK2 = 2 * JK
199			JK1 = JK2 - 1
200			DO 217 JNU = 1 , Ninter
201			DO 216 JL = 1, KDLON
202			PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
203			216 CONTINUE
204			217 CONTINUE
205			218 CONTINUE
206			C
207			RETURN
208			C
209			END