c************************************************************************ subroutine leaf_extinction(N_layer, tauv,tauh) c************************************************************************ integer nl parameter(nl=250) complex th,tv complex tauh(nl),tauv(nl) real d,del_leaf,z_lc,hole common /layer_struct/ d,del_leaf,z_lc,hole real z_delta,z integer N_layer,layer integer l_tensor_flag,l_tau_flag,l_field_flag(2,4) common /leaf_flags/ l_tensor_flag,l_tau_flag,l_field_flag l_tau_flag=0 z_delta=-d/N_layer do layer=1,N_layer z=layer*z_delta call leaf_tau(z, tv,th) tauh(layer)=th tauv(layer)=tv enddo return end c************************************************************************ subroutine leaf_tau(z, tauv,tauh) c************************************************************************ integer v,h parameter(v=1) parameter(h=2) complex ii,coef_fs,coef_ks complex tauh,tauv complex tauh_ka,tauv_ka complex tauh_ks,tauv_ks complex leaf_fs_int complex leaf_ks_int real pi,mpi real z,int_z real N_lpcc integer pol,mech,mech_c common/index/ pol,mech,mech_c real theta_i,phi_i,k_0 common /incident/ theta_i,phi_i,k_0 complex leaf_fs_ave_h,leaf_fs_ave_v complex leaf_ks_ave_h,leaf_ks_ave_v common /store_lt/ leaf_fs_ave_h,leaf_fs_ave_v, & leaf_ks_ave_h,leaf_ks_ave_v real N_ppscm common /unfrm_data/ N_ppscm real d,del_leaf,z_lc,hole common /layer_struct/ d,del_leaf,z_lc,hole integer N_leaf common /leaf_number/ N_leaf integer l_tensor_flag,l_tau_flag,l_field_flag(2,4) common /leaf_flags/ l_tensor_flag,l_tau_flag,l_field_flag external leaf_fs_int,leaf_ks_int ii=cmplx(0.0,1.0) pi=3.14159265 mpi=-pi N_lpcc=N_leaf*N_ppscm/del_leaf coef_fs=(ii*2.0*pi*N_lpcc/k_0) coef_ks=(-N_lpcc/2.0) if(z .gt. z_lc+(del_leaf/2.0))then int_z=0.0 else if(z .lt. z_lc-(del_leaf/2.0))then int_z=-del_leaf else int_z=(z-(z_lc+del_leaf/2.0)) endif if(int_z .eq. 0.0)then tauh=cmplx(0.0,0.0) tauv=cmplx(0.0,0.0) else if (l_tau_flag .eq. 0) then pol=h call integral1(leaf_fs_int,mpi,pi, leaf_fs_ave_h) write(6,*) 'leaf_fs_ave_h = ',leaf_fs_ave_h call integral1(leaf_ks_int,mpi,pi, leaf_ks_ave_h) pol=v call integral1(leaf_fs_int,mpi,pi, leaf_fs_ave_v) write(6,*) 'leaf_fs_ave_v = ',leaf_fs_ave_v call integral1(leaf_ks_int,mpi,pi, leaf_ks_ave_v) l_tau_flag=1 tauh_ka=coef_fs*leaf_fs_ave_h*int_z tauv_ka=coef_fs*leaf_fs_ave_v*int_z tauh_ks=coef_ks*leaf_ks_ave_h*int_z tauv_ks=coef_ks*leaf_ks_ave_v*int_z tauh=tauh_ka+tauh_ks tauv=tauv_ka+tauv_ks print*,'tauh,tauh_ka,tauh_ks' print*,tauh,tauh_ka,tauh_ks print*,'tauv,tauv_ka,tauv_ks' print*,tauv,tauv_ka,tauv_ks else tauh_ka=coef_fs*leaf_fs_ave_h*int_z tauv_ka=coef_fs*leaf_fs_ave_v*int_z tauh_ks=coef_ks*leaf_ks_ave_h*int_z tauv_ks=coef_ks*leaf_ks_ave_v*int_z tauh=tauh_ka+tauh_ks tauv=tauv_ka+tauv_ks endif return end c************************************************************************ complex function leaf_fs_int(phii) c************************************************************************ complex result,g_lt real vmin,vmax real phi,v real phii real leaf_alpha_pdf common /leaf_limits/ vmin,vmax common /leaf_state/ phi,v external g_lt phi=phii call integral2(g_lt,vmin,vmax, result) leaf_fs_int=result*leaf_alpha_pdf(phi) c write(6,*)'leaf_fs_int = ',leaf_fs_int return end c************************************************************************ complex function g_lt(vv) c************************************************************************ complex leaf_forward_scat complex lfs real lvp real vv real leaf_v_pdf real phi,v common /leaf_state/ phi,v integer pol,mech,mech_c common/index/ pol,mech,mech_c v=vv lfs=leaf_forward_scat(phi,v,pol) lvp=leaf_v_pdf(v) g_lt=lfs*lvp c print*,'leaf_forward_scat= ',lfs,phi,v,pol,g_lt c g_lt=leaf_forward_scat(phi,v,pol)*leaf_v_pdf(v) return end c************************************************************************ complex function leaf_ks_int(phii) c************************************************************************ complex result,g_lks real vmin,vmax real phi,v real phii real leaf_alpha_pdf common /leaf_limits/ vmin,vmax common /leaf_state/ phi,v external g_lks phi=phii call integral2(g_lks,vmin,vmax, result) leaf_ks_int=result*leaf_alpha_pdf(phi) c write(6,*)'leaf_ks_int = ',leaf_ks_int return end c************************************************************************ complex function g_lks(vv) c************************************************************************ complex leaf_ks complex lks real lvp real vv real leaf_v_pdf real phi,v common /leaf_state/ phi,v integer pol,mech,mech_c common/index/ pol,mech,mech_c v=vv lks=leaf_ks(phi,v,pol) lvp=leaf_v_pdf(v) g_lks=lks*lvp c print*,'leaf_forward_scat= ',lks,phi,v,pol c g_lks=leaf_forward_scat(phi,v,pol)*leaf_v_pdf(v) return end