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

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

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

revision 165 by guez, Wed Apr 29 15:47:56 2015 UTC revision 166 by guez, Wed Jul 29 14:32:55 2015 UTC
# Line 1  Line 1 
1  SUBROUTINE lwvn(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, &  module lwvn_m
2      pdbdt)  
   USE dimens_m  
   USE dimphy  
   USE raddim  
   USE raddimlw  
3    IMPLICIT NONE    IMPLICIT NONE
4    
5    ! -----------------------------------------------------------------------  contains
6    ! PURPOSE.  
7    ! --------    SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
8    ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS      USE dimens_m
9    ! TO GIVE LONGWAVE FLUXES OR RADIANCES      USE dimphy
10        USE raddim
11        USE raddimlw
12        ! -----------------------------------------------------------------------
13        ! PURPOSE.
14        ! --------
15        ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
16        ! TO GIVE LONGWAVE FLUXES OR RADIANCES
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 ADJACENT LAYERS USING A GAUSSIAN QUADRATURE      ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
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    
39    ! * ARGUMENTS:      ! * ARGUMENTS:
40    
41    INTEGER kuaer, ktraer      INTEGER kuaer
42    
43    DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS      DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
44    DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT      DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
45    DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS      DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46    DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS      DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
47    
48    DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS      DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
49    DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS      DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
50    DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX      DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
51    DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT      DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT
52    
53    ! * LOCAL ARRAYS:      ! * LOCAL ARRAYS:
54    
55    DOUBLE PRECISION zglayd(kdlon)      DOUBLE PRECISION zglayd(kdlon)
56    DOUBLE PRECISION zglayu(kdlon)      DOUBLE PRECISION zglayu(kdlon)
57    DOUBLE PRECISION ztt(kdlon, ntra)      DOUBLE PRECISION ztt(kdlon, ntra)
58    DOUBLE PRECISION ztt1(kdlon, ntra)      DOUBLE PRECISION ztt1(kdlon, ntra)
59    DOUBLE PRECISION ztt2(kdlon, ntra)      DOUBLE PRECISION ztt2(kdlon, ntra)
60    DOUBLE PRECISION zuu(kdlon, nua)      DOUBLE PRECISION zuu(kdlon, nua)
61    
62    INTEGER jk, jl, ja, im12, ind, inu, ixu, jg      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
63    INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
64    DOUBLE PRECISION zwtr      DOUBLE PRECISION zwtr
65    
66    ! * Data Block:      ! * Data Block:
67    
68    DOUBLE PRECISION wg1(2)      DOUBLE PRECISION wg1(2)
69    SAVE wg1      SAVE wg1
70    DATA (wg1(jk), jk=1, 2)/1.0, 1.0/      DATA (wg1(jk), jk=1, 2)/1.0, 1.0/
71    ! -----------------------------------------------------------------------      ! -----------------------------------------------------------------------
72    
73    ! *         1.    INITIALIZATION      ! *         1.    INITIALIZATION
74    ! --------------      ! --------------
75    
76    
77    ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS      ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
78    ! ------------------------------      ! ------------------------------
79    
80    
81    DO jk = 1, kflev + 1      DO jk = 1, kflev + 1
82      DO jl = 1, kdlon         DO jl = 1, kdlon
83        padjd(jl, jk) = 0.            padjd(jl, jk) = 0.
84        padju(jl, jk) = 0.            padju(jl, jk) = 0.
85           END DO
86      END DO      END DO
   END DO  
87    
88    ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS      ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
89    ! ---------------------------------      ! ---------------------------------
90    
91    
92    DO ja = 1, ntra      DO ja = 1, ntra
93      DO jl = 1, kdlon         DO jl = 1, kdlon
94        ztt(jl, ja) = 1.0            ztt(jl, ja) = 1.0
95        ztt1(jl, ja) = 1.0            ztt1(jl, ja) = 1.0
96        ztt2(jl, ja) = 1.0            ztt2(jl, ja) = 1.0
97           END DO
98      END DO      END DO
   END DO  
99    
100    DO ja = 1, nua      DO ja = 1, nua
101      DO jl = 1, kdlon         DO jl = 1, kdlon
102        zuu(jl, ja) = 0.            zuu(jl, ja) = 0.
103           END DO
104      END DO      END DO
   END DO  
105    
106    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
107    
108    ! *         2.      VERTICAL INTEGRATION      ! *         2.      VERTICAL INTEGRATION
109    ! --------------------      ! --------------------
110    
111    
112    
113    ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS      ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
114    ! ---------------------------------      ! ---------------------------------
115    
116    
117    DO jk = 1, kflev      DO jk = 1, kflev
118    
119      ! *         2.1.1   DOWNWARD LAYERS         ! *         2.1.1   DOWNWARD LAYERS
120      ! ---------------         ! ---------------
121    
122    
123      im12 = 2*(jk-1)         im12 = 2*(jk-1)
124      ind = (jk-1)*ng1p1 + 1         ind = (jk-1)*ng1p1 + 1
125      ixd = ind         ixd = ind
126      inu = jk*ng1p1 + 1         inu = jk*ng1p1 + 1
127      ixu = ind         ixu = ind
128    
129      DO jl = 1, kdlon         DO jl = 1, kdlon
130        zglayd(jl) = 0.            zglayd(jl) = 0.
131        zglayu(jl) = 0.            zglayu(jl) = 0.
132      END DO         END DO
133    
134      DO jg = 1, ng1         DO jg = 1, ng1
135        ibs = im12 + jg            ibs = im12 + jg
136        idd = ixd + jg            idd = ixd + jg
137        DO ja = 1, kuaer            DO ja = 1, kuaer
138          DO jl = 1, kdlon               DO jl = 1, kdlon
139            zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)                  zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
140          END DO               END DO
141        END DO            END DO
   
   
       CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)  
   
       DO jl = 1, kdlon  
         zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &  
           pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &  
           pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &  
           pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &  
           pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &  
           pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)  
         zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)  
       END DO  
   
       ! *         2.1.2   DOWNWARD LAYERS  
       ! ---------------  
   
   
       imu = ixu + jg  
       DO ja = 1, kuaer  
         DO jl = 1, kdlon  
           zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)  
         END DO  
       END DO  
   
   
       CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)  
   
       DO jl = 1, kdlon  
         zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &  
           pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &  
           pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &  
           pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &  
           pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &  
           pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)  
         zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)  
       END DO  
142    
     END DO  
143    
144      DO jl = 1, kdlon            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
145        padjd(jl, jk) = zglayd(jl)  
146        pcntrb(jl, jk, jk+1) = zglayd(jl)            DO jl = 1, kdlon
147        padju(jl, jk+1) = zglayu(jl)               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
148        pcntrb(jl, jk+1, jk) = zglayu(jl)                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
149        pcntrb(jl, jk, jk) = 0.0                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
150      END DO                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
151                      pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
152                      pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
153                 zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
154              END DO
155    
156              ! *         2.1.2   DOWNWARD LAYERS
157              ! ---------------
158    
159    
160    END DO            imu = ixu + jg
161              DO ja = 1, kuaer
162                 DO jl = 1, kdlon
163                    zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
164                 END DO
165              END DO
166    
167    DO jk = 1, kflev  
168      jk2 = 2*jk            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
169      jk1 = jk2 - 1  
170      DO jnu = 1, ninter            DO jl = 1, kdlon
171        DO jl = 1, kdlon               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
172          pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
173        END DO                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
174                      pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
175                      pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
176                      pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
177                 zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
178              END DO
179    
180           END DO
181    
182           DO jl = 1, kdlon
183              padjd(jl, jk) = zglayd(jl)
184              pcntrb(jl, jk, jk+1) = zglayd(jl)
185              padju(jl, jk+1) = zglayu(jl)
186              pcntrb(jl, jk+1, jk) = zglayu(jl)
187              pcntrb(jl, jk, jk) = 0.0
188           END DO
189    
190        END DO
191    
192        DO jk = 1, kflev
193           jk2 = 2*jk
194           jk1 = jk2 - 1
195           DO jnu = 1, ninter
196              DO jl = 1, kdlon
197                 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
198              END DO
199           END DO
200      END DO      END DO
   END DO  
201    
202    RETURN      RETURN
203    
204      END SUBROUTINE lwvn
205    
206  END SUBROUTINE lwvn  end module lwvn_m
Legend:
Removed from v.165  
changed lines
  Added in v.166
  ViewVC Help
Powered by ViewVC 1.1.21