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

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

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

trunk/libf/phylmd/Radlwsw/lwvn.f revision 71 by guez, Mon Jul 8 18:12:18 2013 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  module lwvn_m
2       R  , PABCU,PDBSL,PGA,PGB  
3       S  , PADJD,PADJU,PCNTRB,PDBDT)    IMPLICIT NONE
4        use dimens_m  
5        use dimphy  contains
6        use raddim  
7              use raddimlw    SUBROUTINE lwvn(kuaer, pabcu, pdbsl, pga, pgb, padjd, padju, pcntrb, pdbdt)
8        IMPLICIT none      USE dimens_m
9  C      USE dimphy
10  C-----------------------------------------------------------------------      USE raddim
11  C     PURPOSE.      USE raddimlw
12  C     --------      ! -----------------------------------------------------------------------
13  C           CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS      ! PURPOSE.
14  C           TO GIVE LONGWAVE FLUXES OR RADIANCES      ! --------
15  C      ! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
16  C     METHOD.      ! TO GIVE LONGWAVE FLUXES OR RADIANCES
17  C     -------  
18  C      ! METHOD.
19  C          1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE      ! -------
20  C     CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE  
21  C      ! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
22  C     REFERENCE.      ! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
23  C     ----------  
24  C      ! REFERENCE.
25  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND      ! ----------
26  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS  
27  C      ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
28  C     AUTHOR.      ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
29  C     -------  
30  C        JEAN-JACQUES MORCRETTE  *ECMWF*      ! AUTHOR.
31  C      ! -------
32  C     MODIFICATIONS.      ! JEAN-JACQUES MORCRETTE  *ECMWF*
33  C     --------------  
34  C        ORIGINAL : 89-07-14      ! MODIFICATIONS.
35  C-----------------------------------------------------------------------      ! --------------
36  C      ! ORIGINAL : 89-07-14
37  C* ARGUMENTS:      ! -----------------------------------------------------------------------
38  C  
39        INTEGER KUAER,KTRAER      ! * ARGUMENTS:
40  C  
41        DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS      INTEGER kuaer
42        DOUBLE PRECISION PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT  
43        DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
44        DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
45  C      DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
46        DOUBLE PRECISION PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS      DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
47        DOUBLE PRECISION PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS  
48        DOUBLE PRECISION PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX      DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
49        DOUBLE PRECISION PDBDT(KDLON,Ninter,KFLEV) !  LAYER PLANCK FUNCTION GRADIENT      DOUBLE PRECISION padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
50  C      DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
51  C* LOCAL ARRAYS:      DOUBLE PRECISION pdbdt(kdlon, ninter, kflev) !  LAYER PLANCK FUNCTION GRADIENT
52  C  
53        DOUBLE PRECISION ZGLAYD(KDLON)      ! * LOCAL ARRAYS:
54        DOUBLE PRECISION ZGLAYU(KDLON)  
55        DOUBLE PRECISION ZTT(KDLON,NTRA)      DOUBLE PRECISION zglayd(kdlon)
56        DOUBLE PRECISION ZTT1(KDLON,NTRA)      DOUBLE PRECISION zglayu(kdlon)
57        DOUBLE PRECISION ZTT2(KDLON,NTRA)      DOUBLE PRECISION ztt(kdlon, ntra)
58        DOUBLE PRECISION ZUU(KDLON,NUA)      DOUBLE PRECISION zuu(kdlon, nua)
59  C  
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  c  
64  C* Data Block:      ! * Data Block:
65  c  
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  C-----------------------------------------------------------------------      ! -----------------------------------------------------------------------
70  C  
71  C*         1.    INITIALIZATION      ! *         1.    INITIALIZATION
72  C                --------------      ! --------------
73  C  
74   100  CONTINUE  
75  C      ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
76  C*         1.1     INITIALIZE LAYER CONTRIBUTIONS      ! ------------------------------
77  C                  ------------------------------  
78  C  
79   110  CONTINUE      DO jk = 1, kflev + 1
80  C         DO jl = 1, kdlon
81        DO 112 JK = 1 , KFLEV+1            padjd(jl, jk) = 0.
82        DO 111 JL = 1, KDLON            padju(jl, jk) = 0.
83        PADJD(JL,JK) = 0.         END DO
84        PADJU(JL,JK) = 0.      END DO
85   111  CONTINUE  
86   112  CONTINUE      ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
87  C      ! ---------------------------------
88  C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS  
89  C                  ---------------------------------  
90  C      DO ja = 1, ntra
91   120  CONTINUE         DO jl = 1, kdlon
92  C            ztt(jl, ja) = 1.0
93        DO 122 JA = 1 , NTRA         END DO
94        DO 121 JL = 1, KDLON      END DO
95        ZTT (JL,JA) = 1.0  
96        ZTT1(JL,JA) = 1.0      DO ja = 1, nua
97        ZTT2(JL,JA) = 1.0         DO jl = 1, kdlon
98   121  CONTINUE            zuu(jl, ja) = 0.
99   122  CONTINUE         END DO
100  C      END DO
101        DO 124 JA = 1 , NUA  
102        DO 123 JL = 1, KDLON      ! ------------------------------------------------------------------
103        ZUU(JL,JA) = 0.  
104   123  CONTINUE      ! *         2.      VERTICAL INTEGRATION
105   124  CONTINUE      ! --------------------
106  C  
107  C     ------------------------------------------------------------------  
108  C  
109  C*         2.      VERTICAL INTEGRATION      ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
110  C                  --------------------      ! ---------------------------------
111  C  
112   200  CONTINUE  
113  C      DO jk = 1, kflev
114  C  
115  C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS         ! *         2.1.1   DOWNWARD LAYERS
116  C                  ---------------------------------         ! ---------------
117  C  
118   210  CONTINUE  
119  C         im12 = 2*(jk-1)
120        DO 215 JK = 1 , KFLEV         ind = (jk-1)*ng1p1 + 1
121  C         ixd = ind
122  C*         2.1.1   DOWNWARD LAYERS         inu = jk*ng1p1 + 1
123  C                  ---------------         ixu = ind
124  C  
125   2110 CONTINUE         DO jl = 1, kdlon
126  C            zglayd(jl) = 0.
127        IM12 = 2 * (JK - 1)            zglayu(jl) = 0.
128        IND = (JK - 1) * NG1P1 + 1         END DO
129        IXD = IND  
130        INU = JK * NG1P1 + 1         DO jg = 1, ng1
131        IXU = IND            ibs = im12 + jg
132  C            idd = ixd + jg
133        DO 2111 JL = 1, KDLON            DO ja = 1, kuaer
134        ZGLAYD(JL) = 0.               DO jl = 1, kdlon
135        ZGLAYU(JL) = 0.                  zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
136   2111 CONTINUE               END DO
137  C            END DO
138        DO 213 JG = 1 , NG1  
139        IBS = IM12 + JG  
140        IDD = IXD + JG            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
141        DO 2113 JA = 1 , KUAER  
142        DO 2112 JL = 1, KDLON            DO jl = 1, kdlon
143        ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
144   2112 CONTINUE                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
145   2113 CONTINUE                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
146  C                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
147  C                    pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
148        CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)                    pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
149  C               zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
150        DO 2114 JL = 1, KDLON            END DO
151        ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)  
152       S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)            ! *         2.1.2   DOWNWARD LAYERS
153       S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)            ! ---------------
154       S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)  
155       S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)  
156       S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)            imu = ixu + jg
157        ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)            DO ja = 1, kuaer
158   2114 CONTINUE               DO jl = 1, kdlon
159  C                  zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
160  C*         2.1.2   DOWNWARD LAYERS               END DO
161  C                  ---------------            END DO
162  C  
163   2120 CONTINUE  
164  C            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
165        IMU = IXU + JG  
166        DO 2122 JA = 1 , KUAER            DO jl = 1, kdlon
167        DO 2121 JL = 1, KDLON               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
168        ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
169   2121 CONTINUE                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
170   2122 CONTINUE                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
171  C                    pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
172  C                    pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
173        CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)               zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
174  C            END DO
175        DO 2123 JL = 1, KDLON  
176        ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)         END DO
177       S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)  
178       S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)         DO jl = 1, kdlon
179       S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)            padjd(jl, jk) = zglayd(jl)
180       S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)            pcntrb(jl, jk, jk+1) = zglayd(jl)
181       S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)            padju(jl, jk+1) = zglayu(jl)
182        ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)            pcntrb(jl, jk+1, jk) = zglayu(jl)
183   2123 CONTINUE            pcntrb(jl, jk, jk) = 0.0
184  C         END DO
185   213  CONTINUE      END DO
186  C  
187        DO 214 JL = 1, KDLON      DO jk = 1, kflev
188        PADJD(JL,JK) = ZGLAYD(JL)         jk2 = 2*jk
189        PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)         jk1 = jk2 - 1
190        PADJU(JL,JK+1) = ZGLAYU(JL)         DO jnu = 1, ninter
191        PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)            DO jl = 1, kdlon
192        PCNTRB(JL,JK  ,JK) = 0.0               pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
193   214  CONTINUE            END DO
194  C         END DO
195   215  CONTINUE      END DO
196  C  
197        DO 218 JK = 1 , KFLEV    END SUBROUTINE lwvn
198        JK2 = 2 * JK  
199        JK1 = JK2 - 1  end module lwvn_m
       DO 217 JNU = 1 , Ninter  
       DO 216 JL = 1, KDLON  
       PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)  
  216  CONTINUE  
  217  CONTINUE  
  218  CONTINUE  
 C  
       RETURN  
 C  
       END  
Legend:
Removed from v.71  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21