source: trunk/MESOSCALE/LMDZ.MARS/libf_gcm/phymars/lwmain.F @ 1242

Last change on this file since 1242 was 57, checked in by aslmd, 14 years ago

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