c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ *=*=*=*= flus.html =*=*=*=*
subroutine flus

subroutine flus


      subroutine flus(nq,n,omega,g,tau,emis,bh,bsol,fah,fdh)
c.......................................................................
c
c  calcul des flux ascendant et descendant aux interfaces entre n couches
c  * dans l'infrarouge
c  * B est une fonction lineaire de $\tau$ a l'interieur de chaque couche
c  * le B du sol peut etre different de celui qui correspond au profil
c    de la n-ieme couche
c  * l'hypothese est une hypothese a deux flux isotropes sur chaque
c    hemisphere ("hemispheric constant") + "source function technique"
c  * le flux descendant en haut de l'atmosphere est nul
c  * les couches sont numerotees du haut de l'atmosphere vers le sol
c
c  in :   * nq         ---> ordre de la quadrature
c         * n          ---> nombre de couches
c         * omega(i)   ---> single scattering albedo pour la i-eme couche
c         * g(i)       ---> asymmetry parameter pour la i-eme couche
c         * tau(i)     ---> epaisseur optique de la i-eme couche
c         * emis       ---> emissivite du sol
c         * bh(i)      ---> luminance du corps noir en haut de la i-eme
c                           couche, bh(n+1) pour la valeur au sol qui
c                           correspond au profil de la n-ieme couche
c         * bsol       ---> luminance du corps noir au sol
c
c  out :  * fah(i)     ---> flux ascendant en haut de la i-eme couche,
c                           fah(n+1) pour le sol
c         * fdh(i)     ---> flux descendant en haut de la i-eme couche,
c                           fdh(n+1) pour le sol
c
c  Remarque :     Cette subroutine est tres lente et (de plus) elle est
c                 intolerablement lente : elle recalcule les coefficients
c                 de la quadrature a chaque appel (intolerable).
c
c.......................................................................
      implicit double precision (a-h,o-z)
      parameter (pi=3.141592653589793d0)
      parameter (nqmax=20)
      parameter (nmax=100)
c.......................................................................
      dimension omega(nmax),g(nmax),tau(nmax)
     &,bh(nmax+1),fah(nmax+1),fdh(nmax+1)
c.......................................................................
      dimension a(2*nmax),b(2*nmax),d(2*nmax),e(2*nmax),y(2*nmax)
     &,alambda(nmax)
     &,e1(nmax),e2(nmax),e3(nmax),e4(nmax)
     &,cah(nmax),cab(nmax),cdh(nmax),cdb(nmax)
c.......................................................................
      dimension grg(nmax),grh(nmax),grj(nmax),grk(nmax)
     &,alpha1(nmax),alpha2(nmax),sigma1(nmax),sigma2(nmax)
c.......................................................................
      dimension x(nqmax),w(nqmax),gri(nqmax)
c.......................................................................
      if (nq.gt.nqmax) print *,'Oh ! (1) --> flus.f'
      if (n.gt.nmax) print *,'Oh ! (2) --> flus.f'
c.......................................................................
      do 10001 i=1,n
c
      beta=(1.d0-g(i))/2.d0
      gama1=2.d0*(1.d0-omega(i)*(1.d0-beta))
      gama2=2.d0*omega(i)*beta
      amu1=0.5d0
      alambda(i)=dsqrt(gama1**2-gama2**2)
      grgama=(gama1-alambda(i))/gama2
      b0=bh(i)
      b1=(bh(i+1)-b0)/tau(i)
c
      e1(i)=1.d0+grgama*dexp(-alambda(i)*tau(i))
      e2(i)=1.d0-grgama*dexp(-alambda(i)*tau(i))
      e3(i)=grgama+dexp(-alambda(i)*tau(i))
      e4(i)=grgama-dexp(-alambda(i)*tau(i))
      cah(i)=2.d0*pi*amu1*(b0+b1/(gama1+gama2))
      cab(i)=2.d0*pi*amu1*(b0+b1*(tau(i)+1.d0/(gama1+gama2)))
      cdh(i)=2.d0*pi*amu1*(b0-b1/(gama1+gama2))
      cdb(i)=2.d0*pi*amu1*(b0+b1*(tau(i)-1.d0/(gama1+gama2)))
c
      grg(i)=(1.d0/amu1-alambda(i))
      grh(i)=grgama*(alambda(i)+1.d0/amu1)
      grj(i)=grh(i)
      grk(i)=grg(i)
      alpha1(i)=2.d0*pi*(b0+b1*(1.d0/(gama1+gama2)-amu1))
      alpha2(i)=2.d0*pi*b1
      sigma1(i)=2.d0*pi*(b0-b1*(1.d0/(gama1+gama2)-amu1))
      sigma2(i)=alpha2(i)
c
10001 continue
c.......................................................................
      a(1)=0.d0
      b(1)=e1(1)
      d(1)=-e2(1)
      e(1)=-cdh(1)
c
      do 10002 i=1,n-1
      j=2*i+1
      a(j)=e2(i)*e3(i)-e4(i)*e1(i)
      b(j)=e1(i)*e1(i+1)-e3(i)*e3(i+1)
      d(j)=e3(i)*e4(i+1)-e1(i)*e2(i+1)
      e(j)=e3(i)*(cah(i+1)-cab(i))+e1(i)*(cdb(i)-cdh(i+1))
10002 continue
c
      do 10003 i=1,n-1
      j=2*i
      a(j)=e2(i+1)*e1(i)-e3(i)*e4(i+1)
      b(j)=e2(i)*e2(i+1)-e4(i)*e4(i+1)
      d(j)=e1(i+1)*e4(i+1)-e2(i+1)*e3(i+1)
      e(j)=e2(i+1)*(cah(i+1)-cab(i))+e4(i+1)*(cdb(i)-cdh(i+1))
10003 continue
c
      j=2*n
      a(j)=e1(n)-(1.d0-emis)*e3(n)
      b(j)=e2(n)-(1.d0-emis)*e4(n)
      d(j)=0.d0
      e(j)=emis*pi*bsol-cab(n)+(1.d0-emis)*cdb(n)
c.......................................................................
      call sys3(2*n,a,b,d,e,y)
c.......................................................................
      do 10004 i=1,n
      grg(i)=grg(i)*(y(2*i-1)+y(2*i))
      grh(i)=grh(i)*(y(2*i-1)-y(2*i))
      grj(i)=grj(i)*(y(2*i-1)+y(2*i))
      grk(i)=grk(i)*(y(2*i-1)-y(2*i))
10004 continue
c.......................................................................
c les valeurs de flux "hemispheric pur"
c
      if (nq.eq.0) then
      do 10005 i=1,n
      fah(i)=e3(i)*y(2*i-1)-e4(i)*y(2*i)+cah(i)
      fdh(i)=e1(i)*y(2*i-1)-e2(i)*y(2*i)+cdh(i)
10005 continue
      fah(n+1)=e1(n)*y(2*n-1)+e2(n)*y(2*n)+cab(n)
      fdh(n+1)=e3(n)*y(2*n-1)+e4(n)*y(2*n)+cdb(n)
      goto 10100
      endif
c.......................................................................
c passage a "source function"
c
c x est le vecteur des \mu de la quadrature
c w est le vecteur des poids correspondants
c
      call gauleg(0.d0,1.d0,x,w,nq)
c.......................................................................
c on part d'en haut et on descent selon les nq angles pour calculer
c tous les flux descendants
c
      do 10006 j=1,nq
      gri(j)=0.d0
10006 continue
      fdh(1)=0.d0
      do 10007 i=1,n
      do 10008 j=1,nq
      gri(j)=gri(j)*dexp(-tau(i)/x(j))
     &+grj(i)/(alambda(i)*x(j)+1.d0)
     &*(1.d0-dexp(-tau(i)*(alambda(i)+1.d0/x(j))))
     &+grk(i)/(alambda(i)*x(j)-1.d0)
     &*(dexp(-tau(i)/x(j))-dexp(-tau(i)*alambda(i)))
     &+sigma1(i)*(1.d0-dexp(-tau(i)/x(j)))
     &+sigma2(i)*(x(j)*dexp(-tau(i)/x(j))+tau(i)-x(j))
10008 continue
      fdh(i+1)=0.d0
      do 10009 j=1,nq
      fdh(i+1)=fdh(i+1)+w(j)*x(j)*gri(j)
10009 continue
10007 continue
c.......................................................................
c on applique la condition de reflexion a sol
c
      fah(n+1)=(1.d0-emis)*fdh(n+1)+pi*emis*bsol
      do 10010 j=1,nq
      gri(j)=2.d0*fah(n+1)
10010 continue
c.......................................................................
c on remonte pour calculer tous les flux ascendants
c
      do 10011 i=n,1,-1
      do 10012 j=1,nq
      gri(j)=gri(j)*dexp(-tau(i)/x(j))
     &+grg(i)/(alambda(i)*x(j)-1.d0)
     &*(dexp(-tau(i)/x(j))-dexp(-tau(i)*alambda(i)))
     &+grh(i)/(alambda(i)*x(j)+1.d0)
     &*(1.d0-dexp(-tau(i)*(alambda(i)+1.d0/x(j))))
     &+alpha1(i)*(1.d0-dexp(-tau(i)/x(j)))
     &+alpha2(i)*(x(j)-(tau(i)+x(j))*dexp(-tau(i)/x(j)))
10012 continue
      fah(i)=0.d0
      do 10013 j=1,nq
      fah(i)=fah(i)+w(j)*x(j)*gri(j)
10013 continue
10011 continue
c.......................................................................
10100 continue
c.......................................................................
      return
      end