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