1 |
SUBROUTINE lwv(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, pbtop, & |
module lwv_m |
2 |
pdbsl, pemis, ppmb, ptave, pga, pgb, pgasur, pgbsur, pgatop, pgbtop, & |
|
|
pcntrb, pcts, pfluc) |
|
|
USE dimens_m |
|
|
USE dimphy |
|
|
USE suphec_m |
|
|
USE raddim |
|
|
USE raddimlw |
|
3 |
IMPLICIT NONE |
IMPLICIT NONE |
4 |
|
|
5 |
! ----------------------------------------------------------------------- |
contains |
6 |
! PURPOSE. |
|
7 |
! -------- |
SUBROUTINE lwv(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, pbtop, & |
8 |
! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE |
pdbsl, pemis, ppmb, pga, pgb, pgasur, pgbsur, pgatop, pgbtop, & |
9 |
! FLUXES OR RADIANCES |
pcntrb, pcts, pfluc) |
10 |
|
USE dimens_m |
11 |
! METHOD. |
USE dimphy |
12 |
! ------- |
use lwvd_m, only: lwvd |
13 |
|
USE suphec_m |
14 |
! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN |
USE raddim |
15 |
! CONTRIBUTIONS BY - THE NEARBY LAYERS |
USE raddimlw |
16 |
! - THE DISTANT LAYERS |
|
17 |
! - THE BOUNDARY TERMS |
! ----------------------------------------------------------------------- |
18 |
! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. |
! PURPOSE. |
19 |
|
! -------- |
20 |
! REFERENCE. |
! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE |
21 |
! ---------- |
! FLUXES OR RADIANCES |
22 |
|
|
23 |
! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND |
! METHOD. |
24 |
! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS |
! ------- |
25 |
|
|
26 |
! AUTHOR. |
! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN |
27 |
! ------- |
! CONTRIBUTIONS BY - THE NEARBY LAYERS |
28 |
! JEAN-JACQUES MORCRETTE *ECMWF* |
! - THE DISTANT LAYERS |
29 |
|
! - THE BOUNDARY TERMS |
30 |
! MODIFICATIONS. |
! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES. |
31 |
! -------------- |
|
32 |
! ORIGINAL : 89-07-14 |
! REFERENCE. |
33 |
! ----------------------------------------------------------------------- |
! ---------- |
34 |
|
|
35 |
! * ARGUMENTS: |
! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND |
36 |
INTEGER kuaer, ktraer, klim |
! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS |
37 |
|
|
38 |
DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS |
! AUTHOR. |
39 |
DOUBLE PRECISION pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS |
! ------- |
40 |
DOUBLE PRECISION pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS |
! JEAN-JACQUES MORCRETTE *ECMWF* |
41 |
DOUBLE PRECISION pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION |
|
42 |
DOUBLE PRECISION pbsuin(kdlon) ! SURFACE PLANCK FUNCTION |
! MODIFICATIONS. |
43 |
DOUBLE PRECISION pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION |
! -------------- |
44 |
DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT |
! ORIGINAL : 89-07-14 |
45 |
DOUBLE PRECISION pemis(kdlon) ! SURFACE EMISSIVITY |
! ----------------------------------------------------------------------- |
46 |
DOUBLE PRECISION ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB) |
|
47 |
DOUBLE PRECISION ptave(kdlon, kflev) ! TEMPERATURE |
! * ARGUMENTS: |
48 |
DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS |
INTEGER kuaer, ktraer, klim |
49 |
DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS |
|
50 |
DOUBLE PRECISION pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS |
DOUBLE PRECISION pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS |
51 |
DOUBLE PRECISION pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS |
DOUBLE PRECISION pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS |
52 |
DOUBLE PRECISION pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS |
DOUBLE PRECISION pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS |
53 |
DOUBLE PRECISION pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS |
DOUBLE PRECISION pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION |
54 |
|
DOUBLE PRECISION pbsuin(kdlon) ! SURFACE PLANCK FUNCTION |
55 |
DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX |
DOUBLE PRECISION pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION |
56 |
DOUBLE PRECISION pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM |
DOUBLE PRECISION pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT |
57 |
DOUBLE PRECISION pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES |
DOUBLE PRECISION pemis(kdlon) ! SURFACE EMISSIVITY |
58 |
! ----------------------------------------------------------------------- |
DOUBLE PRECISION ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB) |
59 |
! LOCAL VARIABLES: |
DOUBLE PRECISION pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS |
60 |
DOUBLE PRECISION zadjd(kdlon, kflev+1) |
DOUBLE PRECISION pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS |
61 |
DOUBLE PRECISION zadju(kdlon, kflev+1) |
DOUBLE PRECISION pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS |
62 |
DOUBLE PRECISION zdbdt(kdlon, ninter, kflev) |
DOUBLE PRECISION pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS |
63 |
DOUBLE PRECISION zdisd(kdlon, kflev+1) |
DOUBLE PRECISION pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS |
64 |
DOUBLE PRECISION zdisu(kdlon, kflev+1) |
DOUBLE PRECISION pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS |
65 |
|
|
66 |
INTEGER jk, jl |
DOUBLE PRECISION pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX |
67 |
! ----------------------------------------------------------------------- |
DOUBLE PRECISION pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM |
68 |
|
DOUBLE PRECISION pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES |
69 |
DO jk = 1, kflev + 1 |
! ----------------------------------------------------------------------- |
70 |
DO jl = 1, kdlon |
! LOCAL VARIABLES: |
71 |
zadjd(jl, jk) = 0. |
DOUBLE PRECISION zadjd(kdlon, kflev+1) |
72 |
zadju(jl, jk) = 0. |
DOUBLE PRECISION zadju(kdlon, kflev+1) |
73 |
zdisd(jl, jk) = 0. |
DOUBLE PRECISION zdbdt(kdlon, ninter, kflev) |
74 |
zdisu(jl, jk) = 0. |
DOUBLE PRECISION zdisd(kdlon, kflev+1) |
75 |
|
DOUBLE PRECISION zdisu(kdlon, kflev+1) |
76 |
|
|
77 |
|
INTEGER jk, jl |
78 |
|
! ----------------------------------------------------------------------- |
79 |
|
|
80 |
|
DO jk = 1, kflev + 1 |
81 |
|
DO jl = 1, kdlon |
82 |
|
zadjd(jl, jk) = 0. |
83 |
|
zadju(jl, jk) = 0. |
84 |
|
zdisd(jl, jk) = 0. |
85 |
|
zdisu(jl, jk) = 0. |
86 |
|
END DO |
87 |
END DO |
END DO |
|
END DO |
|
88 |
|
|
89 |
DO jk = 1, kflev |
DO jk = 1, kflev |
90 |
DO jl = 1, kdlon |
DO jl = 1, kdlon |
91 |
pcts(jl, jk) = 0. |
pcts(jl, jk) = 0. |
92 |
|
END DO |
93 |
END DO |
END DO |
|
END DO |
|
94 |
|
|
95 |
! * CONTRIBUTION FROM ADJACENT LAYERS |
! * CONTRIBUTION FROM ADJACENT LAYERS |
96 |
|
|
97 |
|
CALL lwvn(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, pcntrb, & |
98 |
|
zdbdt) |
99 |
|
! * CONTRIBUTION FROM DISTANT LAYERS |
100 |
|
|
101 |
CALL lwvn(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, pcntrb, & |
CALL lwvd(ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, zdisu) |
|
zdbdt) |
|
|
! * CONTRIBUTION FROM DISTANT LAYERS |
|
102 |
|
|
103 |
CALL lwvd(kuaer, ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, zdisu) |
! * EXCHANGE WITH THE BOUNDARIES |
104 |
|
|
105 |
! * EXCHANGE WITH THE BOUNDARIES |
CALL lwvb(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, pbsuin, & |
106 |
|
pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, & |
107 |
|
pgatop, pgbtop, pcts, pfluc) |
108 |
|
|
|
CALL lwvb(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, pbsuin, & |
|
|
pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, & |
|
|
pgatop, pgbtop, pcts, pfluc) |
|
109 |
|
|
110 |
|
RETURN |
111 |
|
END SUBROUTINE lwv |
112 |
|
|
113 |
RETURN |
end module lwv_m |
|
END SUBROUTINE lwv |
|