/[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/libf/phylmd/Radlwsw/lwvn.f revision 24 by guez, Wed Mar 3 13:23:49 2010 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        REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS      INTEGER kuaer
42        REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT  
43        REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
44        REAL*8 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        REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS      DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
47        REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS  
48        REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX      DOUBLE PRECISION padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
49        REAL*8 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        REAL*8 ZGLAYD(KDLON)      ! * LOCAL ARRAYS:
54        REAL*8 ZGLAYU(KDLON)  
55        REAL*8 ZTT(KDLON,NTRA)      DOUBLE PRECISION zglayd(kdlon)
56        REAL*8 ZTT1(KDLON,NTRA)      DOUBLE PRECISION zglayu(kdlon)
57        REAL*8 ZTT2(KDLON,NTRA)      DOUBLE PRECISION ztt(kdlon, ntra)
58        REAL*8 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        REAL*8 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        REAL*8 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.24  
changed lines
  Added in v.168
  ViewVC Help
Powered by ViewVC 1.1.21