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