/[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 76 by guez, Fri Nov 15 18:45:49 2013 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  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 ztt1(kdlon, ntra)
59  C      DOUBLE PRECISION ztt2(kdlon, ntra)
60        INTEGER jk, jl, ja, im12, ind, inu, ixu, jg      DOUBLE PRECISION zuu(kdlon, nua)
61        INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu  
62        DOUBLE PRECISION zwtr      INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
63  c      INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
64  C* Data Block:      DOUBLE PRECISION zwtr
65  c  
66        DOUBLE PRECISION WG1(2)      ! * Data Block:
67        SAVE WG1  
68        DATA (WG1(jk),jk=1,2) /1.0, 1.0/      DOUBLE PRECISION wg1(2)
69  C-----------------------------------------------------------------------      SAVE wg1
70  C      DATA (wg1(jk), jk=1, 2)/1.0, 1.0/
71  C*         1.    INITIALIZATION      ! -----------------------------------------------------------------------
72  C                --------------  
73  C      ! *         1.    INITIALIZATION
74   100  CONTINUE      ! --------------
75  C  
76  C*         1.1     INITIALIZE LAYER CONTRIBUTIONS  
77  C                  ------------------------------      ! *         1.1     INITIALIZE LAYER CONTRIBUTIONS
78  C      ! ------------------------------
79   110  CONTINUE  
80  C  
81        DO 112 JK = 1 , KFLEV+1      DO jk = 1, kflev + 1
82        DO 111 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   111  CONTINUE         END DO
86   112  CONTINUE      END DO
87  C  
88  C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS      ! *         1.2     INITIALIZE TRANSMISSION FUNCTIONS
89  C                  ---------------------------------      ! ---------------------------------
90  C  
91   120  CONTINUE  
92  C      DO ja = 1, ntra
93        DO 122 JA = 1 , NTRA         DO jl = 1, kdlon
94        DO 121 JL = 1, KDLON            ztt(jl, ja) = 1.0
95        ZTT (JL,JA) = 1.0            ztt1(jl, ja) = 1.0
96        ZTT1(JL,JA) = 1.0            ztt2(jl, ja) = 1.0
97        ZTT2(JL,JA) = 1.0         END DO
98   121  CONTINUE      END DO
99   122  CONTINUE  
100  C      DO ja = 1, nua
101        DO 124 JA = 1 , NUA         DO jl = 1, kdlon
102        DO 123 JL = 1, KDLON            zuu(jl, ja) = 0.
103        ZUU(JL,JA) = 0.         END DO
104   123  CONTINUE      END DO
105   124  CONTINUE  
106  C      ! ------------------------------------------------------------------
107  C     ------------------------------------------------------------------  
108  C      ! *         2.      VERTICAL INTEGRATION
109  C*         2.      VERTICAL INTEGRATION      ! --------------------
110  C                  --------------------  
111  C  
112   200  CONTINUE  
113  C      ! *         2.1     CONTRIBUTION FROM ADJACENT LAYERS
114  C      ! ---------------------------------
115  C*         2.1     CONTRIBUTION FROM ADJACENT LAYERS  
116  C                  ---------------------------------  
117  C      DO jk = 1, kflev
118   210  CONTINUE  
119  C         ! *         2.1.1   DOWNWARD LAYERS
120        DO 215 JK = 1 , KFLEV         ! ---------------
121  C  
122  C*         2.1.1   DOWNWARD LAYERS  
123  C                  ---------------         im12 = 2*(jk-1)
124  C         ind = (jk-1)*ng1p1 + 1
125   2110 CONTINUE         ixd = ind
126  C         inu = jk*ng1p1 + 1
127        IM12 = 2 * (JK - 1)         ixu = ind
128        IND = (JK - 1) * NG1P1 + 1  
129        IXD = IND         DO jl = 1, kdlon
130        INU = JK * NG1P1 + 1            zglayd(jl) = 0.
131        IXU = IND            zglayu(jl) = 0.
132  C         END DO
133        DO 2111 JL = 1, KDLON  
134        ZGLAYD(JL) = 0.         DO jg = 1, ng1
135        ZGLAYU(JL) = 0.            ibs = im12 + jg
136   2111 CONTINUE            idd = ixd + jg
137  C            DO ja = 1, kuaer
138        DO 213 JG = 1 , NG1               DO jl = 1, kdlon
139        IBS = IM12 + JG                  zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
140        IDD = IXD + JG               END DO
141        DO 2113 JA = 1 , KUAER            END DO
142        DO 2112 JL = 1, KDLON  
143        ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)  
144   2112 CONTINUE            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
145   2113 CONTINUE  
146  C            DO jl = 1, kdlon
147  C               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
148        CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
149  C                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
150        DO 2114 JL = 1, KDLON                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
151        ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                    pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
152       S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)                    pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
153       S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)               zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
154       S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)            END DO
155       S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)  
156       S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)            ! *         2.1.2   DOWNWARD LAYERS
157        ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)            ! ---------------
158   2114 CONTINUE  
159  C  
160  C*         2.1.2   DOWNWARD LAYERS            imu = ixu + jg
161  C                  ---------------            DO ja = 1, kuaer
162  C               DO jl = 1, kdlon
163   2120 CONTINUE                  zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
164  C               END DO
165        IMU = IXU + JG            END DO
166        DO 2122 JA = 1 , KUAER  
167        DO 2121 JL = 1, KDLON  
168        ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)            CALL lwtt(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
169   2121 CONTINUE  
170   2122 CONTINUE            DO jl = 1, kdlon
171  C               zwtr = pdbsl(jl, 1, ibs)*ztt(jl, 1)*ztt(jl, 10) + &
172  C                    pdbsl(jl, 2, ibs)*ztt(jl, 2)*ztt(jl, 7)*ztt(jl, 11) + &
173        CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)                    pdbsl(jl, 3, ibs)*ztt(jl, 4)*ztt(jl, 8)*ztt(jl, 12) + &
174  C                    pdbsl(jl, 4, ibs)*ztt(jl, 5)*ztt(jl, 9)*ztt(jl, 13) + &
175        DO 2123 JL = 1, KDLON                    pdbsl(jl, 5, ibs)*ztt(jl, 3)*ztt(jl, 14) + &
176        ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1)          *ZTT(JL,10)                    pdbsl(jl, 6, ibs)*ztt(jl, 6)*ztt(jl, 15)
177       S    +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)               zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
178       S    +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)            END DO
179       S    +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)  
180       S    +PDBSL(JL,5,IBS)*ZTT(JL,3)          *ZTT(JL,14)         END DO
181       S    +PDBSL(JL,6,IBS)*ZTT(JL,6)          *ZTT(JL,15)  
182        ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)         DO jl = 1, kdlon
183   2123 CONTINUE            padjd(jl, jk) = zglayd(jl)
184  C            pcntrb(jl, jk, jk+1) = zglayd(jl)
185   213  CONTINUE            padju(jl, jk+1) = zglayu(jl)
186  C            pcntrb(jl, jk+1, jk) = zglayu(jl)
187        DO 214 JL = 1, KDLON            pcntrb(jl, jk, jk) = 0.0
188        PADJD(JL,JK) = ZGLAYD(JL)         END DO
189        PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)      END DO
190        PADJU(JL,JK+1) = ZGLAYU(JL)  
191        PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)      DO jk = 1, kflev
192        PCNTRB(JL,JK  ,JK) = 0.0         jk2 = 2*jk
193   214  CONTINUE         jk1 = jk2 - 1
194  C         DO jnu = 1, ninter
195   215  CONTINUE            DO jl = 1, kdlon
196  C               pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
197        DO 218 JK = 1 , KFLEV            END DO
198        JK2 = 2 * JK         END DO
199        JK1 = JK2 - 1      END DO
200        DO 217 JNU = 1 , Ninter  
201        DO 216 JL = 1, KDLON    END SUBROUTINE lwvn
202        PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)  
203   216  CONTINUE  end module lwvn_m
  217  CONTINUE  
  218  CONTINUE  
 C  
       RETURN  
 C  
       END  
Legend:
Removed from v.76  
changed lines
  Added in v.168
  ViewVC Help
Powered by ViewVC 1.1.21