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

revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC revision 328 by guez, Thu Jun 13 14:40:06 2019 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 dimensions
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 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
95        ! --------------------
96    
97    ! *         2.      VERTICAL INTEGRATION      ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS
98    ! --------------------      ! ---------------------------------
99    
100    
   ind1 = 0  
   ind3 = 0  
   ind4 = 1  
   ind2 = 1  
101    
102        ! *         2.2.1   DISTANT AND ABOVE LAYERS
103        ! ------------------------
104    
   ! *         2.2     CONTRIBUTION FROM DISTANT LAYERS  
   ! ---------------------------------  
105    
106    
107    
108    ! *         2.2.1   DISTANT AND ABOVE LAYERS      ! *         2.2.2   FIRST UPPER LEVEL
109    ! ------------------------      ! -----------------
110    
111    
112        DO jk = 1, kflev - 1
113           ikp1 = jk + 1
114           ikn = (jk-1)*ng1p1 + 1
115           ikd1 = jk*ng1p1 + 1
116    
117           CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &
118                ztt1)
119    
   ! *         2.2.2   FIRST UPPER LEVEL  
   ! -----------------  
120    
121    
122    DO jk = 1, kflev - 1         ! *         2.2.3   HIGHER UP
123      ikp1 = jk + 1         ! ---------
     ikn = (jk-1)*ng1p1 + 1  
     ikd1 = jk*ng1p1 + 1  
124    
     CALL lwttm(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), pabcu(1,1,ikd1), &  
       ztt1)  
125    
126           itt = 1
127           DO jkj = ikp1, kflev
128              IF (itt==1) THEN
129                 itt = 2
130              ELSE
131                 itt = 1
132              END IF
133              ikjp1 = jkj + 1
134              ikd2 = jkj*ng1p1 + 1
135    
136              IF (itt==1) THEN
137                 CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
138                      pabcu(1,1,ikd2), ztt1)
139              ELSE
140                 CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
141                      pabcu(1,1,ikd2), ztt2)
142              END IF
143    
144      ! *         2.2.3   HIGHER UP            DO ja = 1, ktraer
145      ! ---------               DO jl = 1, kdlon
146                    ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
147                 END DO
148              END DO
149    
150              DO jl = 1, kdlon
151                 zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &
152                      pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
153                      pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
154                      pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
155                      pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &
156                      pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)
157                 zglayd(jl) = zww
158                 zdzxdg = zglayd(jl)
159                 pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
160                 pcntrb(jl, jk, ikjp1) = zdzxdg
161              END DO
162    
     itt = 1  
     DO jkj = ikp1, kflev  
       IF (itt==1) THEN  
         itt = 2  
       ELSE  
         itt = 1  
       END IF  
       ikjp1 = jkj + 1  
       ikd2 = jkj*ng1p1 + 1  
163    
164        IF (itt==1) THEN         END DO
165          CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &      END DO
           pabcu(1,1,ikd2), ztt1)  
       ELSE  
         CALL lwttm(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &  
           pabcu(1,1,ikd2), ztt2)  
       END IF  
166    
       DO ja = 1, ktraer  
         DO jl = 1, kdlon  
           ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5  
         END DO  
       END DO  
167    
168        DO jl = 1, kdlon      ! *         2.2.4   DISTANT AND BELOW LAYERS
169          zww = pdbdt(jl, 1, jkj)*ztt(jl, 1)*ztt(jl, 10) + &      ! ------------------------
           pdbdt(jl, 2, jkj)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &  
           pdbdt(jl, 3, jkj)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &  
           pdbdt(jl, 4, jkj)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &  
           pdbdt(jl, 5, jkj)*ztt(jl, 3)*ztt(jl, 14) + &  
           pdbdt(jl, 6, jkj)*ztt(jl, 6)*ztt(jl, 15)  
         zglayd(jl) = zww  
         zdzxdg = zglayd(jl)  
         pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg  
         pcntrb(jl, jk, ikjp1) = zdzxdg  
       END DO  
170    
171    
     END DO  
   END DO  
172    
173    
174    ! *         2.2.4   DISTANT AND BELOW LAYERS      ! *         2.2.5   FIRST LOWER LEVEL
175    ! ------------------------      ! -----------------
176    
177    
178        DO jk = 3, kflev + 1
179           ikn = (jk-1)*ng1p1 + 1
180           ikm1 = jk - 1
181           ikj = jk - 2
182           iku1 = ikj*ng1p1 + 1
183    
184    
185    ! *         2.2.5   FIRST LOWER LEVEL         CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
186    ! -----------------              pabcu(1,1,ikn), ztt1)
187    
188    
   DO jk = 3, kflev + 1  
     ikn = (jk-1)*ng1p1 + 1  
     ikm1 = jk - 1  
     ikj = jk - 2  
     iku1 = ikj*ng1p1 + 1  
189    
190           ! *         2.2.6   DOWN BELOW
191           ! ----------
192    
     CALL lwttm(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &  
       pabcu(1,1,ikn), ztt1)  
193    
194           itt = 1
195           DO jlk = 1, ikj
196              IF (itt==1) THEN
197                 itt = 2
198              ELSE
199                 itt = 1
200              END IF
201              ijkl = ikm1 - jlk
202              iku2 = (ijkl-1)*ng1p1 + 1
203    
204    
205      ! *         2.2.6   DOWN BELOW            IF (itt==1) THEN
206      ! ----------               CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
207                      pabcu(1,1,ikn), ztt1)
208              ELSE
209                 CALL lwttm(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
210                      pabcu(1,1,ikn), ztt2)
211              END IF
212    
213              DO ja = 1, ktraer
214                 DO jl = 1, kdlon
215                    ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
216                 END DO
217              END DO
218    
219      itt = 1            DO jl = 1, kdlon
220      DO jlk = 1, ikj               zww = pdbdt(jl, 1, ijkl)*ztt(jl, 1)*ztt(jl, 10) + &
221        IF (itt==1) THEN                    pdbdt(jl, 2, ijkl)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
222          itt = 2                    pdbdt(jl, 3, ijkl)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
223        ELSE                    pdbdt(jl, 4, ijkl)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
224          itt = 1                    pdbdt(jl, 5, ijkl)*ztt(jl, 3)*ztt(jl, 14) + &
225        END IF                    pdbdt(jl, 6, ijkl)*ztt(jl, 6)*ztt(jl, 15)
226        ijkl = ikm1 - jlk               zglayu(jl) = zww
227        iku2 = (ijkl-1)*ng1p1 + 1               zdzxmg = zglayu(jl)
228                 pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
229                 pcntrb(jl, jk, ijkl) = zdzxmg
230        IF (itt==1) THEN            END DO
         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  
231    
232    
233           END DO
234      END DO      END DO
   END DO  
235    
236    RETURN      RETURN
237  END SUBROUTINE lwvd    END SUBROUTINE lwvd
238    
239    end module lwvd_m
Legend:
Removed from v.81  
changed lines
  Added in v.328
  ViewVC Help
Powered by ViewVC 1.1.21