/[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 178 by guez, Fri Mar 11 18:47:26 2016 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 zuu(kdlon, nua)
   DOUBLE PRECISION ztt2(kdlon, ntra)  
   DOUBLE PRECISION zuu(kdlon, nua)  
59    
60    INTEGER jk, jl, ja, im12, ind, inu, ixu, jg      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
61    INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
62    DOUBLE PRECISION zwtr      DOUBLE PRECISION zwtr
63    
64    ! * Data Block:      ! * Data Block:
65    
66    DOUBLE PRECISION wg1(2)      DOUBLE PRECISION wg1(2)
67    SAVE wg1      SAVE wg1
68    DATA (wg1(jk), jk=1, 2)/1.0, 1.0/      DATA (wg1(jk), jk=1, 2)/1d0, 1d0/
69    ! -----------------------------------------------------------------------      ! -----------------------------------------------------------------------
70    
71    ! *         1.    INITIALIZATION      ! *         1.    INITIALIZATION
72    ! --------------      ! --------------
73    
74    
75    ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS      ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
76    ! ------------------------------      ! ------------------------------
77    
78    
79    DO jk = 1, kflev + 1      DO jk = 1, kflev + 1
80      DO jl = 1, kdlon         DO jl = 1, kdlon
81        padjd(jl, jk) = 0.            padjd(jl, jk) = 0.
82        padju(jl, jk) = 0.            padju(jl, jk) = 0.
83           END DO
84      END DO      END DO
   END DO  
85    
86    ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS      ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
87    ! ---------------------------------      ! ---------------------------------
88    
89    
90    DO ja = 1, ntra      DO ja = 1, ntra
91      DO jl = 1, kdlon         DO jl = 1, kdlon
92        ztt(jl, ja) = 1.0            ztt(jl, ja) = 1.0
93        ztt1(jl, ja) = 1.0         END DO
       ztt2(jl, ja) = 1.0  
94      END DO      END DO
   END DO  
95    
96    DO ja = 1, nua      DO ja = 1, nua
97      DO jl = 1, kdlon         DO jl = 1, kdlon
98        zuu(jl, ja) = 0.            zuu(jl, ja) = 0.
99           END DO
100      END DO      END DO
   END DO  
101    
102    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
103    
104    ! *         2.      VERTICAL INTEGRATION      ! *         2.      VERTICAL INTEGRATION
105    ! --------------------      ! --------------------
106    
107    
108    
109    ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS      ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
110    ! ---------------------------------      ! ---------------------------------
111    
112    
113    DO jk = 1, kflev      DO jk = 1, kflev
114    
115      ! *         2.1.1   DOWNWARD LAYERS         ! *         2.1.1   DOWNWARD LAYERS
116      ! ---------------         ! ---------------
117    
118    
119      im12 = 2*(jk-1)         im12 = 2*(jk-1)
120      ind = (jk-1)*ng1p1 + 1         ind = (jk-1)*ng1p1 + 1
121      ixd = ind         ixd = ind
122      inu = jk*ng1p1 + 1         inu = jk*ng1p1 + 1
123      ixu = ind         ixu = ind
124    
125      DO jl = 1, kdlon         DO jl = 1, kdlon
126        zglayd(jl) = 0.            zglayd(jl) = 0.
127        zglayu(jl) = 0.            zglayu(jl) = 0.
128      END DO         END DO
129    
130      DO jg = 1, ng1         DO jg = 1, ng1
131        ibs = im12 + jg            ibs = im12 + jg
132        idd = ixd + jg            idd = ixd + jg
133        DO ja = 1, kuaer            DO ja = 1, kuaer
134          DO jl = 1, kdlon               DO jl = 1, kdlon
135            zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)                  zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
136          END DO               END DO
137        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  
138    
     END DO  
139    
140      DO jl = 1, kdlon            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
141        padjd(jl, jk) = zglayd(jl)  
142        pcntrb(jl, jk, jk+1) = zglayd(jl)            DO jl = 1, kdlon
143        padju(jl, jk+1) = zglayu(jl)               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
144        pcntrb(jl, jk+1, jk) = zglayu(jl)                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
145        pcntrb(jl, jk, jk) = 0.0                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
146      END DO                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
147                      pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
148                      pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
149                 zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
150              END DO
151    
152              ! *         2.1.2   DOWNWARD LAYERS
153              ! ---------------
154    
   END DO  
155    
156    DO jk = 1, kflev            imu = ixu + jg
157      jk2 = 2*jk            DO ja = 1, kuaer
158      jk1 = jk2 - 1               DO jl = 1, kdlon
159      DO jnu = 1, ninter                  zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
160        DO jl = 1, kdlon               END DO
161          pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)            END DO
162        END DO  
163    
164              CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
165    
166              DO jl = 1, kdlon
167                 zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
168                      pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
169                      pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
170                      pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
171                      pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
172                      pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
173                 zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
174              END DO
175    
176           END DO
177    
178           DO jl = 1, kdlon
179              padjd(jl, jk) = zglayd(jl)
180              pcntrb(jl, jk, jk+1) = zglayd(jl)
181              padju(jl, jk+1) = zglayu(jl)
182              pcntrb(jl, jk+1, jk) = zglayu(jl)
183              pcntrb(jl, jk, jk) = 0.0
184           END DO
185        END DO
186    
187        DO jk = 1, kflev
188           jk2 = 2*jk
189           jk1 = jk2 - 1
190           DO jnu = 1, ninter
191              DO jl = 1, kdlon
192                 pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
193              END DO
194           END DO
195      END DO      END DO
   END DO  
196    
197    RETURN    END SUBROUTINE lwvn
198    
199  END SUBROUTINE lwvn  end module lwvn_m
Legend:
Removed from v.82  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21