c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
c$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
*=*=*=*= flus.html =*=*=*=*
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