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 |