/[lmdze]/trunk/phylmd/Radlwsw/lwvd.f90
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/lwvd.f90

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 155 by guez, Wed Jul 8 17:03:45 2015 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 ind1, ind2, ind3, ind4, 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  
98   200  CONTINUE      ind1 = 0
99  C      ind3 = 0
100        IND1=0      ind4 = 1
101        IND3=0      ind2 = 1
102        IND4=1  
103        IND2=1  
104  C      ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
105  C      ! ---------------------------------
106  C*         2.2     CONTRIBUTION FROM DISTANT LAYERS  
107  C                  ---------------------------------  
108  C  
109   220  CONTINUE      ! *         2.2.1   DISTANT AND ABOVE LAYERS
110  C      ! ------------------------
111  C  
112  C*         2.2.1   DISTANT AND ABOVE LAYERS  
113  C                  ------------------------  
114  C  
115   2210 CONTINUE      ! *         2.2.2   FIRST UPPER LEVEL
116  C      ! -----------------
117  C  
118  C  
119  C*         2.2.2   FIRST UPPER LEVEL      DO jk = 1, kflev - 1
120  C                  -----------------         ikp1 = jk + 1
121  C         ikn = (jk-1)*ng1p1 + 1
122   2220 CONTINUE         ikd1 = jk*ng1p1 + 1
123  C  
124        DO 225 JK = 1 , KFLEV-1         CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
125        IKP1=JK+1              ztt1)
126        IKN=(JK-1)*NG1P1+1  
127        IKD1= JK  *NG1P1+1  
128  C  
129        CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)         ! *         2.2.3   HIGHER UP
130       2          , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)         ! ---------
131  C  
132  C  
133  C         itt = 1
134  C*         2.2.3   HIGHER UP         DO jkj = ikp1, kflev
135  C                  ---------            IF (itt==1) THEN
136  C               itt = 2
137   2230 CONTINUE            ELSE
138  C               itt = 1
139        ITT=1            END IF
140        DO 224 JKJ=IKP1,KFLEV            ikjp1 = jkj + 1
141        IF(ITT.EQ.1) THEN            ikd2 = jkj*ng1p1 + 1
142           ITT=2  
143        ELSE            IF (itt==1) THEN
144           ITT=1               CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
145        ENDIF                    pabcu(1,1,ikd2), ztt1)
146        IKJP1=JKJ+1            ELSE
147        IKD2= JKJ  *NG1P1+1               CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
148  C                    pabcu(1,1,ikd2), ztt2)
149        IF(ITT.EQ.1) THEN            END IF
150           CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)  
151       2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)            DO ja = 1, ktraer
152        ELSE               DO jl = 1, kdlon
153           CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)                  ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
154       2             , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)               END DO
155        ENDIF            END DO
156  C  
157        DO 2235 JA = 1, KTRAER            DO jl = 1, kdlon
158        DO 2234 JL = 1, KDLON               zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
159        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5                    pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
160   2234 CONTINUE                    pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
161   2235 CONTINUE                    pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
162  C                    pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
163        DO 2236 JL = 1, KDLON                    pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
164        ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1)          *ZTT(JL,10)               zglayd(jl) = zww
165       S   +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)               zdzxdg = zglayd(jl)
166       S   +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)               pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
167       S   +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)               pcntrb(jl, jk, ikjp1) = zdzxdg
168       S   +PDBDT(JL,5,JKJ)*ZTT(JL,3)          *ZTT(JL,14)            END DO
169       S   +PDBDT(JL,6,JKJ)*ZTT(JL,6)          *ZTT(JL,15)  
170        ZGLAYD(JL)=ZWW  
171        ZDZXDG=ZGLAYD(JL)         END DO
172        PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG      END DO
173        PCNTRB(JL,JK,IKJP1)=ZDZXDG  
174   2236 CONTINUE  
175  C      ! *         2.2.4   DISTANT AND BELOW LAYERS
176  C      ! ------------------------
177   224  CONTINUE  
178   225  CONTINUE  
179  C  
180  C  
181  C*         2.2.4   DISTANT AND BELOW LAYERS      ! *         2.2.5   FIRST LOWER LEVEL
182  C                  ------------------------      ! -----------------
183  C  
184   2240 CONTINUE  
185  C      DO jk = 3, kflev + 1
186  C         ikn = (jk-1)*ng1p1 + 1
187  C         ikm1 = jk - 1
188  C*         2.2.5   FIRST LOWER LEVEL         ikj = jk - 2
189  C                  -----------------         iku1 = ikj*ng1p1 + 1
190  C  
191   2250 CONTINUE  
192  C         CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
193        DO 228 JK=3,KFLEV+1              pabcu(1,1,ikn), ztt1)
194        IKN=(JK-1)*NG1P1+1  
195        IKM1=JK-1  
196        IKJ=JK-2  
197        IKU1= IKJ  *NG1P1+1         ! *         2.2.6   DOWN BELOW
198  C         ! ----------
199  C  
200        CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)  
201       2          , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)         itt = 1
202  C         DO jlk = 1, ikj
203  C            IF (itt==1) THEN
204  C               itt = 2
205  C*         2.2.6   DOWN BELOW            ELSE
206  C                  ----------               itt = 1
207  C            END IF
208   2260 CONTINUE            ijkl = ikm1 - jlk
209  C            iku2 = (ijkl-1)*ng1p1 + 1
210        ITT=1  
211        DO 227 JLK=1,IKJ  
212        IF(ITT.EQ.1) THEN            IF (itt==1) THEN
213           ITT=2               CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
214        ELSE                    pabcu(1,1,ikn), ztt1)
215           ITT=1            ELSE
216        ENDIF               CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
217        IJKL=IKM1-JLK                    pabcu(1,1,ikn), ztt2)
218        IKU2=(IJKL-1)*NG1P1+1            END IF
219  C  
220  C            DO ja = 1, ktraer
221        IF(ITT.EQ.1) THEN               DO jl = 1, kdlon
222           CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)                  ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
223       2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)               END DO
224        ELSE            END DO
225           CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)  
226       2             , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)            DO jl = 1, kdlon
227        ENDIF               zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
228  C                    pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
229        DO 2265 JA = 1, KTRAER                    pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
230        DO 2264 JL = 1, KDLON                    pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
231        ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5                    pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
232   2264 CONTINUE                    pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
233   2265 CONTINUE               zglayu(jl) = zww
234  C               zdzxmg = zglayu(jl)
235        DO 2266 JL = 1, KDLON               pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
236        ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1)          *ZTT(JL,10)               pcntrb(jl, jk, ijkl) = zdzxmg
237       S   +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)            END DO
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)  
240       S   +PDBDT(JL,5,IJKL)*ZTT(JL,3)          *ZTT(JL,14)         END DO
241       S   +PDBDT(JL,6,IJKL)*ZTT(JL,6)          *ZTT(JL,15)      END DO
242        ZGLAYU(JL)=ZWW  
243        ZDZXMG=ZGLAYU(JL)      RETURN
244        PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG    END SUBROUTINE lwvd
245        PCNTRB(JL,JK,IJKL)=ZDZXMG  
246   2266 CONTINUE  end module lwvd_m
 C  
 C  
  227  CONTINUE  
  228  CONTINUE  
 C  
       RETURN  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.155
  ViewVC Help
Powered by ViewVC 1.1.21