*=*=*=*= lwflux.html =*=*=*=*
subroutine lwflux (ig0,kdlon,kflev,dp . ,bsurf,btop,blev,blay,dbsublay . ,tlay, tlev, dt0 ! pour sortie dans g2d uniquement . ,aer_u,emis . ,coolrate,fluxground . ,netrad) c---------------------------------------------------------------------- c LWFLUX computes the fluxes c---------------------------------------------------------------------- implicit none c#define undim #include "dimensions.h" #include "dimphys.h" #include "dimradmars.h" #include "callkeys.h" #include "comg1d.h" #include "yomcst.h" #include "yomrad.h" #include "yomrdu.h" #include "yomaer.h" #include "yomsw.h" #include "yomlw.h" c---------------------------------------------------------------------- c 0.1 arguments c --------- c inputs: c ------- integer ig0 ! integer kdlon ! part of ngrid integer kflev ! part of nlayer real dp (ndlo2,kflev) ! layer pressure thickness (Pa) real bsurf (ndlo2,nir) ! surface spectral planck function real blev (ndlo2,nir,kflev+1) ! level spectral planck function real blay (ndlo2,nir,kflev) ! layer spectral planck function real btop (ndlo2,nir) ! top spectral planck function real dbsublay (ndlo2,nir,2*kflev) ! layer gradient spectral planck ! function in sub layers real dt0 (ndlo2) ! surface temperature discontinuity real tlay (ndlo2,kflev) ! layer temperature real tlev (ndlo2,kflev+1) ! level temperature real aer_u (ndlo2,nir,kflev+1) ! transmission (aer) real emis (ndlo2) ! surface emissivity c outputs: c -------- real coolrate(ndlo2,kflev) ! radiative cooling rate (K/j) real netrad (ndlo2,kflev) ! radiative budget (W/m2) real fluxground(ndlo2) ! downward flux on the ground ! for surface radiative budget c---------------------------------------------------------------------- c 0.2 local arrays c ------------ integer ja,jl,j,i,ig1d,ig real ksidb (ndlon,nuco2+1,0:nflev+1,0:nflev+1) ! net exchange rate (W/m2) real dpscday (0:nflev+1,0:nflev+1) ! dp/cday real temp (0:nflev+1,0:nflev+1) real fluxdiff(ndlon,2,nflev+1) ! diffusion flux: upward(1) downward(2) real*4 reel4 real xi (ngridmx,nuco2,0:nlayermx+1,0:nlayermx+1) real xi_ground (ngridmx,nuco2) common/ksicom/xi,xi_ground c---------------------------------------------------------------------- c 1.1 exchanges (layer i <--> all layers up to i) c ------------------------------------------- do i = 1,kflev do j = i+1,kflev do ja = 1,nuco2 do jl = 1,kdlon ksidb(jl,ja,i,j) = xi(ig0+jl,ja,i,j) . * (blay(jl,ja,j)-blay(jl,ja,i)) c ksidb reciprocity c ----------------- ksidb(jl,ja,j,i) = -ksidb(jl,ja,i,j) enddo enddo enddo enddo c---------------------------------------------------------------------- c 1.2 exchanges (ground <--> all layers) c ---------------------------------- do i = 1,kflev do ja = 1,nuco2 do jl = 1,kdlon ksidb(jl,ja,i,0) = xi(ig0+jl,ja,0,i) . * (bsurf(jl,ja)-blay(jl,ja,i)) c ksidb reciprocity c ----------------- ksidb(jl,ja,0,i) = -ksidb(jl,ja,i,0) enddo enddo enddo c-------------------------------------------------------- c Here we add the neighbour contribution c for exchanges between ground and first layer c-------------------------------------------------------- do ja = 1,nuco2 do jl = 1,kdlon ksidb(jl,ja,1,0) = ksidb(jl,ja,1,0) . - xi_ground(ig0+jl,ja) . * (blev(jl,ja,1)-blay(jl,ja,1)) cc ksidb reciprocity cc ----------------- ksidb(jl,ja,0,1) = - ksidb(jl,ja,1,0) enddo enddo c---------------------------------------------------------------------- c 1.3 exchanges (layer i <--> space) c ------------------------------ do i = 1,kflev do ja = 1,nuco2 do jl = 1,kdlon ksidb(jl,ja,i,kflev+1) = xi(ig0+jl,ja,i,kflev+1) . * (-blay(jl,ja,i)) c ksidb reciprocity c ----------------- ksidb(jl,ja,kflev+1,i) = - ksidb(jl,ja,i,kflev+1) enddo enddo enddo c---------------------------------------------------------------------- c 1.4 exchanges (ground <--> space) c ----------------------------- do ja = 1,nuco2 do jl = 1,kdlon ksidb(jl,ja,0,kflev+1) = xi(ig0+jl,ja,0,kflev+1) . * (-bsurf(jl,ja)) c ksidb reciprocity c ----------------- ksidb(jl,ja,kflev+1,0) = - ksidb(jl,ja,0,kflev+1) enddo enddo c---------------------------------------------------------------------- c 2.0 sum of band 1 and 2 of co2 contribution c --------------------------------------- do i = 0,kflev+1 do j = 0,kflev+1 do jl = 1,kdlon ksidb(jl,3,i,j)= ksidb(jl,1,i,j) + ksidb(jl,2,i,j) enddo enddo enddo c---------------------------------------------------------------------- c 3.0 Diffusion c --------- i = kflev+1 do jl = 1,kdlon fluxdiff(jl,1,i) = 0. fluxdiff(jl,2,i) = 0. enddo call lwdiff (kdlon,kflev,aer_u,bsurf,btop,dbsublay . ,emis,fluxdiff) c---------------------------------------------------------------------- c 4.0 Radiative Budget for each layer i c --------------------------------- do i = 1,kflev do jl = 1,kdlon netrad(jl,i) = 0. enddo enddo do i = 1,kflev do j = 0,kflev+1 do jl = 1,kdlon netrad(jl,i) = netrad(jl,i) + ksidb(jl,3,i,j) enddo enddo enddo c diffusion contribution c ---------------------- do i = 1,kflev do jl = 1,kdlon netrad(jl,i) = netrad(jl,i) . - fluxdiff(jl,1,i+1) - fluxdiff(jl,2,i+1) . + fluxdiff(jl,1,i) + fluxdiff(jl,2,i) enddo enddo c---------------------------------------------------------------------- c 4.0 cooling rate for each layer i c ----------------------------- print* do i = 1,kflev do jl = 1,kdlon coolrate(jl,i) = cday * netrad(jl,i) / dp(jl,i) enddo enddo c---------------------------------------------------------------------- c 5.0 downward flux (all layers --> ground): "fluxground" c --------------------------------------------------- do jl = 1,kdlon fluxground(jl) = 0. enddo do i = 1,kflev do ja = 1,nuco2 do jl = 1,kdlon fluxground(jl) = fluxground(jl) . + xi(ig0+jl,ja,0,i) * (-blay(jl,ja,i)) enddo enddo enddo do jl = 1,kdlon fluxground(jl) = fluxground(jl) + fluxdiff(jl,2,1) enddo c---------------------------------------------------------------------- c 6.0 outputs Grads 2D c ---------------- c ig1d: point de la grille physique ou on veut faire la sortie c ig0+1: point du decoupage de la grille physique c ig: point pour les variables decoupees c#ifdef undim if (callg2d) then c ig1d = ngridmx/2 + 1 ig1d = ngridmx if ((ig0+1).LE.ig1d .and. ig1d.LE.(ig0+kdlon) . .OR. ngridmx.EQ.1 ) then ig = ig1d-ig0 print*, 'Sortie g2d: ig1d, ig, ig0', ig1d, ig, ig0 c-------------------------------------------- c Ouverture de g2d.dat c-------------------------------------------- if (g2d_premier) then open (77,file='g2d.dat' & ,form='unformatted',access='direct',recl=4) g2d_irec=0 g2d_appel=0 g2d_premier=.false. endif g2d_appel = g2d_appel+1 c-------------------------------------------- c Sortie g2d des xi proches + distants c-------------------------------------------- if (nlayermx .NE. 500) then do ja = 1,nuco2 do j = 0,kflev+1 do i = 0,kflev+1 g2d_irec=g2d_irec+1 reel4 = xi(ig1d,ja,i,j) write(77,rec=g2d_irec) reel4 enddo enddo enddo endif c------------------------------------------------------ c Writeg2d des ksidb c------------------------------------------------------ do ja = 1,nuco2 c ja=1 do j = 0,kflev+1 do i = 0,kflev+1 g2d_irec=g2d_irec+1 reel4 = ksidb(ig,ja,i,j) write(77,rec=g2d_irec) reel4 enddo enddo enddo do j = 0,kflev+1 do i = 0,kflev+1 g2d_irec=g2d_irec+1 reel4 = ksidb(ig,3,i,j) write(77,rec=g2d_irec) reel4 enddo enddo c------------------------------------------------------ c Writeg2d dpscday c------------------------------------------------------ do j = 1 , kflev do i = 0 , kflev+1 dpscday(i,j) = dp(ig,j) / cday enddo enddo do i = 0 , kflev+1 c dpscday(i,0) = 0.0002 ! (rapport ~ entre 1000 et 10000 pour le sol) dpscday(i,0) = 1. ! (pour regler l'echelle des sorties) dpscday(i,kflev+1) = 0. enddo c print* c print*,'cday: ',cday c print* c do i = 0 , kflev+1 c print*,i,'dp: ',dp(ig,i) c enddo c print* c do i = 0 , kflev+1 c print*,i,'dpscday: ',dpscday(i,1) c enddo do j = 0,kflev+1 do i = 0,kflev+1 g2d_irec=g2d_irec+1 reel4 = dpscday(i,j) write(77,rec=g2d_irec) reel4 enddo enddo c------------------------------------------------------ c Writeg2d temperature c------------------------------------------------------ do j = 1 , kflev do i = 0 , kflev+1 temp(i,j) = tlay(ig,j) enddo enddo do i = 0 , kflev+1 temp(i,0) = tlev(ig,1)+dt0(ig) ! temperature surface temp(i,kflev+1) = 0. ! temperature espace (=0) enddo do j = 0,kflev+1 do i = 0,kflev+1 g2d_irec=g2d_irec+1 reel4 = temp(i,j) write(77,rec=g2d_irec) reel4 enddo enddo write(76,*) 'ig1d, ig, ig0', ig1d, ig, ig0 write(76,*) 'kflev', kflev write(76,*) 'nflev', nflev write(76,*) 'kdlon', kdlon write(76,*) 'ndlo2', ndlo2 write(76,*) 'ndlon', ndlon do ja=1,4 write(76,*) 'bsurf', ja, bsurf(ig,ja) write(76,*) 'btop', ja, btop(ig,ja) do j=1,kflev+1 write(76,*) 'blev', ja, j, blev(ig,ja,j) enddo do j=1,kflev write(76,*) 'blay', ja, j, blay(ig,ja,j) enddo do j=1,2*kflev write(76,*) 'dbsublay', ja, j, dbsublay(ig,ja,j) enddo enddo endif c************************************************************************ c#endif endif ! callg2d return end