/[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

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