source: trunk/LMDZ.MARS/libf/phymars/lwmain_mod.F @ 3807

Last change on this file since 3807 was 3757, checked in by emillour, 2 months ago

Mars PCM:
More code tidying: puting routines in modules and modernizing some old
constructs. Tested to not change results with respect to previous version.
EM

File size: 7.7 KB
Line 
1       MODULE lwmain_mod
2
3       IMPLICIT NONE
4
5       CONTAINS
6       
7       subroutine lwmain (ig0,icount,kdlon,kflev
8     .                   ,dp,dt0,emis
9     .                   ,plev,tlev,tlay,aerosol,coolrate
10     .                   ,fluxground,fluxtop
11     .                   ,netrad
12     &                   ,QIRsQREF3d,omegaIR3d,gIR3d
13     &                   ,co2ice)
14
15c----------------------------------------------------------------------
16c     LWMAIN     organizes the LTE longwave calculations
17c     for layer 1 to layer "nlaylte" (stored in  "yomlw_h")
18c----------------------------------------------------------------------
19
20      use dimradmars_mod, only: ndlo2, nflev, nir, ndlon, nuco2
21      use dimradmars_mod, only: naerkind
22      use yomlw_h, only: nlaylte, xi
23      use lwi_mod, only: lwi
24      use lwb_mod, only: lwb
25      use lwu_mod, only: lwu
26      use lwxd_mod, only: lwxd
27      use lwxn_mod, only: lwxn
28      use lwxb_mod, only: lwxb
29      use lwflux_mod, only: lwflux
30      use callkeys_mod, only: ilwb, ilwd, ilwn
31     
32      implicit none
33     
34c----------------------------------------------------------------------
35c         0.1   arguments
36c               ---------
37c     inputs/outputs:
38c     -------
39      integer, intent(in) :: ig0
40      integer, intent(in) :: icount
41      integer, intent(in) :: kdlon            ! part of ngrid
42      integer, intent(in) :: kflev            ! part of nlayer
43
44      real, intent(in) :: dp (ndlo2,kflev)         ! layer pressure thickness (Pa)
45      real, intent(in) :: dt0 (ndlo2)              ! surface temperature discontinuity (K)
46      real, intent(in) :: emis (ndlo2)             ! surface emissivity
47      real, intent(in) :: plev (ndlo2,kflev+1)     ! level pressure (Pa)
48      real, intent(in) :: tlev (ndlo2,kflev+1)     ! level temperature (K)
49      real, intent(in) :: tlay (ndlo2,kflev)       ! layer temperature (K)
50      real, intent(in) :: aerosol(ndlo2,kflev,naerkind)      !  aerosol extinction optical
51c                         depth at reference wavelength "longrefvis" set
52c                         in dimradmars_mod , in each layer, for one of
53c                         the "naerkind" kind of aerosol optical properties.
54
55
56c                                                            outputs:
57c                                                            --------
58      real, intent(out) :: coolrate(ndlo2,kflev)      ! cooling rate (K/s)
59      real, intent(out) :: fluxground(ndlo2)          ! downward ground flux (W/m2)
60      real, intent(out) :: fluxtop(ndlo2)             ! outgoing upward flux (W/m2) ("OLR")
61      real, intent(out) :: netrad (ndlo2,kflev)       ! radiative budget (W/m2)
62c     Aerosol optical properties
63      real, intent(in) :: QIRsQREF3d(ndlo2,kflev,nir,naerkind)
64      real, intent(in) :: omegaIR3d(ndlo2,kflev,nir,naerkind)
65      real, intent(in) :: gIR3d(ndlo2,kflev,nir,naerkind)
66      real, intent(in) :: co2ice(ndlo2)           ! co2 ice surface layer (kg.m-2)
67c----------------------------------------------------------------------
68c         0.2   local arrays
69c               ------------
70
71      real aer_t (ndlon,nuco2,nflev+1)  ! transmission (aer)
72      real co2_u (ndlon,nuco2,nflev+1)  ! absorber amounts (co2)
73      real co2_up (ndlon,nuco2,nflev+1) ! idem scaled by the pressure (co2)
74
75      real bsurf (ndlon,nir)            ! surface spectral planck function
76      real btop (ndlon,nir)             ! top spectral planck function
77      real blev (ndlon,nir,nflev+1)     ! level   spectral planck function
78      real blay (ndlon,nir,nflev)       ! layer   spectral planck function
79      real dblay (ndlon,nir,nflev)      ! layer gradient spectral planck function
80      real dbsublay (ndlon,nir,2*nflev) ! layer gradient spectral planck function
81                                        ! in sub layers
82
83      real tautotal(ndlon,nflev,nir)  ! \   Total single scattering
84      real omegtotal(ndlon,nflev,nir) !  >  properties (Addition of the
85      real gtotal(ndlon,nflev,nir)    ! /   NAERKIND aerosols prop.)
86
87      real newcoolrate(ndlon,nflev) ! cooling rate (K/s) / with implicite scheme
88
89      real emis_gaz(ndlo2)         ! emissivity for gaz computations
90
91      integer jk,jkk,ja,jl
92
93
94c----------------------------------------------------------------------
95c         0.3   Initialisation
96c               --------------
97
98      DO jl=1 , kdlon
99         IF(co2ice(jl) .GT. 20.e-3) THEN
100             emis_gaz(jl)=1.
101         ELSE
102             emis_gaz(jl)=emis(jl)
103         ENDIF
104      ENDDO
105
106c----------------------------------------------------------------------
107c         1.0   planck function
108c               ---------------
109
110      call lwb ( kdlon, kflev, tlev, tlay, dt0
111     .         , bsurf, btop, blay, blev, dblay, dbsublay)
112
113c----------------------------------------------------------------------
114c         2.0   absorber amounts
115c               ----------------
116
117      call lwu ( kdlon, kflev
118     .         , dp, plev, tlay, aerosol
119     &         , QIRsQREF3d,omegaIR3d,gIR3d
120     .         , aer_t, co2_u, co2_up
121     .         , tautotal,omegtotal,gtotal)
122
123c----------------------------------------------------------------------
124c         3.0   transmission functions / exchange coefficiants
125c               ----------------------------------------------
126
127c                                                                distants
128c                                                                --------
129                    if( mod(icount-1,ilwd).eq.0) then
130
131c     print*, 'CALL of DISTANTS'
132      call lwxd ( ig0, kdlon, kflev, emis_gaz
133     .          , aer_t, co2_u, co2_up)
134
135                    endif
136c                                                              neighbours
137c                                                              ----------
138                    if( mod(icount-1,ilwn).eq.0) then
139
140c     print*, 'CALL of NEIGHBOURS'
141      call lwxn ( ig0, kdlon, kflev
142     .          , dp
143     .          , aer_t, co2_u, co2_up)
144
145                    endif
146c                                                              boundaries
147c                                                              ----------
148                    if( mod(icount-1,ilwb).eq.0) then
149
150c     print*, 'CALL of BOUNDARIES'
151      call lwxb ( ig0, kdlon, kflev, emis_gaz
152     .          , aer_t, co2_u, co2_up)
153
154                    endif
155
156c----------------------------------------------------------------------
157c         4.0   cooling rate
158c               ------------
159
160      call lwflux ( ig0, kdlon, kflev, dp
161     .            , bsurf, btop, blev, blay, dbsublay
162     .            , tlay, tlev, dt0      ! pour sortie dans g2d uniquement
163     .            , emis
164     .            , tautotal,omegtotal,gtotal
165     .            , coolrate, fluxground, fluxtop
166     .            , netrad)
167
168c     do jk = 1, nlaylte
169c       print*,coolrate(1,jk)
170c     enddo
171     
172c       do jkk = 0 , nlaylte+1
173c         do jk = 0 , nlaylte+1
174c           do ja = 1 , nuco2
175c             do jl = 1 , ngrid
176c      if (xi (jl,ja,jk,jkk) .LT. 0
177c    .       .OR. xi (jl,ja,jk,jkk) .GT. 1 ) then
178c                 print*,'xi bande',ja,jk,jkk,xi (jl,ja,jk,jkk)
179c      endif
180c             enddo
181c           enddo
182c         enddo
183c       enddo
184
185c----------------------------------------------------------------------
186c
187c          5.    shema semi-implicite  (lwi)
188c                ---------------------------
189c
190c
191      call lwi (ig0,kdlon,kflev,netrad,dblay,dp
192     .          , newcoolrate)
193c
194c  Verif que   (X sol,space) + somme(X i,sol) = 1
195c
196      do jkk = 1 , nlaylte
197        do jl = 1 , kdlon
198c     print*,'NEW et OLD coolrate :',jkk,newcoolrate(jl,jkk)
199c    .  ,coolrate(jl,jkk)
200      coolrate(jl,jkk) = newcoolrate(jl,jkk)
201        enddo
202      enddo
203c
204c----------------------------------------------------------------------
205
206      END SUBROUTINE lwmain
207
208      END MODULE lwmain_mod
209
Note: See TracBrowser for help on using the repository browser.