/[lmdze]/trunk/Sources/phylmd/Radlwsw/lwvd.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/lwvd.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

trunk/phylmd/Radlwsw/lwvd.f revision 76 by guez, Fri Nov 15 18:45:49 2013 UTC trunk/Sources/phylmd/Radlwsw/lwvd.f revision 178 by guez, Fri Mar 11 18:47:26 2016 UTC
# Line 1  Line 1 
1        SUBROUTINE LWVD(KUAER,KTRAER  module lwvd_m
2       S  , PABCU,PDBDT  
3       R  , PGA,PGB    IMPLICIT NONE
4       S  , PCNTRB,PDISD,PDISU)  
5        use dimens_m  contains
6        use dimphy  
7        use raddim    SUBROUTINE lwvd(ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, pdisu)
8              use raddimlw      USE dimens_m
9        IMPLICIT none      USE dimphy
10  C      USE raddim
11  C-----------------------------------------------------------------------      USE raddimlw
12  C     PURPOSE.  
13  C     --------      ! -----------------------------------------------------------------------
14  C           CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS      ! PURPOSE.
15  C      ! --------
16  C     METHOD.      ! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
17  C     -------  
18  C      ! METHOD.
19  C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE      ! -------
20  C     CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE  
21  C      ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
22  C     REFERENCE.      ! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
23  C     ----------  
24  C      ! REFERENCE.
25  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND      ! ----------
26  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS  
27  C      ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28  C     AUTHOR.      ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29  C     -------  
30  C        JEAN-JACQUES MORCRETTE  *ECMWF*      ! AUTHOR.
31  C      ! -------
32  C     MODIFICATIONS.      ! JEAN-JACQUES MORCRETTE  *ECMWF*
33  C     --------------  
34  C        ORIGINAL : 89-07-14      ! MODIFICATIONS.
35  C-----------------------------------------------------------------------      ! --------------
36  C* ARGUMENTS:      ! ORIGINAL : 89-07-14
37  C      ! -----------------------------------------------------------------------
38        INTEGER KUAER,KTRAER      ! * ARGUMENTS:
39  C  
40        DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS      INTEGER ktraer
41        DOUBLE PRECISION PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT  
42        DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
43        DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
44  C      DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
45        DOUBLE PRECISION PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX      DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46        DOUBLE PRECISION PDISD(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS  
47        DOUBLE PRECISION PDISU(KDLON,KFLEV+1) !  CONTRIBUTION BY DISTANT LAYERS      DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
48  C      DOUBLE PRECISION pdisd(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
49  C* LOCAL VARIABLES:      DOUBLE PRECISION pdisu(kdlon, kflev+1) !  CONTRIBUTION BY DISTANT LAYERS
50  C  
51        DOUBLE PRECISION ZGLAYD(KDLON)      ! * LOCAL VARIABLES:
52        DOUBLE PRECISION ZGLAYU(KDLON)  
53        DOUBLE PRECISION ZTT(KDLON,NTRA)      DOUBLE PRECISION zglayd(kdlon)
54        DOUBLE PRECISION ZTT1(KDLON,NTRA)      DOUBLE PRECISION zglayu(kdlon)
55        DOUBLE PRECISION ZTT2(KDLON,NTRA)      DOUBLE PRECISION ztt(kdlon, ntra)
56  C      DOUBLE PRECISION ztt1(kdlon, ntra)
57        INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2      DOUBLE PRECISION ztt2(kdlon, ntra)
58        INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2  
59        INTEGER ind1, ind2, ind3, ind4, itt      INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
60        DOUBLE PRECISION zww, zdzxdg, zdzxmg      INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
61  C      INTEGER itt
62  C*         1.    INITIALIZATION      DOUBLE PRECISION zww, zdzxdg, zdzxmg
63  C                --------------  
64  C      ! *         1.    INITIALIZATION
65   100  CONTINUE      ! --------------
66  C  
67  C*         1.1     INITIALIZE LAYER CONTRIBUTIONS  
68  C                  ------------------------------      ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
69  C      ! ------------------------------
70   110  CONTINUE  
71  C  
72        DO 112 JK = 1, KFLEV+1      DO jk = 1, kflev + 1
73        DO 111 JL = 1, KDLON         DO jl = 1, kdlon
74        PDISD(JL,JK) = 0.            pdisd(jl, jk) = 0.
75        PDISU(JL,JK) = 0.            pdisu(jl, jk) = 0.
76    111 CONTINUE         END DO
77    112 CONTINUE      END DO
78  C  
79  C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS      ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
80  C                  ---------------------------------      ! ---------------------------------
81  C  
82   120  CONTINUE  
83  C  
84  C      DO ja = 1, ntra
85        DO 122 JA = 1, NTRA         DO jl = 1, kdlon
86        DO 121 JL = 1, KDLON            ztt(jl, ja) = 1.0
87        ZTT (JL,JA) = 1.0            ztt1(jl, ja) = 1.0
88        ZTT1(JL,JA) = 1.0            ztt2(jl, ja) = 1.0
89        ZTT2(JL,JA) = 1.0         END DO
90    121 CONTINUE      END DO
91    122 CONTINUE  
92  C      ! ------------------------------------------------------------------
93  C     ------------------------------------------------------------------  
94  C      ! *         2.      VERTICAL INTEGRATION
95  C*         2.      VERTICAL INTEGRATION      ! --------------------
96  C                  --------------------  
97  C      ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
98   200  CONTINUE      ! ---------------------------------
99  C  
100        IND1=0  
101        IND3=0  
102        IND4=1      ! *         2.2.1   DISTANT AND ABOVE LAYERS
103        IND2=1      ! ------------------------
104  C  
105  C  
106  C*         2.2     CONTRIBUTION FROM DISTANT LAYERS  
107  C                  ---------------------------------  
108  C      ! *         2.2.2   FIRST UPPER LEVEL
109   220  CONTINUE      ! -----------------
110  C  
111  C  
112  C*         2.2.1   DISTANT AND ABOVE LAYERS      DO jk = 1, kflev - 1
113  C                  ------------------------         ikp1 = jk + 1
114  C         ikn = (jk-1)*ng1p1 + 1
115   2210 CONTINUE         ikd1 = jk*ng1p1 + 1
116  C  
117  C         CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
118  C              ztt1)
119  C*         2.2.2   FIRST UPPER LEVEL  
120  C                  -----------------  
121  C  
122   2220 CONTINUE         ! *         2.2.3   HIGHER UP
123  C         ! ---------
124        DO 225 JK = 1 , KFLEV-1  
125        IKP1=JK+1  
126        IKN=(JK-1)*NG1P1+1         itt = 1
127        IKD1= JK  *NG1P1+1         DO jkj = ikp1, kflev
128  C            IF (itt==1) THEN
129        CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)               itt = 2
130       2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)            ELSE
131  C               itt = 1
132  C            END IF
133  C            ikjp1 = jkj + 1
134  C*         2.2.3   HIGHER UP            ikd2 = jkj*ng1p1 + 1
135  C                  ---------  
136  C            IF (itt==1) THEN
137   2230 CONTINUE               CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
138  C                    pabcu(1,1,ikd2), ztt1)
139        ITT=1            ELSE
140        DO 224 JKJ=IKP1,KFLEV               CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
141        IF(ITT.EQ.1) THEN                    pabcu(1,1,ikd2), ztt2)
142           ITT=2            END IF
143        ELSE  
144           ITT=1            DO ja = 1, ktraer
145        ENDIF               DO jl = 1, kdlon
146        IKJP1=JKJ+1                  ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
147        IKD2= JKJ  *NG1P1+1               END DO
148  C            END DO
149        IF(ITT.EQ.1) THEN  
150           CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)            DO jl = 1, kdlon
151       2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)               zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
152        ELSE                    pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
153           CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                    pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
154       2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)                    pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
155        ENDIF                    pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
156  C                    pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
157        DO 2235 JA = 1, KTRAER               zglayd(jl) = zww
158        DO 2234 JL = 1, KDLON               zdzxdg = zglayd(jl)
159        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5               pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
160   2234 CONTINUE               pcntrb(jl, jk, ikjp1) = zdzxdg
161   2235 CONTINUE            END DO
162  C  
163        DO 2236 JL = 1, KDLON  
164        ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)         END DO
165       S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)      END DO
166       S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)  
167       S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)  
168       S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)      ! *         2.2.4   DISTANT AND BELOW LAYERS
169       S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)      ! ------------------------
170        ZGLAYD(JL)=ZWW  
171        ZDZXDG=ZGLAYD(JL)  
172        PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG  
173        PCNTRB(JL,JK,IKJP1)=ZDZXDG  
174   2236 CONTINUE      ! *         2.2.5   FIRST LOWER LEVEL
175  C      ! -----------------
176  C  
177   224  CONTINUE  
178   225  CONTINUE      DO jk = 3, kflev + 1
179  C         ikn = (jk-1)*ng1p1 + 1
180  C         ikm1 = jk - 1
181  C*         2.2.4   DISTANT AND BELOW LAYERS         ikj = jk - 2
182  C                  ------------------------         iku1 = ikj*ng1p1 + 1
183  C  
184   2240 CONTINUE  
185  C         CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
186  C              pabcu(1,1,ikn), ztt1)
187  C  
188  C*         2.2.5   FIRST LOWER LEVEL  
189  C                  -----------------  
190  C         ! *         2.2.6   DOWN BELOW
191   2250 CONTINUE         ! ----------
192  C  
193        DO 228 JK=3,KFLEV+1  
194        IKN=(JK-1)*NG1P1+1         itt = 1
195        IKM1=JK-1         DO jlk = 1, ikj
196        IKJ=JK-2            IF (itt==1) THEN
197        IKU1= IKJ  *NG1P1+1               itt = 2
198  C            ELSE
199  C               itt = 1
200        CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)            END IF
201       2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)            ijkl = ikm1 - jlk
202  C            iku2 = (ijkl-1)*ng1p1 + 1
203  C  
204  C  
205  C*         2.2.6   DOWN BELOW            IF (itt==1) THEN
206  C                  ----------               CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
207  C                    pabcu(1,1,ikn), ztt1)
208   2260 CONTINUE            ELSE
209  C               CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
210        ITT=1                    pabcu(1,1,ikn), ztt2)
211        DO 227 JLK=1,IKJ            END IF
212        IF(ITT.EQ.1) THEN  
213           ITT=2            DO ja = 1, ktraer
214        ELSE               DO jl = 1, kdlon
215           ITT=1                  ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
216        ENDIF               END DO
217        IJKL=IKM1-JLK            END DO
218        IKU2=(IJKL-1)*NG1P1+1  
219  C            DO jl = 1, kdlon
220  C               zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
221        IF(ITT.EQ.1) THEN                    pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
222           CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                    pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
223       2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)                    pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
224        ELSE                    pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
225           CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                    pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
226       2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)               zglayu(jl) = zww
227        ENDIF               zdzxmg = zglayu(jl)
228  C               pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
229        DO 2265 JA = 1, KTRAER               pcntrb(jl, jk, ijkl) = zdzxmg
230        DO 2264 JL = 1, KDLON            END DO
231        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5  
232   2264 CONTINUE  
233   2265 CONTINUE         END DO
234  C      END DO
235        DO 2266 JL = 1, KDLON  
236        ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)      RETURN
237       S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)    END SUBROUTINE lwvd
238       S   +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)  
239       S   +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)  end module lwvd_m
      S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)  
      S   +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  
  2266 CONTINUE  
 C  
 C  
  227  CONTINUE  
  228  CONTINUE  
 C  
       RETURN  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21