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