/[lmdze]/trunk/Sources/phylmd/Radlwsw/lwv.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/lwv.f

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

trunk/libf/phylmd/Radlwsw/lwv.f revision 24 by guez, Wed Mar 3 13:23:49 2010 UTC trunk/Sources/phylmd/Radlwsw/lwv.f revision 166 by guez, Wed Jul 29 14:32:55 2015 UTC
# Line 1  Line 1 
1        SUBROUTINE LWV(KUAER,KTRAER, KLIM  module lwv_m
2       R  , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE  
3       R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP    IMPLICIT NONE
4       S  , PCNTRB,PCTS,PFLUC)  
5        use dimens_m  contains
6        use dimphy  
7        use YOMCST    SUBROUTINE lwv(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, pbtop, &
8        use raddim         pdbsl, pemis, ppmb, pga, pgb, pgasur, pgbsur, pgatop, pgbtop, &
9              use raddimlw         pcntrb, pcts, pfluc)
10        IMPLICIT none      USE dimens_m
11  C      USE dimphy
12  C-----------------------------------------------------------------------      use lwvd_m, only: lwvd
13  C     PURPOSE.      use lwvn_m, only: lwvn
14  C     --------      USE suphec_m
15  C           CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE      USE raddim
16  C           FLUXES OR RADIANCES      USE raddimlw
17  C  
18  C     METHOD.      ! -----------------------------------------------------------------------
19  C     -------      ! PURPOSE.
20  C      ! --------
21  C          1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN      ! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
22  C     CONTRIBUTIONS BY -  THE NEARBY LAYERS      ! FLUXES OR RADIANCES
23  C                      -  THE DISTANT LAYERS  
24  C                      -  THE BOUNDARY TERMS      ! METHOD.
25  C          2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.      ! -------
26  C  
27  C     REFERENCE.      ! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
28  C     ----------      ! CONTRIBUTIONS BY -  THE NEARBY LAYERS
29  C      ! -  THE DISTANT LAYERS
30  C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND      ! -  THE BOUNDARY TERMS
31  C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS      ! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
32  C  
33  C     AUTHOR.      ! REFERENCE.
34  C     -------      ! ----------
35  C        JEAN-JACQUES MORCRETTE  *ECMWF*  
36  C      ! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
37  C     MODIFICATIONS.      ! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
38  C     --------------  
39  C        ORIGINAL : 89-07-14      ! AUTHOR.
40  C-----------------------------------------------------------------------      ! -------
41  C      ! JEAN-JACQUES MORCRETTE  *ECMWF*
42  C* ARGUMENTS:  
43        INTEGER KUAER,KTRAER, KLIM      ! MODIFICATIONS.
44  C      ! --------------
45        REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS      ! ORIGINAL : 89-07-14
46        REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS      ! -----------------------------------------------------------------------
47        REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS  
48        REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION      ! * ARGUMENTS:
49        REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION      INTEGER kuaer, ktraer, klim
50        REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION  
51        REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT      DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
52        REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY      DOUBLE PRECISION pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
53        REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)      DOUBLE PRECISION pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
54        REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE      DOUBLE PRECISION pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
55        REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
56        REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS      DOUBLE PRECISION pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
57        REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS      DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
58        REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS      DOUBLE PRECISION pemis(kdlon) ! SURFACE EMISSIVITY
59        REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS      DOUBLE PRECISION ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
60        REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS      DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
61  C      DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
62        REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX      DOUBLE PRECISION pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS
63        REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM      DOUBLE PRECISION pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS
64        REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES      DOUBLE PRECISION pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS
65  C-----------------------------------------------------------------------      DOUBLE PRECISION pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS
66  C LOCAL VARIABLES:  
67        REAL*8 ZADJD(KDLON,KFLEV+1)      DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
68        REAL*8 ZADJU(KDLON,KFLEV+1)      DOUBLE PRECISION pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
69        REAL*8 ZDBDT(KDLON,Ninter,KFLEV)      DOUBLE PRECISION pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
70        REAL*8 ZDISD(KDLON,KFLEV+1)      ! -----------------------------------------------------------------------
71        REAL*8 ZDISU(KDLON,KFLEV+1)      ! LOCAL VARIABLES:
72  C      DOUBLE PRECISION zadjd(kdlon, kflev+1)
73        INTEGER jk, jl      DOUBLE PRECISION zadju(kdlon, kflev+1)
74  C-----------------------------------------------------------------------      DOUBLE PRECISION zdbdt(kdlon, ninter, kflev)
75  C      DOUBLE PRECISION zdisd(kdlon, kflev+1)
76        DO 112 JK=1,KFLEV+1      DOUBLE PRECISION zdisu(kdlon, kflev+1)
77        DO 111 JL=1, KDLON  
78        ZADJD(JL,JK)=0.      INTEGER jk, jl
79        ZADJU(JL,JK)=0.      ! -----------------------------------------------------------------------
80        ZDISD(JL,JK)=0.  
81        ZDISU(JL,JK)=0.      DO jk = 1, kflev + 1
82   111  CONTINUE         DO jl = 1, kdlon
83   112  CONTINUE            zadjd(jl, jk) = 0.
84  C            zadju(jl, jk) = 0.
85        DO 114 JK=1,KFLEV            zdisd(jl, jk) = 0.
86        DO 113 JL=1, KDLON            zdisu(jl, jk) = 0.
87        PCTS(JL,JK)=0.         END DO
88   113  CONTINUE      END DO
89   114  CONTINUE  
90  C      DO jk = 1, kflev
91  C* CONTRIBUTION FROM ADJACENT LAYERS         DO jl = 1, kdlon
92  C            pcts(jl, jk) = 0.
93        CALL LWVN(KUAER,KTRAER         END DO
94       R  , PABCU,PDBSL,PGA,PGB      END DO
95       S  , ZADJD,ZADJU,PCNTRB,ZDBDT)  
96  C* CONTRIBUTION FROM DISTANT LAYERS      ! * CONTRIBUTION FROM ADJACENT LAYERS
97  C  
98        CALL LWVD(KUAER,KTRAER      CALL lwvn(kuaer, pabcu, pdbsl, pga, pgb, zadjd, zadju, pcntrb, zdbdt)
99       R  , PABCU,ZDBDT,PGA,PGB      ! * CONTRIBUTION FROM DISTANT LAYERS
100       S  , PCNTRB,ZDISD,ZDISU)  
101  C      CALL lwvd(ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, zdisu)
102  C* EXCHANGE WITH THE BOUNDARIES  
103  C      ! * EXCHANGE WITH THE BOUNDARIES
104        CALL LWVB(KUAER,KTRAER, KLIM  
105       R  , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP      CALL lwvb(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, pbsuin, &
106       R  , ZDISD,ZDISU,PEMIS,PPMB           pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, &
107       R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP           pgatop, pgbtop, pcts, pfluc)
108       S  , PCTS,PFLUC)  
109  C  
110  C      RETURN
111        RETURN    END SUBROUTINE lwv
112        END  
113    end module lwv_m
Legend:
Removed from v.24  
changed lines
  Added in v.166
  ViewVC Help
Powered by ViewVC 1.1.21