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

trunk/phylmd/Radlwsw/lwvn.f revision 82 by guez, Wed Mar 5 14:57:53 2014 UTC trunk/Sources/phylmd/Radlwsw/lwvn.f revision 168 by guez, Wed Sep 9 10:41:47 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    
   END DO  
159    
160    DO jk = 1, kflev            imu = ixu + jg
161      jk2 = 2*jk            DO ja = 1, kuaer
162      jk1 = jk2 - 1               DO jl = 1, kdlon
163      DO jnu = 1, ninter                  zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
164        DO jl = 1, kdlon               END DO
165          pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)            END DO
166        END DO  
167    
168              CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
169    
170              DO jl = 1, kdlon
171                 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
172                      pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
173                      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        END DO
190    
191        DO jk = 1, kflev
192           jk2 = 2*jk
193           jk1 = jk2 - 1
194           DO jnu = 1, ninter
195              DO jl = 1, kdlon
196                 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
197              END DO
198           END DO
199      END DO      END DO
   END DO  
200    
201    RETURN    END SUBROUTINE lwvn
202    
203  END SUBROUTINE lwvn  end module lwvn_m
Legend:
Removed from v.82  
changed lines
  Added in v.168
  ViewVC Help
Powered by ViewVC 1.1.21