c                           disclaimer
c
c   this file was generated by taf version 1.9.69
c
c   fastopt disclaims  all  warranties,  eprior_xess  or  implied,
c   including (without limitation) all implied  warranties  of
c   merchantability  or fitness for a particular purpose, with
c   respect to the software and user programs.   in  no  event
c   shall  fastopt be liable for any lost or anticipated prof-
c   its, or any indirect, incidental, exemplary,  special,  or
c   consequential  damages, whether or not fastopt was advised
c   of the possibility of such damages.
c
c                           haftungsbeschraenkung
c   fastopt gibt ausdruecklich keine gewaehr, explizit oder indirekt,
c   bezueglich der brauchbarkeit  der software  fuer einen bestimmten
c   zweck.   unter  keinen  umstaenden   ist  fastopt   haftbar  fuer
c   irgendeinen verlust oder nicht eintretenden erwarteten gewinn und
c   allen indirekten,  zufaelligen,  exemplarischen  oder  speziellen
c   schaeden  oder  folgeschaeden  unabhaengig  von einer eventuellen
c   mitteilung darueber an fastopt.
c
      subroutine archi_ad( x_lai, x_lai_ad, teta_s )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: teta_s
      double precision :: x_lai(nw)
      double precision :: x_lai_ad(nw)

c locals
      double precision :: tmpr_ad(nw),tmpr(nw),tmpx_ly(nw)
c      print*,'uhu',nw,x_lai_ad,x_lai
c----------------------------------------------
c routine body
c----------------------------------------------
      a_f(1:nw) = (df(1:nw)/2.)**2*pi
      tmpx_ly = x_ly(1:nw)
      call deep(tmpx_ly,teta_s)
      x_ly(1:nw) = tmpx_ly
      tmpr = r(1:nw)
      call sun_fleck(tmpr,teta_s)
      r(1:nw) = tmpr
      h_c_ad(1:nw) = h_c_ad(1:nw)-
     $c1_ad(1:nw)*(2*r*x_lai/(h_c(1:nw)*h_c(1:nw)))
      r_ad(1:nw) = r_ad(1:nw)+c1_ad(1:nw)*(2*x_lai/h_c(1:nw))
      x_lai_ad = x_lai_ad+c1_ad(1:nw)*(2*r/h_c(1:nw))
      c1_ad = 0.
      tmpr_ad = r_ad(1:nw)
      call sun_fleckh_ad( r_ad,teta_s )
      r_ad = 0.
      df_ad(1:nw) = df_ad(1:nw)+a_f_ad(1:nw)*df(1:nw)/2.*pi
      a_f_ad = 0.

      end subroutine archi_ad


      subroutine archi( x_lai, teta_s )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: teta_s
      double precision :: x_lai(nw),tmpx_ly(nw),tmpr(nw)

      a_f(1:nw) = (df(1:nw)/2.)**2*pi
      x_nf(1:nw) = x_lai/(a_f(1:nw)*h_c(1:nw))
c      print*,'x_nf',x_nf
c      print*,'x_lai',x_lai
      tmpx_ly = x_ly(1:nw)
      call deep(tmpx_ly,teta_s)
      x_ly(1:nw) = tmpx_ly
      tmpr = r(1:nw)
      call sun_fleck(tmpr,teta_s)
      r(1:nw) = tmpr
      c1(1:nw) = 2.*r(1:nw)*x_lai/h_c(1:nw)
      end subroutine archi


      subroutine bunnik( ild1 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      integer :: ild1

      ag = 1.
      bg = 1.
      cg = 1.
      dg = 1.
      if (ild1 .eq. 1) then
        dg = 0.
      endif
      if (ild1 .eq. 2) then
        bg = -1.
        dg = 0.
      endif
      if (ild1 .eq. 3) then
        bg = -1.
        cg = 2.
        dg = 0.
      endif
      if (ild1 .eq. 4) then
        cg = 2.
        dg = 0.
      endif
      if (ild1 .eq. 5) then
        ag = 0.
        bg = 0.
        cg = 0.
      endif
      end subroutine bunnik


      subroutine deep( vdeep, teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vdeep(nw)
      double precision :: teta_01

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      double precision :: x_a(nw)

      x_a = 0.005
      call g_ross(help_h,teta_01)
      vdeep = -(log(x_a)*abs(cos(teta_01))/help_h)
      end  subroutine deep


      subroutine energie( teta_i, phi_i, fpar, albedo_sys, trans_totale 
     $)
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: albedo_sys(nw)
      double precision :: fpar(nw)
      double precision :: phi_i
      double precision :: teta_i
      double precision :: trans_totale(nw)

c==============================================
c declare local variables
c==============================================
      double precision :: g_w(32,nw)
      double precision :: gamma_0(32,32,nw)
      double precision :: gs(nw)
      integer :: i
      integer :: j
      integer :: k
      integer :: m0
      double precision :: mm(32,32,nw)
      integer :: mmm
      double precision :: phi_s(nw)
      double precision :: phi_w(nw)
      double precision :: sum_k(nw)
      double precision :: sum_x(nw)
      double precision :: sum_y(nw)
      double precision :: t_i1d(32,32,nw)
      double precision :: teta_s
      double precision :: teta_w
      double precision :: trans_1(nw)
      double precision :: trans_1_in(nw)
      double precision :: trans_in_m(nw)
      double precision :: trans_m(nw)
      double precision :: x
      double precision :: x_lambda(32,32,nw)
      double precision :: x_lambda_0(nw)
      double precision :: x_rho_0(32,32,nw)
      double precision :: x_rho_1(32,32,nw)
      double precision :: x_rho_m(32,32,nw)
      double precision :: xm
      double precision :: xmus
      double precision :: xr
      double precision :: xt_directe(nw)
      double precision :: y(nw)
      double precision :: ym
      double precision :: yr

      double precision :: g_w_h(nw), gamma_0_h(nw)
      double precision :: x_rho_0_h(nw), x_rho_1_h(nw),x_rho_m_h(nw)

c initialise locals
      g_w=0
      gamma_0=0
      gs=0
      m0=0
      mm=0
      mmm=0
      phi_s=0
      phi_w=0
      sum_k=0
      sum_x=0
      sum_y=0
      t_i1d=0
      teta_s=0
      teta_w=0
      trans_1=0
      trans_1_in=0
      trans_in_m=0
      trans_m=0
      x=0
      x_lambda=0
      x_lambda_0=0
      x_rho_0=0
      x_rho_1=0
      x_rho_m=0
      xm=0
      xmus=0
      xr=0
      xt_directe=0
      y=0
      ym=0
      yr=0
c start code
      teta_s = (180.-teta_i)*pi/180.
      phi_s = (180.-phi_i)*pi/180.
      call g_ross(gs,teta_s)
      xmus = cos(teta_s)
      xm = 0.5*(1.-1.)
      xr = 0.5*(1.+1.)
      ym = 0.5*(2.*pi-0.)
      yr = 0.5*(2.*pi+0.)
      do j = 1, number
        x = xm+xr*points(j)
        teta_w = acos(x)
        call  g_ross(g_w_h,teta_w)
        g_w(j,:) = g_w_h
      end do
      do i = 1, number
        y = ym+yr*points(i)
        phi_w = y
        do j = 1, number
          x = xm+xr*points(j)
          teta_w = acos(x)
          x_lambda(i,j,:) = 0.01*abs(cos(teta_s))/gs*
     $abs(cos(teta_w))/g_w(j,:)
          mm(i,j,:) = lai(1:nw)/x_lambda(i,j,:)
          call rho_0_nad(x_rho_0_h,teta_w,phi_w(1),x_lambda(i,j,:))
          x_rho_0(i,j,:) = x_rho_0_h
          call rho_1_nad(x_rho_1_h,teta_w,phi_w(1),x_lambda(i,j,:))
          x_rho_1(i,j,:) = x_rho_1_h
          call rho_mult_nad(x_rho_m_h,teta_w)
          x_rho_m(i,j,:) = x_rho_m_h
        end do
      end do
      sum_y = 0.
      do i = 1, number
        y = ym+yr*points(i)
        sum_x = 0.
        do j = number/2+1, number
          x = xm+xr*points(j)
          sum_x = sum_x+(x_rho_0(i,j,:)+x_rho_1(i,j,:)
     $+x_rho_m(i,j,:))*weights(j)*abs(x)*xr
        end do
        sum_y = sum_y+sum_x*weights(i)*yr
      end do
      albedo_sys = sum_y/pi
      do i = 1, number
        y = ym+yr*points(i)
        phi_w = y
        do j = 1, number/2
          x = xm+xr*points(j)
          teta_w = acos(x)
          call  gamma_leaf(gamma_0_h,teta_s,phi_s(1),teta_w,phi_w(1))
          gamma_0(i,j,:) = gamma_0_h
        end do
      end do
      do i = 1, number
        y = ym+yr*points(i)
        phi_w = y
        do j = 1, number/2
          x = xm+xr*points(j)
          teta_w = acos(x)
          sum_k = 0
          mmm = mm(i,j,lbound(mm,3))
          do k = 1, mmm
            sum_k = sum_k+(1.-x_lambda(i,j,:)*g_w(j,:)/abs(x))**(mmm-k)*
     $x_lambda(i,j,:)*(1.-x_lambda(i,j,:)*gs/abs(xmus))**k
          end do
          t_i1d(i,j,:) = sum_k*gamma_0(i,j,:)*(1./(pi*abs(x)))
        end do
      end do
      sum_y = 0.
      do i = 1, number
        y = ym+yr*points(i)
        sum_x = 0.
        do j = 1, number/2
          x = xm+xr*points(j)
          sum_x = sum_x+t_i1d(i,j,:)*weights(j)*abs(x)*xr
        end do
        sum_y = sum_y+sum_x*weights(i)*yr
      end do
      trans_1 = sum_y/abs(xmus)
      sum_y = 0.
      do i = 1, number
        y = ym+yr*points(i)
        sum_x = 0.
        do j = 1, number/2
          x = xm+xr*points(j)
          sum_x = sum_x+t_i1d(i,j,:)*rs*weights(j)*abs(x)*xr
        end do
        sum_y = sum_y+sum_x*weights(i)*yr
      end do
      trans_1_in = sum_y/abs(xmus)
      sum_x = 0.
      do j = 1, number/2
        x = xm+xr*points(j)
        sum_x = sum_x+xif(21,j,1:nw)*weights(j)*abs(x)*xr
      end do
      trans_m = sum_x/abs(xmus)
      sum_x = 0.
      do j = number/2+1, number
        x = xm+xr*points(j)
        sum_x = sum_x+ximt(1:nw)*weights(j)*abs(x)*xr
      end do
      trans_in_m = sum_x/abs(xmus)
      x_lambda_0 = 0.01**abs(xmus)/gs*abs(xmus)/gs
      m0 = lai(1)/x_lambda_0(1)
      xt_directe = (1.-x_lambda_0*gs/abs(xmus))**m0
      trans_totale = xt_directe+trans_m+trans_1
      fpar = 1.-albedo_sys-(1.-rs)*trans_totale
      end subroutine energie


      subroutine fase_leafh_ad( fase_leaf_ad, teta_i, teta_e )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: fase_leaf_ad(nw)
      double precision :: teta_e
      double precision :: teta_i

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      double precision :: help_i(nw)
      double precision :: help_j(nw)
      integer :: j
      double precision :: sum_ad(nw)
      double precision :: x
      double precision :: xm
      double precision :: xr
c initialise locals
      help_h=0
      help_i=0
      help_j=0
      j=0
      x=0
      xm=0
      xr=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      sum_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      xm = 0.5*(pi/2.+0.)
      xr = 0.5*(pi/2.-0.)
      sum_ad = sum_ad+fase_leaf_ad*xr
      fase_leaf_ad = 0.
      do j = 1, number
        x = xm+xr*points(j)
        call  gl_bun(help_h,x)
        call psi_leaf_p(help_i,teta_e,teta_i,x)
        call psi_leaf_m(help_j,teta_e,teta_i,x)
        rl_ad(1:nw) = rl_ad(1:nw)+sum_ad*weights(j)*help_h*help_j
        tl_ad(1:nw) = tl_ad(1:nw)+sum_ad*weights(j)*help_h*help_i
      end do

      end subroutine fase_leafh_ad


      subroutine fase_leaf( vfase_leaf, teta_i, teta_e )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vfase_leaf(nw)
      double precision :: teta_e
      double precision :: teta_i

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      double precision :: help_i(nw)
      double precision :: help_j(nw)
      integer :: j
      double precision :: sum(nw)
      double precision :: x
      double precision :: xm
      double precision :: xr
c initialise locals
      help_h=0
      help_i=0
      help_j=0
      j=0
      x=0
      xm=0
      xr=0

      xm = 0.5*(pi/2.+0.)
      xr = 0.5*(pi/2.-0.)
      sum = 0.
      do j = 1, number
        x = xm+xr*points(j)
        call gl_bun(help_h,x)
        call psi_leaf_p(help_i,teta_e,teta_i,x)
        call psi_leaf_m(help_j,teta_e,teta_i,x)
        sum = sum+weights(j)*help_h*(tl(1:nw)*help_i+rl(1:nw)*help_j)
      end do
      vfase_leaf = sum*xr
      end subroutine fase_leaf


      subroutine fg_ross( vfg_ross, teta_p, x )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vfg_ross(nw)
      double precision :: teta_p
      double precision :: x

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      double precision :: help_i(nw)
      double precision :: teta_i
c initialise locals
      help_h=0
      help_i=0

      teta_i = teta_p
      call gl_bun(help_h,x)
      call psi_ross(help_i,teta_i,x)
      vfg_ross = help_h*help_i
      end subroutine fg_ross


      subroutine fgamma_leafh_ad( fgamma_leaf_ad, teta_p, phi_p, x, y, 
     $teta_i, phi_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: fgamma_leaf_ad(nw)
      double precision :: phi_i
      double precision :: phi_p
      double precision :: teta_i
      double precision :: teta_p
      double precision :: x
      double precision :: y

c==============================================
c declare local variables
c==============================================
      double precision :: di
      double precision :: dp
      double precision :: dpp
      double precision :: f_ad(nw)
      double precision :: g1(nw)
c initialise locals
      di=0
      dp=0
      dpp=0
      g1=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      f_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      call gl_bun(g1,x)
      dp = cos(x)*cos(teta_i)+sin(x)*sin(teta_i)*cos(abs(phi_i-y))
      dpp = cos(x)*cos(teta_p)+sin(x)*sin(teta_p)*cos(abs(phi_p-y))
      di = dp*dpp
      f_ad = f_ad+fgamma_leaf_ad*g1/pi*abs(dp)*abs(dpp)
      fgamma_leaf_ad = 0.
      if (di .lt. 0.) then
        rl_ad(1:nw) = rl_ad(1:nw)+f_ad
        f_ad = 0.
      else
        tl_ad(1:nw) = tl_ad(1:nw)+f_ad
        f_ad = 0.
      endif

      end subroutine fgamma_leafh_ad


      subroutine fgamma_leaf( vfgamma_leaf, 
     $teta_p, phi_p, x, y, teta_i, phi_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vfgamma_leaf(nw)
      double precision :: phi_i
      double precision :: phi_p
      double precision :: teta_i
      double precision :: teta_p
      double precision :: x
      double precision :: y

c==============================================
c declare local variables
c==============================================
      double precision :: di
      double precision :: dp
      double precision :: dpp
      double precision :: f(nw)
      double precision :: g1(nw)
c initialise locals
      di=0
      dp=0
      dpp=0
      f=0
      g1=0
c start code
      call gl_bun(g1,x)
      dp = cos(x)*cos(teta_i)+sin(x)*sin(teta_i)*cos(abs(phi_i-y))
      dpp = cos(x)*cos(teta_p)+sin(x)*sin(teta_p)*cos(abs(phi_p-y))
      di = dp*dpp
      if (di .lt. 0.) then
        f = rl(1:nw)
      else
        f = tl(1:nw)
      endif
      vfgamma_leaf = g1*f/pi*abs(dp)*abs(dpp)
      end subroutine fgamma_leaf


      subroutine g_ross(vg_ross, teta_p )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vg_ross(nw)
      double precision :: teta_p

c==============================================
c declare local variables
c==============================================
      double precision :: a
      double precision :: b
      double precision :: dx
      integer :: i
      double precision :: ssc(nw)
      double precision :: x1(nw)
      double precision :: x2(nw)
      double precision :: xm
      double precision :: xr
c initialise locals
      a=0
      b=0
      dx=0
      i=0
      x1=0
      x2=0
      xm=0
      xr=0
      ssc = 0.
      a = 0.
      b = pi/2.
      xm = 0.5*(b+a)
      xr = 0.5*(b-a)
      do i = number/2+1, number
        dx = xr*points(i)
        call fg_ross(x1,teta_p,xm+dx)
        call fg_ross(x2,teta_p,xm-dx)
        ssc = ssc+weights(i)*(x1+x2)
      end do
      ssc = ssc*xr
      vg_ross = ssc
      end  subroutine g_ross


      subroutine gamma_leafh_ad( gamma_leaf_ad, teta_p, phi_p, teta_i, 
     $phi_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: gamma_leaf_ad(nw)
      double precision :: phi_i
      double precision :: phi_p
      double precision :: teta_i
      double precision :: teta_p

c==============================================
c declare local variables
c==============================================
      double precision :: dx
      double precision :: dy
      double precision :: gausg_ad(nw)
      integer :: i
      integer :: j
      double precision :: sd_ad(nw)
      double precision :: sy_ad(nw)
      double precision :: xm
      double precision :: xr
      double precision :: ym
      double precision :: yr
c initialise locals
      dx=0
      dy=0
      i=0
      j=0
      xm=0
      xr=0
      ym=0
      yr=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      gausg_ad = 0.
      sd_ad = 0.
      sy_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      xm = 0.5*(pi/2.+0.)
      xr = 0.5*(pi/2.-0.)
      ym = 0.5*(2.*pi+0.)
      yr = 0.5*(2.*pi-0.)
      gausg_ad = gausg_ad+0.5*gamma_leaf_ad
      gamma_leaf_ad = 0.
      do j = number, 1, -1
        sd_ad = 0.
        sy_ad = 0.
        dx = xm+xr*points(j)
        sy_ad = sy_ad+gausg_ad*weights(j)*yr
        do i = number, 1, -1
          sd_ad = 0.
          dy = ym+yr*points(i)
          sd_ad = sd_ad+sy_ad*weights(i)*xr
          call fgamma_leafh_ad( sd_ad,teta_p,phi_p,dx,dy,teta_i,phi_i )
          sd_ad = 0.
        end do
        sy_ad = 0.
      end do

      end subroutine gamma_leafh_ad


      subroutine gamma_leaf( vgamma_leaf,
     $teta_p, phi_p, teta_i, phi_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vgamma_leaf(nw)
      double precision :: phi_i
      double precision :: phi_p
      double precision :: teta_i
      double precision :: teta_p

c==============================================
c declare local variables
c==============================================
      double precision :: dx
      double precision :: dy
      double precision :: gausg(nw)
      integer :: i
      integer :: j
      double precision :: sd(nw)
      double precision :: sy(nw)
      double precision :: xm
      double precision :: xr
      double precision :: ym
      double precision :: yr
c initialise locals
      dx=0
      dy=0
      gausg=0
      i=0
      j=0
      sd=0
      sy=0
      xm=0
      xr=0
      ym=0
      yr=0
c code body
      xm = 0.5*(pi/2.+0.)
      xr = 0.5*(pi/2.-0.)
      ym = 0.5*(2.*pi+0.)
      yr = 0.5*(2.*pi-0.)
      gausg = 0.
      do j = 1, number
        dx = xm+xr*points(j)
        sy = 0.
        do i = 1, number
          dy = ym+yr*points(i)
          call fgamma_leaf(sd,teta_p,phi_p,dx,dy,teta_i,phi_i)
          sy = sy+weights(i)*sd*xr
        end do
        gausg = gausg+weights(j)*sy*yr
      end do
      vgamma_leaf = gausg/2.
      end subroutine gamma_leaf


      subroutine gauleg( x1, x2, x, w, n )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none
      double precision eps
c==============================================
c declare arguments
c==============================================
      integer :: n
      double precision :: w(n)
      double precision :: x(n)
      double precision :: x1
      double precision :: x2

c==============================================
c declare local variables
c==============================================
      integer :: i
      integer :: j
      integer :: m
      double precision :: p1
      double precision :: p2
      double precision :: p3
      double precision :: pp
      double precision :: xl
      double precision :: xm
      double precision :: z
      double precision :: z1
c initialise locals
      i=0
      j=0
      m=0
      p1=0
      p2=0
      p3=0
      pp=0
      xl=0
      xm=0
      z=0
      z1=0
c code body
      eps = 3.d-14
      m = (n+1)/2
      xm = 0.5d0*(x2+x1)
      xl = 0.5d0*(x2-x1)
cdummy loop header
      do i = 1, m
        z = cos(3.141592654d0*(i-0.25d0)/(n+0.5d0))
        p1 = 1.d0
        p2 = 0.d0
        do j = 1, n
          p3 = p2
          p2 = p1
          p1 = ((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
        end do
        pp = n*(z*p1-p2)/(z*z-1.d0)
        z1 = z
        z = z1-p1/pp
        do while ( abs(z-z1) .gt. eps )
          p1 = 1.d0
          p2 = 0.d0
          do j = 1, n
            p3 = p2
            p2 = p1
            p1 = ((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
          end do
          pp = n*(z*p1-p2)/(z*z-1.d0)
          z1 = z
          z = z1-p1/pp
        end do
        x(i) = xm-xl*z
        x(n+1-i) = xm+xl*z
        w(i) = 2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i) = w(i)
      end do
      end subroutine gauleg


      subroutine geo( vgeo,teta_e, teta_01, phi_e, phi_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vgeo(nw)
      double precision :: phi_01
      double precision :: phi_e
      double precision :: teta_01
      double precision :: teta_e

c==============================================
c declare local variables
c==============================================
      double precision :: li1
      double precision :: li2

      li1 = tan(teta_01)**2+tan(teta_e)**2
      li2 = -(2.*tan(teta_e)*tan(teta_01)*cos(phi_01-phi_e))
      vgeo = sqrt(abs(li1+li2))
      where (vgeo .lt. 9.9999999999999e-36) vgeo = 9.9999999999999e-36
      end subroutine geo


      subroutine gl_bun(vgl_bun, x )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vgl_bun(nw)
      double precision :: x

      vgl_bun = 2./pi*(ag+bg*cos(2.*cg*x))+dg*sin(x)
      end subroutine gl_bun


      subroutine hot_spoth_ad( hot_spot_ad, x, x_ad, xli, xli_ad )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: hot_spot_ad(nw)
      double precision :: x(nw)
      double precision :: x_ad(nw)
      double precision :: xli(nw)
      double precision :: xli_ad(nw)

c----------------------------------------------
c routine body
c----------------------------------------------
      where (x .lt. xli) 
        x_ad = x_ad+hot_spot_ad*((1.-4./(3.*pi))/xli)
        xli_ad = xli_ad-hot_spot_ad*((1.-4./(3.*pi))*x/(xli*xli))
        hot_spot_ad = 0.
      end where
      where (x .ge. xli)
        x_ad = x_ad+hot_spot_ad*(4./(3.*pi)*xli/(x*x))
        xli_ad = xli_ad-hot_spot_ad*(4./(3.*pi)/x)
        hot_spot_ad = 0.
      end where

      end subroutine hot_spoth_ad


      subroutine hot_spot(vhot_spot, x, xli )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vhot_spot(nw)
      double precision :: x(nw)
      double precision :: xli(nw)

      where (x .lt. xli) 
        vhot_spot = (1.-4./(3.*pi))*x/xli
      end where
      where (x .ge. xli )
        vhot_spot = 1.-4./(3.*pi)*xli/x
      end where
      end subroutine hot_spot

      subroutine multiple_dom_ad( ipt,teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c referencing used modules
c==============================================
      use mo_nad
      use multiple_dom_store_ad

c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: teta_01
      integer :: ipt
c==============================================
c declare local variables
c==============================================
      double precision :: dl(nw)
      double precision :: dl_ad(nw)
      double precision :: g0(nw)
      double precision :: gg(40,nw)
      integer :: i
      double precision :: i00(nw)
      double precision :: i0h(nw)
      double precision :: i0h_ad(nw)
      double precision :: i0i(nw)
      integer :: j
      integer :: k
      integer :: l
      integer :: m
      integer :: nl
      double precision :: q0m(21,40,nw)
      double precision :: q0m_ad(21,40,nw)
      double precision :: q1(21,40,nw)
      double precision :: q1_ad(21,40,nw)
      double precision :: s(21,40,nw)
      double precision :: s_ad(21,40,nw)
      double precision :: sum(nw)
      double precision :: sum_ad(nw)
      double precision :: x
      double precision :: xgama_0(40,nw)
      double precision :: xgama_0_ad(40,nw)
      double precision :: xgama_xy(40,40,nw)
      double precision :: xgama_xy_ad(40,40,nw)
      double precision :: xi(21,40,nw)
      double precision :: xi1uh(nw)
      double precision :: xi1ui(nw)
      double precision :: xi1ui_ad(nw)
      double precision :: xi1uj(nw)
      double precision :: xi1uk(nw)
      double precision :: xi1ul(nw)
      double precision :: xi1um(nw)
      double precision :: xi_ad(21,40,nw)
      double precision :: xih(nw)
      double precision :: xii(nw)
      double precision :: xii_ad(nw)
      double precision :: xij(nw)
      double precision :: xik(nw)
      double precision :: xil(nw)
      double precision :: xim(nw)
      double precision :: xl(nw)
      double precision :: xl_ad(nw)
      double precision :: xm
      double precision :: xmu0
      double precision :: xr
      double precision :: y(nw)

      double precision :: xgama_xy_h(nw),xgama_0_h(nw)
      double precision :: gg_h(nw)
c initialise locals
      dl=0
      g0=0
      gg=0
      i=0
      i00=0
      i0h=0
      i0h_ad=0
      i0i=0
      j=0
      k=0
      l=0
      m=0
      nl=0
      q0m=0
      q1=0
      s=0
      sum=0
      x=0
      xgama_0=0
      xgama_xy=0
      xi=0
      xi1uh=0
      xi1ui=0
      xi1ui_ad=0
      xi1uj=0
      xi1uk=0
      xi1ul=0
      xi1um=0
      xih=0
      xii=0
      xii_ad=0
      xij=0
      xik=0
      xil=0
      xim=0
      xl=0
      xm=0
      xmu0=0
      xr=0
      y=0
      xgama_xy_h=0
      xgama_0_h=0
      gg_h=0

c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      dl_ad = 0.
      q0m_ad = 0.
      q1_ad = 0.
      s_ad = 0.
      sum_ad = 0.
      xgama_0_ad = 0.
      xgama_xy_ad = 0.
      xi_ad = 0.
      xl_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      xmu0 = abs(cos(teta_01))
      m = 20
      dl = lai(1:nw)/float(m)
      call g_ross(g0,teta_01)
      xm = 0.5*(1.+(-1.))
      xr = 0.5*(1.-(-1.))
      i00 = 1.
      do j = 1, number
        x = xm+xr*points(j)
        call g_ross(gg_h,acos(x))
        gg(j,:) = gg_h
      end do
      xi = 0.
      do k = 1, m+1
        xl = float(k-1)*dl
        do i = 1, number/2
          x = xm+xr*points(i)
          if (abs(x) .eq. xmu0) then
            i0(k,i,1:nw) = i00*exp(-(g0/xmu0*xl))
          else
            i0(k,i,1:nw) = 0.
          endif
        end do
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do i = number/2+1, number
          x = xm+xr*points(i)
          i0(k,i,1:nw) = 2.*rs*i00*xmu0*exp(-((g0/xmu0)*lai(1:nw)))
     $*exp(-((gg(i,:)/x)*(lai(1:nw)-xl)))
        end do
      end do
      do i = 1, number
        y = xm+xr*points(i)
        do j = 1, number
          x = xm+xr*points(j)
          call fase_leaf(xgama_xy_h,acos(x),acos(y(1)))
          xgama_xy(i,j,:) = xgama_xy_h
        end do
      end do
      do k = m, 1, -1
        do i = 1, number
          sum = 0.
          do j = number/2+1, number
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.
          end do
          q0m(k,i,:) = sum
        end do
      end do
      do i = 1, number
        x = xm+xr*points(i)
        call fase_leaf(xgama_0_h,teta_01,acos(x))
        xgama_0(i,:) = xgama_0_h
      end do
      do k = 1, m+1
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
	print*,'666',i00,xgama_0(j,:),xmu0,g0,xmu0,xl,exp(-(g0/xmu0*xl))
	    print*,'667',gg(j,:),
     $exp(-(gg(j,:)/abs(x)*xl)),(gg(j,:)*xmu0-g0*abs(x))
            xi(k,j,:) = 
     $i00*2.*xgama_0(j,:)*xmu0*(exp(-(g0/xmu0*xl))-exp(-(
     $gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
          else
	    print*,'777',i00,xl,xgama_0(j,:),exp(-(g0/xmu0*xl)),xmu0
            xi(k,j,:) = i00*xl*2.*xgama_0(j,:)*exp(-(g0/xmu0*xl))/xmu0
          endif
        end do
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do j = number/2+1, number
          x = xm+xr*points(j)
	  print*,'999',i00,xgama_0(j,:),xmu0,exp(-(g0/xmu0*xl))
	  print*,'1000',exp(-(gg(j,:)/x*(lai(1:nw)-xl)))
	  print*,'1001',exp(-(g0/xmu0*lai(1:nw))),(g0*x+gg(j,:)*xmu0)
          xi(k,j,:) = 
     $i00*2.*xgama_0(j,:)*xmu0*(exp(-(g0/xmu0*xl))-exp(-(gg(
     $j,:)/x*(lai(1:nw)-xl)))*
     $exp(-(g0/xmu0*lai(1:nw))))/(g0*x+gg(j,:)*xmu0)
        end do
      end do
      do j = number/2+1, number
        xi(m+1,j,:) = 0.
      end do
      do k = 1, m
        do i = 1, number
          sum = 0.
          do j = 1, number
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(xi(k+1,j,:)+xi(k,j,:))/2.
          end do
          q1(k,i,:) = sum
        end do
      end do
      nl = nlm
      do l = nl, 1, -1
        s = multl_s_3h(:,:,l+nlm*(ipt-1),:)
        xi = multl_xi_4h(:,:,l+nlm*(ipt-1),:)
        do k = m, 1, -1
          sum_ad = 0.
          do i = number, 1, -1
            sum_ad = 0.
            sum_ad = sum_ad+s_ad(k,i,:)
            s_ad(k,i,:) = 0.
            do j = number, 1, -1
              xgama_xy_ad(i,j,:) = xgama_xy_ad(i,j,:)+
     $sum_ad*(2*weights(j)*
     $xr*(xi(k+1,j,:)+xi(k,j,:))/2.)
              xi_ad(k+1,j,:) = xi_ad(k+1,j,:)+
     $sum_ad*(2*weights(j)*xr*
     $xgama_xy(i,j,:)/2.)
              xi_ad(k,j,:) = xi_ad(k,j,:)+
     $sum_ad*(2*weights(j)*xr*xgama_xy(i,j,:)/2.)
            end do
            sum_ad = 0.
          end do
        end do
        do k = 1, m+1
          do j = 1, number
            xi_ad(k,j,:) = xi_ad(k,j,:)+xif_ad(k,j,1:nw)
            xif_ad(k,j,:) = 0.
          end do
        end do
        do k = 1, m
          xi(k+1,:,:) = multkl_xi_2h(:,k+21*(l-1)+21*nlm*(ipt-1),:)
          do j = number/2+1, number
            x = xm+xr*points(j)
            dl_ad = dl_ad+xi_ad(k,j,:)*((-(xi(k+1,j,:)
     $*(x/(dl*dl))/(gg(j,:)/
     $2.+x/dl)))+(s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k+1,j,:)*
     $(gg(j,:)/2.-x/dl))*(x/
     $(dl*dl))/((gg(j,:)/2.+x/dl)*(gg(j,:)/2.+x/dl)))
            q0m_ad(k,j,:) = q0m_ad(k,j,:)+xi_ad(k,j,:)/(gg(j,:)/2.+x/dl)
            q1_ad(k,j,:) = q1_ad(k,j,:)+xi_ad(k,j,:)/(gg(j,:)/2.+x/dl)
            s_ad(k,j,:) = s_ad(k,j,:)+xi_ad(k,j,:)/(gg(j,:)/2.+x/dl)
            xi_ad(k+1,j,:) = xi_ad(k+1,j,:)
     $-xi_ad(k,j,:)*((gg(j,:)/2.-x/dl)/(gg(j,:)/2.+x/dl))
            xi_ad(k,j,:) = 0.
          end do
        end do
        do j = number/2+1, number
          xi1_ad(1:nw) = xi1_ad(1:nw)+xi_ad(m+1,j,:)
          ximt_ad(1:nw) = ximt_ad(1:nw)+xi_ad(m+1,j,:)
          xi_ad(m+1,j,:) = 0.
        end do
        xi = multl_xi_2h(:,:,l+nlm*(ipt-1),:)
        do j = 1, number/2
          x = xm+xr*points(j)
          rs_ad(1:nw) = rs_ad(1:nw)+
     $2*ximt_ad(1:nw)*weights(j)*xr*xi(m+1,j,:)*abs(x)
          xi_ad(m+1,j,:) = xi_ad(m+1,j,:)+2.*ximt_ad(1:nw)*
     $weights(j)*xr*rs*abs(x)
        end do
        ximt_ad = 0.
        s = multl_s_1h(:,:,l+nlm*(ipt-1),:)
        do k = m, 1, -1
          xi(k,:,:) = multkl_xi_1h(:,k+21*(l-1)+21*nlm*(ipt-1),:)
          do j = 1, number/2
            x = xm+xr*points(j)
            dl_ad = dl_ad+xi_ad(k+1,j,:)*(xi(k,j,:)*(x/(dl*dl))/
     $(gg(j,:)/2.-x/dl)-(s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k,j,:)*
     $(gg(j,:)/2.+x/dl))*(x/(dl*dl))/
     $((gg(j,:)/2.-x/dl)*(gg(j,:)/2.-x/dl)))
            q0m_ad(k,j,:) = q0m_ad(k,j,:)+xi_ad(k+1,j,:)/
     $(gg(j,:)/2.-x/dl)
            q1_ad(k,j,:) = q1_ad(k,j,:)+xi_ad(k+1,j,:)/(gg(j,:)/2.-x/dl)
            s_ad(k,j,:) = s_ad(k,j,:)+xi_ad(k+1,j,:)/(gg(j,:)/2.-x/dl)
            xi_ad(k,j,:) = xi_ad(k,j,:)-xi_ad(k+1,j,:)*((gg(j,:)
     $/2.+x/dl)/(gg(j,:)/2.-x/dl))
            xi_ad(k+1,j,:) = 0.
          end do
        end do
      end do
      do k = 1, m+1
        do j = 1, number/2
          xi_ad(k,j,:) = 0.
        end do
      end do
      xi = 0.
      do k = 1, m+1
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
            xi(k,j,:) = i00*2.*xgama_0(j,:)
     $*xmu0*(exp(-(g0/xmu0*xl))-exp(-(
     $gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
          else
            xi(k,j,:) = i00*xl*2.*xgama_0(j,:)*exp(-(g0/xmu0*xl))/xmu0
          endif
        end do
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do j = number/2+1, number
          x = xm+xr*points(j)
          xi(k,j,:) = i00*2.*xgama_0(j,:)*xmu0
     $*(exp(-(g0/xmu0*xl))-exp(-(gg(j,:)/x*(lai(1:nw)-xl)))*
     $exp(-(g0/xmu0*lai(1:nw))))/(g0*x+gg(j,:)*xmu0)
        end do
      end do
      do j = number/2+1, number
        xi(m+1,j,:) = 0.
      end do
      do k = m, 1, -1
        sum_ad = 0.
        do i = number, 1, -1
          sum_ad = 0.
          sum_ad = sum_ad+q1_ad(k,i,:)
          q1_ad(k,i,:) = 0.
          do j = number, 1, -1
            xgama_xy_ad(i,j,:) = xgama_xy_ad(i,j,:)+
     $sum_ad*(2*weights(j)*xr*
     $(xi(k+1,j,:)+xi(k,j,:))/2.)
            xi_ad(k+1,j,:) = xi_ad(k+1,j,:)+sum_ad*(2*weights(j)*xr*
     $xgama_xy(i,j,:)/2.)
            xi_ad(k,j,:) = xi_ad(k,j,:)+sum_ad*(2*weights(j)*xr*
     $xgama_xy(i,j,:)/2.)
          end do
          sum_ad = 0.
        end do
      end do
      do j = number/2+1, number
        xi1u_ad(m+1,j,:) = 0.
        xi_ad(m+1,j,:) = 0.
      end do
      do k = 1, m+1
        xl_ad = 0.
        xl = float(k-1)*dl
        do j = number/2+1, number
          x = xm+xr*points(j)
          xi1uh = -(g0/xmu0*lai(1:nw))
          xi1ui = -(gg(j,:)/x*(lai(1:nw)-xl))
          xi1uj = -(g0/xmu0*xl)
          xgama_0_ad(j,:) = xgama_0_ad(j,:)+xi1u_ad(k,j,1:nw)
     $*(2*i00*xmu0*(exp(
     $xi1uj)-exp(xi1ui)*exp(xi1uh))/(g0*x+gg(j,:)*xmu0))
          xi1ui_ad = -(xi1u_ad(k,j,1:nw)*(2.*i00*xgama_0(j,:)
     $*xmu0*exp(xi1ui)*
     $exp(xi1uh)/(g0*x+gg(j,:)*xmu0)))
          xl_ad = xl_ad-xi1u_ad(k,j,1:nw)*2.*i00*xgama_0(j,:)*xmu0*
     $exp(xi1uj)/(g0*x+gg(j,:)*xmu0)*(g0/xmu0)
          lai_ad(1:nw) = lai_ad(1:nw)-xi1ui_ad*(gg(j,:)/x)
          xl_ad = xl_ad+xi1ui_ad*(gg(j,:)/x)
          lai_ad(1:nw) = lai_ad(1:nw)+
     $xi1u_ad(k,j,1:nw)*2.*i00*xgama_0(j,:)*
     $xmu0*exp(xi1ui)
     $*exp(xi1uh)/(g0*x+gg(j,:)*xmu0)*(g0/xmu0)
          xi1u_ad(k,j,:) = 0.
          xih = -(g0/xmu0*lai(1:nw))
          xii = -(gg(j,:)/x*(lai(1:nw)-xl))
          xij = -(g0/xmu0*xl)
          xgama_0_ad(j,:) = xgama_0_ad(j,:)+xi_ad(k,j,:)
     $*(2*i00*xmu0*(exp(xij)
     $-exp(xii)*exp(xih))/(g0*x+gg(j,:)*xmu0))
          xii_ad = -(xi_ad(k,j,:)*(2.*i00*xgama_0(j,:)*
     $xmu0*exp(xii)*exp(
     $xih)/(g0*x+gg(j,:)*xmu0)))
          xl_ad = xl_ad-xi_ad(k,j,:)*2.*i00*xgama_0(j,:)*
     $xmu0*exp(xij)/(g0*
     $x+gg(j,:)*xmu0)*(g0/xmu0)
          lai_ad(1:nw) = lai_ad(1:nw)-xii_ad*(gg(j,:)/x)
          xl_ad = xl_ad+xii_ad*(gg(j,:)/x)
          lai_ad(1:nw) = lai_ad(1:nw)+xi_ad(k,j,:)*2.*i00*xgama_0(j,:)
     $*xmu0*exp(xii)*
     $exp(xih)/(g0*x+gg(j,:)*xmu0)*(g0/xmu0)
          xi_ad(k,j,:) = 0.
        end do
        dl_ad = dl_ad+xl_ad*float(k-1)
        xl_ad = 0.
      end do
      xi = 0.
      do k = 1, m+1
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
            xi(k,j,:) = i00*2.*xgama_0(j,:)
     $*xmu0*(exp(-(g0/xmu0*xl))-exp(-(
     $gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
          else
            xi(k,j,:) = i00*xl*2.*xgama_0(j,:)*exp(-(g0/xmu0*xl))/xmu0
          endif
        end do
      end do
      do j = 1, number/2
        x = xm+xr*points(j)
        rs_ad(1:nw) = rs_ad(1:nw)+
     $2*xi1_ad(1:nw)*weights(j)*xr*xi(m+1,j,:)*abs(x)
        xi_ad(m+1,j,:) = xi_ad(m+1,j,:)+
     $2*xi1_ad(1:nw)*weights(j)*xr*rs*abs(x)
      end do
      xi1_ad = 0.
      do k = m+1, 1, -1
        xl_ad = 0.
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
            xi1ul = -(gg(j,:)/abs(x)*xl)
            xi1um = -(g0/xmu0*xl)
            xgama_0_ad(j,:) = xgama_0_ad(j,:)+xi1u_ad(k,j,1:nw)
     $*(2*i00*xmu0*(exp(
     $xi1um)-exp(xi1ul))/(gg(j,:)*xmu0-g0*abs(x)))
            xl_ad = xl_ad-xi1u_ad(k,j,1:nw)*2.*i00*
     $xgama_0(j,:)*xmu0*exp(xi1um)/(gg(j,:)*xmu0-g0*abs(x))*(g0/xmu0)
            xl_ad = xl_ad+xi1u_ad(k,j,1:nw)*2.*i00*
     $xgama_0(j,:)*xmu0*exp(xi1ul)
     $/(gg(j,:)*xmu0-g0*abs(x))*(gg(j,:)/abs(x))
            xi1u_ad(k,j,:) = 0.
            xil = -(gg(j,:)/abs(x)*xl)
            xim = -(g0/xmu0*xl)
            xgama_0_ad(j,:) = xgama_0_ad(j,:)
     $+xi_ad(k,j,:)*(2*i00*xmu0*(exp(
     $xim)-exp(xil))/(gg(j,:)*xmu0-g0*abs(x)))
            xl_ad = xl_ad-xi_ad(k,j,:)*2.*i00*xgama_0(j,:)
     $*xmu0*exp(xim)/(
     $gg(j,:)*xmu0-g0*abs(x))*(g0/xmu0)
            xl_ad = xl_ad+xi_ad(k,j,:)*2.*i00*xgama_0(j,:)
     $*xmu0*exp(xil)/(
     $gg(j,:)*xmu0-g0*abs(x))*(gg(j,:)/abs(x))
            xi_ad(k,j,:) = 0.
          else
            xi1uk = -(g0/xmu0*xl)
            xgama_0_ad(j,:) = xgama_0_ad(j,:)+xi1u_ad(k,j,1:nw)
     $*(2*i00*xl*exp(
     $xi1uk)/xmu0)
            xl_ad = xl_ad+xi1u_ad(k,j,1:nw)*(2.*i00*xgama_0(j,:)
     $*exp(xi1uk)/xmu0)
            xl_ad = xl_ad-xi1u_ad(k,j,1:nw)*2.*i00*xl*xgama_0(j,:)
     $*exp(xi1uk)/xmu0*(g0/xmu0)
            xi1u_ad(k,j,:) = 0.
            xik = -(g0/xmu0*xl)
            xgama_0_ad(j,:) = xgama_0_ad(j,:)+
     $xi_ad(k,j,:)*(2*i00*xl*exp(xik)/xmu0)
            xl_ad = xl_ad+xi_ad(k,j,:)*(2.*i00*xgama_0(j,:)
     $*exp(xik)/xmu0)
            xl_ad = xl_ad-xi_ad(k,j,:)*2.*i00*xl*xgama_0(j,:)
     $*exp(xik)/xmu0*(g0/xmu0)
            xi_ad(k,j,:) = 0.
          endif
        end do
        dl_ad = dl_ad+xl_ad*float(k-1)
        xl_ad = 0.
      end do
      do i = 1, number
        x = xm+xr*points(i)
        call fase_leafh_ad( xgama_0_ad(i,:),teta_01,acos(x) )
        xgama_0_ad(i,:) = 0.
      end do
      do k = 1, m
        sum_ad = 0.
        do i = number, 1, -1
          sum_ad = 0.
          sum_ad = sum_ad+q0m_ad(k,i,:)
          q0m_ad(k,i,:) = 0.
          do j = number, number/2+1, -1
            i0_ad(k+1,j,1:nw) = i0_ad(k+1,j,1:nw)+
     $sum_ad*(2*weights(j)*xr*
     $xgama_xy(i,j,:)/2.)
            i0_ad(k,j,1:nw) = i0_ad(k,j,1:nw)+
     $sum_ad*(2*weights(j)*xr*
     $xgama_xy(i,j,:)/2.)
            xgama_xy_ad(i,j,:) = xgama_xy_ad(i,j,:)+sum_ad*
     $(2*weights(j)*xr*(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.)
          end do
          sum_ad = 0.
        end do
      end do
      do i = 1, number
        y = xm+xr*points(i)
        do j = 1, number
          x = xm+xr*points(j)
          call fase_leafh_ad( xgama_xy_ad(i,j,:),acos(x),acos(y(1)) )
          xgama_xy_ad(i,j,:) = 0.
        end do
      end do
      do k = 1, m+1
        xl_ad = 0.
        xl = float(k-1)*dl
        do i = number/2+1, number
          x = xm+xr*points(i)
          i0h = -(gg(i,:)/x*(lai(1:nw)-xl))
          i0i = -(g0/xmu0*lai(1:nw))
          i0h_ad =2.*i0_ad(k,i,1:nw)*rs*i00*xmu0*exp(i0i)*exp(i0h)
          rs_ad(1:nw) =rs_ad(1:nw)+
     $2*i0_ad(k,i,1:nw)*i00*xmu0*exp(i0i)*exp(i0h)
          lai_ad(1:nw) =lai_ad(1:nw)-
     $2.*i0_ad(k,i,1:nw)*rs*i00*xmu0*g0/xmu0*exp(i0i)*
     $exp(i0h)
          lai_ad(1:nw) = lai_ad(1:nw)-i0h_ad*(gg(i,:)/x)
          xl_ad = xl_ad+i0h_ad*(gg(i,:)/x)
          i0_ad(k,i,:) = 0.
        end do
        dl_ad = dl_ad+xl_ad*float(k-1)
        xl_ad = 0.
      end do
      do k = m+1, 1, -1
        xl_ad = 0.
        xl = float(k-1)*dl
        do i = 1, number/2
          x = xm+xr*points(i)
          if (abs(x) .eq. xmu0) then
            xl_ad = xl_ad-i0_ad(k,i,1:nw)*
     $i00*(g0/xmu0)*exp(-(g0/xmu0*xl))
            i0_ad(k,i,:) = 0.
          else
            i0_ad(k,i,:) = 0.
          endif
        end do
        dl_ad = dl_ad+xl_ad*float(k-1)
        xl_ad = 0.
      end do
      do k = 1, m+1
        do j = 1, number
          xif_ad(k,j,:) = 0.
        end do
      end do
      lai_ad(1:nw) = lai_ad(1:nw)+dl_ad/float(m)
      dl_ad = 0.

      end subroutine multiple_dom_ad


      subroutine multiple_dommd(ipt, teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c referencing used modules
c==============================================
      use multiple_dom_store_ad

c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: teta_01
      integer ipt
c==============================================
c declare local variables
c==============================================
      double precision :: dl(nw)
      double precision :: g0(nw)
      double precision :: gg(40,nw)
      integer :: i
      double precision :: i00(nw)
      integer :: j
      integer :: k
      integer :: l
      integer :: m
      integer :: nl
      double precision :: q0m(21,40,nw)
      double precision :: q1(21,40,nw)
      double precision :: s(21,40,nw)
      double precision :: sum(nw)
      double precision :: x
      double precision :: xgama_0(40,nw)
      double precision :: xgama_xy(40,40,nw)
      double precision :: xi(21,40,nw)
      double precision :: xl(nw)
      double precision :: xm
      double precision :: xmu0
      double precision :: xr
      double precision :: y
c initialise locals
      dl=0
      g0=0
      gg=0
      i=0
      i00=0
      j=0
      k=0
      l=0
      m=0
      nl=0
      q0m=0
      q1=0
      s=0
      sum=0
      x=0
      xgama_0=0
      xgama_xy=0
      xi=0
      xl=0
      xm=0
      xmu0=0
      xr=0
      y=0
c**********************************************
c executable statements of routine
c**********************************************
      xmu0 = abs(cos(teta_01))
      m = 20
      dl = lai(1:nw)/float(m)
      call g_ross(g0,teta_01)
      xm = 0.5*(1.+(-1.))
      xr = 0.5*(1.-(-1.))
      i00 = 1.
      do j = 1, number
        x = xm+xr*points(j)
        call g_ross(gg(j,:),acos(x))
      end do
      do k = 1, m+1
        do j = 1, number
          s(k,j,:) = 0.
          xif(k,j,:) = 0.
        end do
      end do
      xi = 0.
      s = 0.
      do k = 1, m+1
        xl = float(k-1)*dl
        do i = 1, number/2
          x = xm+xr*points(i)
          if (abs(x) .eq. xmu0) then
            i0(k,i,1:nw) = i00*exp(-(g0/xmu0*xl))
          else
            i0(k,i,:) = 0.
          endif
        end do
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do i = number/2+1, number
          x = xm+xr*points(i)
          i0(k,i,1:nw) = 2.*rs*i00*xmu0*exp(-(g0/xmu0*lai(1:nw)))
     $*exp(-(gg(i,:)/x*(lai(1:nw)-xl)))
        end do
      end do
      do i = 1, number
        y = xm+xr*points(i)
        do j = 1, number
          x = xm+xr*points(j)
          call fase_leaf(xgama_xy(i,j,:),acos(x),acos(y))
        end do
      end do
      do k = m, 1, -1
        do i = 1, number
          sum = 0.
          do j = number/2+1, number
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.
          end do
          q0m(k,i,:) = sum
        end do
      end do
      do i = 1, number
        x = xm+xr*points(i)
        call  fase_leaf(xgama_0(i,:),teta_01,acos(x))
      end do
      do k = 1, m+1
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
            xi(k,j,:) = i00*2.*xgama_0(j,:)*xmu0*
     $(exp(-(g0/xmu0*xl))-exp(-(
     $gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
            xi1u(k,j,1:nw) = i00*2.*xgama_0(j,:)
     $*xmu0*(exp(-(g0/xmu0*xl))-exp(-
     $(gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
          else
            xi(k,j,:) = i00*xl*2.*xgama_0(j,:)
     $*exp(-(g0/xmu0*xl))/xmu0
            xi1u(k,j,1:nw) = i00*xl*2.*xgama_0(j,:)
     $*exp(-(g0/xmu0*xl))/xmu0
          endif
        end do
      end do
      print*,'*1**',maxval(xi),minval(xi)
      print*,'*1a*',maxloc(xi),minloc(xi)


      xi1 = 0.
      do j = 1, number/2
        x = xm+xr*points(j)
        xi1(1:nw) = xi1(1:nw)+weights(j)*xr*abs(x)*2.*rs*xi(m+1,j,:)
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do j = number/2+1, number
          x = xm+xr*points(j)
	  if (j == 16) then
	   print*,'*C1',gg(j,:)
	   print*,'*C2',x
	   print*,'*C3',gg(j,:)/x
	   print*,'*C4',(lai(1:nw)-xl)
	   print*,'**4',-((gg(j,:)/x)*(lai(1:nw)-xl))
	   print*,'*C5',exp(-((gg(j,:)/x)*(lai(1:nw)-xl)))
	  endif
          xi(k,j,1:nw) = i00*2.*xgama_0(j,:)*
     $xmu0*(exp(-(g0/xmu0*xl))-exp(-(gg(
     $j,:)/x*(lai(1:nw)-xl)))*exp(-(g0/xmu0*lai(1:nw))))
     $/(g0*x+gg(j,:)*xmu0)
          xi1u(k,j,1:nw) = i00*2.*xgama_0(j,:)*
     $xmu0*(exp(-(g0/xmu0*xl))
     $-exp(-(gg(j,:)/x*(lai(1:nw)-xl)))*
     $exp(-(g0/xmu0*lai(1:nw))))/(g0*x+gg(j,:)
     $*xmu0)
        xi(k,j,1:nw) = amin1(1000.,amax1(-1000.,xi(k,j,1:nw)))
	xi1u(k,j,1:nw) = amin1(1000.,amax1(-1000.,xi1u(k,j,1:nw)))
	  print*,'***C5',j,k,xi(k,j,:),xi1u(k,j,:)
        end do
      end do
      print*,'*2**',minval(xi)
      print*,'*2a*',minloc(xi)

      do j = number/2+1, number
        xi(m+1,j,:) = 0.
        xi1u(m+1,j,:) = 0.
      end do
      do k = 1, m
        do i = 1, number
          sum = 0.
          do j = 1, number
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(xi(k+1,j,:)+xi(k,j,:))/2.
          end do
          q1(k,i,:) = sum
        end do
      end do
      do k = 1, m+1
        do j = 1, number/2
          xi(k,j,:) = 0.
        end do
      end do
      nl = nlm
      do l = 1, nl
        multl_s_1h(:,:,l+nlm*(ipt-1),:) = s
        do k = 1, m
          multkl_xi_1h(:,k+21*(l-1)+21*nlm*(ipt-1),:) = xi(k,:,:)
          do j = 1, number/2
            x = xm+xr*points(j)
            xi(k+1,j,:) = (s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k,j,:)
     $*(gg(j,:)/2.+x/dl))/(gg(j,:)/2.-x/dl)
	    xi(k+1,j,:) = amin1(1000.,amax1(-1000.,xi(k+1,j,:)))

          end do
        end do
        ximt = 0.
        multl_xi_2h(:,:,l+nlm*(ipt-1),:) = xi
        do j = 1, number/2
          x = xm+xr*points(j)
          ximt(1:nw) = ximt(1:nw)+weights(j)*xr*2.*rs*abs(x)*xi(m+1,j,:)
        end do
        do j = number/2+1, number
          xi(m+1,j,:) = ximt(1:nw)+xi1(1:nw)
          xi(m+1,j,:) = amin1(1000.,amax1(-1000.,xi(m+1,j,:)))

        end do
        multl_s_3h(:,:,l+nlm*(ipt-1),:) = s
        do k = m, 1, -1
          multkl_xi_2h(:,k+21*(l-1)+21*nlm*(ipt-1),:) = xi(k+1,:,:)
          do j = number/2+1, number
            x = xm+xr*points(j)
            xi(k,j,:) = (s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k+1,j,:)
     $*(gg(j,:)/2.-x/dl))/(gg(j,:)/2.+x/dl)
	    xi(k,j,:) = amin1(1000.,amax1(-1000.,xi(k,j,:)))

          end do
        end do
        multl_xi_4h(:,:,l+nlm*(ipt-1),:) = xi
        do k = 1, m+1
          do j = 1, number
	    if (j == 1) then
	        print*,'****XI***',k,k,xi(k,j,:)
	    endif
            xif(k,j,1:nw) = xi(k,j,:)
          end do
        end do
        do k = 1, m
          do i = 1, number
            y = xm+xr*points(i)
            sum = 0.
            do j = 1, number
              x = xm+xr*points(j)
              sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(xi(k+1,j,:)+xi(k,j,:))/2.
            end do
            s(k,i,:) = sum
          end do
        end do
      end do
      end subroutine multiple_dommd


      subroutine multiple_dom( teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c referencing used modules
c==============================================

c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: teta_01

c==============================================
c declare local variables
c==============================================
      double precision :: dl(nw)
      double precision :: g0(nw)
      double precision :: gg(40,nw)
      integer :: i
      double precision :: i00(nw)
      integer :: j
      integer :: k
      integer :: l
      integer :: m
      integer :: nl
      integer :: nt
      double precision :: q0m(21,40,nw)
      double precision :: q1(21,40,nw)
      double precision :: s(21,40,nw)
      double precision :: sum(nw)
      double precision :: x
      double precision :: xgama_0(40,nw)
      double precision :: xgama_xy(40,40,nw)
      double precision :: xi(21,40,nw)
      double precision :: xl(nw)
      double precision :: xm
      double precision :: xmu0
      double precision :: xnn(nw)
      double precision :: xr
      double precision :: y
c initialise locals
      dl=0
      g0=0
      gg=0
      i=0
      i00=0
      j=0
      k=0
      l=0
      m=0
      nl=0
      nt=0
      q0m=0
      q1=0
      s=0
      sum=0
      x=0
      xgama_0=0
      xgama_xy=0
      xi=0
      xl=0
      xm=0
      xmu0=0
      xnn=0
      xr=0
      y=0
c      print*,'n nwands',nw
      xmu0 = abs(cos(teta_01))
      m = 20
      dl = lai(1:nw)/float(m)
      call g_ross(g0,teta_01)
      xm = 0.5*(1.+(-1.))
      xr = 0.5*(1.-(-1.))
      i00 = 1.
      do j = 1, number
        x = xm+xr*points(j)
        call g_ross(gg(j,:),acos(x))
      end do
      do k = 1, m+1
        do j = 1, number
          s(k,j,:) = 0.
          xif(k,j,:) = 0.
        end do
      end do
      xi = 0.
      s = 0.
      do k = 1, m+1
        xl = float(k-1)*dl
        do i = 1, number/2
          x = xm+xr*points(i)
          if (abs(x) .eq. xmu0) then
            i0(k,i,1:nw) = i00*exp(-(g0/xmu0*xl))
          else
            i0(k,i,:) = 0.
          endif
        end do
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do i = number/2+1, number
          x = xm+xr*points(i)
          i0(k,i,1:nw) = 2.*rs*i00*xmu0*exp(-(g0/xmu0*lai(1:nw)))
     $*exp(-(gg(i,:)/x*(lai(1:nw)-xl)))
        end do
      end do
      do i = 1, number
        y = xm+xr*points(i)
        do j = 1, number
          x = xm+xr*points(j)
          call fase_leaf(xgama_xy(i,j,:),acos(x),acos(y))
        end do
      end do
      do k = m, 1, -1
        do i = 1, number
          y = xm+xr*points(i)
          sum = 0.
          do j = number/2+1, number
            x = xm+xr*points(j)
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)*(i0(k+1,j,1:nw)
     $+i0(k,j,1:nw))
     $/2.
          end do
          q0m(k,i,:) = sum
        end do
      end do
      do i = 1, number
        x = xm+xr*points(i)
        call fase_leaf(xgama_0(i,:),teta_01,acos(x))
      end do
      do k = 1, m+1
        xl = float(k-1)*dl
        do j = 1, number/2
          x = xm+xr*points(j)
          if (abs(x) .ne. xmu0) then
            xi(k,j,:) = i00*2.*xgama_0(j,:)*xmu0*(exp(-(g0/xmu0*xl))
     $-exp(-(gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
            xi1u(k,j,1:nw) = i00*2.*xgama_0(j,:)*
     $xmu0*(exp(-(g0/xmu0*xl))
     $-exp(-(gg(j,:)/abs(x)*xl)))/(gg(j,:)*xmu0-g0*abs(x))
          else
            xi(k,j,:) = i00*xl*2.*xgama_0(j,:)*
     $exp(-(g0/xmu0*xl))/xmu0
            xi1u(k,j,1:nw) = i00*xl*2.*xgama_0(j,:)*
     $exp(-(g0/xmu0*xl))/xmu0
          endif
          xi(k,j,:) = amin1(1000.,amax1(-1000.,xi(k,j,:)))
          xi1u(k,j,:) = amin1(1000.,amax1(-1000.,xi1u(k,j,:)))

        end do
      end do
      xi1 = 0.
      do j = 1, number/2
        x = xm+xr*points(j)
        xi1(1:nw) = xi1(1:nw)+weights(j)*xr*abs(x)*2.*rs*xi(m+1,j,:)
      end do
      do k = m+1, 1, -1
        xl = float(k-1)*dl
        do j = number/2+1, number
          x = xm+xr*points(j)
          xi(k,j,:) = i00*2.*xgama_0(j,:)*xmu0*
     $(exp(-(g0/xmu0*xl))-exp(-(gg(j,:)/x*(lai(1:nw)-xl)))*
     $exp(-(g0/xmu0*lai(1:nw))))/(g0*x+gg(j,:)*xmu0)
          xi1u(k,j,1:nw) = i00*2.*xgama_0(j,:)*xmu0*
     $(exp(-(g0/xmu0*xl))-exp(-(gg(j,:)/x*(lai(1:nw)-xl)))*
     $exp(-(g0/xmu0*lai(1:nw))))/(g0*x+gg(j,:)*xmu0)
          xi(k,j,:) = amin1(1000.,amax1(-1000.,xi(k,j,:)))
          xi1u(k,j,:) = amin1(1000.,amax1(-1000.,xi1u(k,j,:)))

        end do
      end do
      do j = number/2+1, number
        xi(m+1,j,:) = 0.
        xi1u(m+1,j,:) = 0.
      end do
      do k = 1, m
        do i = 1, number
          y = xm+xr*points(i)
          sum = 0.
          do j = 1, number
            x = xm+xr*points(j)
            sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)*
     $(xi(k+1,j,:)+xi(k,j,:))
     $/2.
          end do
          q1(k,i,:) = sum
        end do
      end do
      do k = 1, m+1
        do j = 1, number/2
          xi(k,j,:) = 0.
        end do
      end do
      nl = nlm
      do l = 1, nl
        do k = 1, m
          do j = 1, number/2
            x = xm+xr*points(j)
            xi(k+1,j,:) = (s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k,j,:)
     $*(gg(j,:)/2.+x/dl))/(gg(j,:)/2.-x/dl)
          xi(k+1,j,:) = amin1(1000.,amax1(-1000.,xi(k+1,j,:)))
          end do
        end do
        ximt = 0.
        do j = 1, number/2
          x = xm+xr*points(j)
          ximt(1:nw) = ximt(1:nw)+weights(j)*xr*2.*rs*abs(x)*xi(m+1,j,:)
        end do
        do j = number/2+1, number
          xi(m+1,j,:) = ximt(1:nw)+xi1(1:nw)
          xi(m+1,j,:) = amin1(1000.,amax1(-1000.,xi(m+1,j,:)))
        end do
        do k = m, 1, -1
          do j = number/2+1, number
            x = xm+xr*points(j)
            xi(k,j,:) = (s(k,j,:)+q0m(k,j,:)+q1(k,j,:)-xi(k+1,j,:)
     $*(gg(j,:)/2.-x/dl))/(gg(j,:)/2.+x/dl)
          xi(k,j,:) = amin1(1000.,amax1(-1000.,xi(k,j,:)))
          end do
        end do
        nt = 0
        do k = 1, m+1
          do j = 1, number
            xnn = abs(xif(k,j,1:nw)-xi(k,j,:))
c this part not clear
            if (xnn(1) .lt. 0.0001) then
              nt = nt+1
            endif
            xif(k,j,1:nw) = xi(k,j,:)
          end do
        end do
        do k = 1, m
          do i = 1, number
            y = xm+xr*points(i)
            sum = 0.
            do j = 1, number
              x = xm+xr*points(j)
              sum = sum+weights(j)*xr*2.*xgama_xy(i,j,:)
     $*(xi(k+1,j,:)+xi(k,j,:))/2.
            end do
            s(k,i,:) = sum
          end do
        end do
      end do
      end subroutine multiple_dom


      subroutine psi_leaf_m( vpsi_leaf_m,
     $teta_e, teta_i, teta_l )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vpsi_leaf_m(nw)
      double precision :: teta_e
      double precision :: teta_i
      double precision :: teta_l

c==============================================
c declare local variables
c==============================================
      double precision :: xh1(nw)
      double precision :: xh2(nw)
      double precision :: xh3(nw)
      double precision :: xh4(nw)
      double precision :: xmu_e
      double precision :: xmu_i
      double precision :: xmu_l
c initialise locals
      xh1=0
      xh2=0
      xh3=0
      xh4=0
c main code
      xmu_e = cos(teta_e)
      xmu_i = cos(teta_i)
      xmu_l = cos(teta_l)
      call xh_leaf(xh1,xmu_e,xmu_l)
      call xh_leaf(xh2,-xmu_i,xmu_l)
      call xh_leaf(xh3,-xmu_e,xmu_l)
      call xh_leaf(xh4,xmu_i,xmu_l)
      vpsi_leaf_m = xh1*xh2+xh3*xh4
      end subroutine psi_leaf_m


      subroutine psi_leaf_p(vpsi_leaf_p,
     $ teta_e, teta_i, teta_l )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vpsi_leaf_p(nw)
      double precision :: teta_e
      double precision :: teta_i
      double precision :: teta_l

c==============================================
c declare local variables
c==============================================
      double precision :: xh1(nw)
      double precision :: xh2(nw)
      double precision :: xh3(nw)
      double precision :: xh4(nw)
      double precision :: xmu_e
      double precision :: xmu_i
      double precision :: xmu_l
c initialise locals
      xh1=0
      xh2=0
      xh3=0
      xh4=0
c start code
      xmu_e = cos(teta_e)
      xmu_i = cos(teta_i)
      xmu_l = cos(teta_l)
      call xh_leaf(xh1,xmu_e,xmu_l)
      call xh_leaf(xh2,xmu_i,xmu_l)
      call xh_leaf(xh3,-xmu_e,xmu_l)
      call xh_leaf(xh4,-xmu_i,xmu_l)
      vpsi_leaf_p = xh1*xh2+xh3*xh4
      end subroutine psi_leaf_p


      subroutine psi_ross( vpsi_ross,teta_i, x )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vpsi_ross(nw)
      double precision :: teta_i
      double precision :: x

c==============================================
c declare local variables
c==============================================
      double precision :: fit
      double precision :: smu
      double precision :: xmu
      double precision :: xp
c initialise locals
      fit=0
      xp=0
c main code
      xmu = cos(x)
      smu = sin(x)
      if (xmu .eq. 1.) then
        vpsi_ross = cos(teta_i)
      else
        if (sin(teta_i) .eq. 0.) then
          vpsi_ross = xmu
        else
          if (smu .eq. 0.) then
            xp = 0.
          else
            xp = 1.*cos(teta_i)/sin(teta_i)*xmu/smu
          endif
          if (abs(xp) .gt. 1.) then
            vpsi_ross = cos(teta_i)*xmu
          else
            fit = acos(-xp)
            vpsi_ross = cos(teta_i)*xmu*(2.*fit/pi-1.)
     $+2./pi*sqrt(1.-cos(
     $teta_i)**2)*sqrt(1.-cos(x)**2)*sin(fit)
          endif
        endif
      endif
      vpsi_ross = abs(vpsi_ross)
      end subroutine psi_ross


      subroutine rho_0_nadh_ad( rho_0_nad_ad, teta_e, phi_e, x_lambda_i 
     $)
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: phi_e
      double precision, intent(inout) :: rho_0_nad_ad(nw)
      double precision :: teta_e
      double precision :: x_lambda_i(nw)

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      integer :: i
      integer :: i1
      double precision :: ke(nw)
      double precision :: ki(nw)
      integer :: n_c0
      double precision :: xg1(nw)
      double precision :: xg2(nw)
      double precision :: xh_p(nw)
      double precision :: xh_p_ad(nw)
      double precision :: xli(nw)
      double precision :: xli_ad(nw)
      double precision :: xs1(nw)
      double precision :: xs1_ad(nw)
      double precision :: xs2(nw)
      double precision :: xs2_ad(nw)
      double precision :: tmplai_ad(nw)
      double precision :: tmplai(nw)
c initialise locals
      help_h=0
      i=0
      i1=0
      ke=0
      ki=0
      n_c0=0
      xg1=0
      xg2=0
      xh_p=0
      xli=0
      xs1=0
      xs2=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      xh_p_ad = 0.
      xli_ad = 0.
      xs1_ad = 0.
      xs2_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      n_c0 = lai(1)/x_lambda_i(1)
      call g_ross(xg1,teta_0)
      call  g_ross(xg2,teta_e)
      ki = xg1/abs(cos(teta_0))
      ke = xg2/cos(teta_e)
      xs1 = (1.-x_lambda_i*ki)**n_c0
      xs2 = 1.
      call geo(help_h,teta_e,teta_0,phi_e,phi_0)
      xli = c1(1:nw)/help_h
      tmplai = lai(1:nw)
      call hot_spot(xh_p,tmplai,xli)
      lai(1:nw) = tmplai
      do i = 1, n_c0
        xs2 = xs2*(1.-x_lambda_i*ke*xh_p)
      end do
      rs_ad(1:nw) = rs_ad(1:nw)+rho_0_nad_ad*xs2*xs1
      xs1_ad = xs1_ad+rho_0_nad_ad*rs*xs2
      xs2_ad = xs2_ad+rho_0_nad_ad*rs*xs1
      rho_0_nad_ad = 0.
      xs2 = 1.
      do i = n_c0, 1, -1
        xs2 = 1.
        do i1 = 1, i-1
          xs2 = xs2*(1.-x_lambda_i*ke*xh_p)
        end do
        xh_p_ad = xh_p_ad-xs2_ad*xs2*x_lambda_i*ke
        xs2_ad = xs2_ad*(1.-x_lambda_i*ke*xh_p)
      end do
      tmplai_ad = lai_ad(1:nw)
      tmplai = lai(1:nw)
      call hot_spoth_ad( xh_p_ad,tmplai,tmplai_ad,xli,xli_ad )
      lai_ad(1:nw) = tmplai_ad
      lai(1:nw) = tmplai
      xh_p_ad = 0.
      c1_ad(1:nw) = c1_ad(1:nw)+xli_ad/help_h
      xli_ad = 0.
      xs1_ad = 0.

      end subroutine rho_0_nadh_ad


      subroutine rho_0_nad( vrho_0_nad,
     $teta_e, phi_e, x_lambda_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: phi_e
      double precision :: vrho_0_nad(nw)
      double precision :: teta_e
      double precision :: x_lambda_i(nw)

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      integer :: i
      double precision :: ke(nw)
      double precision :: ki(nw)
      integer :: n_c0
      double precision :: xg1(nw)
      double precision :: xg2(nw)
      double precision :: xh_p(nw)
      double precision :: xli(nw)
      double precision :: xs1(nw)
      double precision :: xs2(nw)
      double precision :: tmplai(nw)
c initialise locals
      help_h=0
      i=0
      ke=0
      ki=0
      n_c0=0
      xg1=0
      xg2=0
      xh_p=0
      xli=0
      xs1=0
      xs2=0
c main code
      n_c0 = lai(1)/x_lambda_i(1)
      call g_ross(xg1,teta_0)
      call g_ross(xg2,teta_e)
      ki = xg1/abs(cos(teta_0))
      ke = xg2/cos(teta_e)
      xs1 = (1.-x_lambda_i*ki)**n_c0
      xs2 = 1.
      call geo(help_h,teta_e,teta_0,phi_e,phi_0)
      xli = c1(1:nw)/help_h
      tmplai = lai(1:nw)
      call hot_spot(xh_p,tmplai,xli)
      lai(1:nw) = tmplai
      do i = 1, n_c0
        xs2 = xs2*(1.-x_lambda_i*ke*xh_p)
      end do
      vrho_0_nad = rs*xs2*xs1
      end  subroutine rho_0_nad


      subroutine rho_1_nadh_ad( rho_1_nad_ad, teta_e, phi_e, x_lambda_i 
     $)
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: phi_e
      double precision, intent(inout) :: rho_1_nad_ad(nw)
      double precision :: teta_e
      double precision :: x_lambda_i(nw)

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      integer :: k
      double precision :: ke(nw)
      double precision :: ki(nw)
      integer :: n_c0
      double precision :: rho_1_nadi(nw)
      double precision :: sum(nw)
      double precision :: sum_ad(nw)
      double precision :: x_hp(nw)
      double precision :: x_hp_ad(nw)
      double precision :: xc1(nw)
      double precision :: xg1(nw)
      double precision :: xg2(nw)
      double precision :: xga(nw)
      double precision :: xga_ad(nw)
      double precision :: xl(nw)
      double precision :: xlh_ad(nw)
      double precision :: xli(nw)
      double precision :: xli_ad(nw)

c initalise locals
      help_h=0
      k=0
      ke=0
      ki=0
      n_c0=0
      rho_1_nadi=0
      sum=0
      x_hp=0
      xc1=0
      xg1=0
      xg2=0
      xga=0
      xl=0
      xli=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      sum_ad = 0.
      x_hp_ad = 0.
      xga_ad = 0.
      xlh_ad = 0.
      xli_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      n_c0 = lai(1)/x_lambda_i(1)
      call g_ross(xg1,teta_0)
      call g_ross(xg2,teta_e)
      ki = xg1/abs(cos(teta_0))
      ke = xg2/cos(teta_e)
      call gamma_leaf(xga,teta_0,phi_0,teta_e,phi_e)
      xc1 = 1.-x_lambda_i*ki
      call geo(help_h,teta_e,teta_0,phi_e,phi_0)
      xli = c1(1:nw)/help_h
      sum = 0.
      do k = 1, n_c0
        xl = x_lambda_i*k
        call hot_spot(x_hp,xl,xli)
        sum = sum+xc1**k*x_lambda_i*(1.-x_lambda_i*ke*x_hp)**k
      end do
      rho_1_nadi = cos(teta_0)
      sum_ad = sum_ad+rho_1_nad_ad/(cos(teta_e)*abs(rho_1_nadi))*xga
      xga_ad = xga_ad+rho_1_nad_ad*(sum/(cos(teta_e)*abs(rho_1_nadi)))
      rho_1_nad_ad = 0.
      do k = n_c0, 1, -1
        x_hp_ad = 0.
        xl = x_lambda_i*k
        call hot_spot(x_hp,xl,xli)
        x_hp_ad = x_hp_ad-sum_ad*xc1**k*x_lambda_i*x_lambda_i*ke*k*(1.-
     $x_lambda_i*ke*x_hp)**(k-1)
        call hot_spoth_ad( x_hp_ad,xl,xlh_ad,xli,xli_ad )
        x_hp_ad = 0.
      end do
      c1_ad(1:nw) = c1_ad(1:nw)+xli_ad/help_h
      xli_ad = 0.
      call gamma_leafh_ad( xga_ad,teta_0,phi_0,teta_e,phi_e )
      xga_ad = 0.

      end subroutine rho_1_nadh_ad


      subroutine rho_1_nad( vrho_1_nad, teta_e, phi_e, x_lambda_i )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: phi_e
      double precision :: vrho_1_nad(nw)
      double precision :: teta_e
      double precision :: x_lambda_i(nw)

c==============================================
c declare local variables
c==============================================
      double precision :: help_h(nw)
      integer :: k
      double precision :: ke(nw)
      double precision :: ki(nw)
      integer :: n_c0
      double precision :: sum(nw)
      double precision :: x_hp(nw)
      double precision :: xc1(nw)
      double precision :: xg1(nw)
      double precision :: xg2(nw)
      double precision :: xga(nw)
      double precision :: xl(nw)
      double precision :: xli(nw)
c initialise locals
      help_h=0
      k=0
      ke=0
      ki=0
      n_c0=0
      sum=0
      x_hp=0
      xc1=0
      xg1=0
      xg2=0
      xga=0
      xl=0
      xli=0
c main code
      n_c0 = lai(1)/x_lambda_i(1)
      call g_ross(xg1,teta_0)
      call g_ross(xg2,teta_e)
      ki = xg1/abs(cos(teta_0))
      ke = xg2/cos(teta_e)
      call gamma_leaf(xga,teta_0,phi_0,teta_e,phi_e)
      xc1 = 1.-x_lambda_i*ki
      call geo(help_h,teta_e,teta_0,phi_e,phi_0)
      xli = c1(1:nw)/help_h
      sum = 0.
      do k = 1, n_c0
        xl = x_lambda_i*k
        call hot_spot(x_hp,xl,xli)
        sum = sum+xc1**k*x_lambda_i*(1.-x_lambda_i*ke*x_hp)**k
      end do
      vrho_1_nad = sum/(cos(teta_e)*abs(cos(teta_0)))*xga
      end  subroutine rho_1_nad


      subroutine rho_mult_nadh_ad( rho_mult_nad_ad, teta_u )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: rho_mult_nad_ad(nw)
      double precision :: teta_u

c==============================================
c declare local variables
c==============================================
      double precision :: aa(nw)
      double precision :: aa_ad(nw)
      double precision :: bb(nw)
      double precision :: bb_ad(nw)
      double precision :: dl(nw)
      double precision :: dl_ad(nw)
      double precision :: gu(nw)
      integer :: j
      integer :: k
      integer :: k1
      integer :: m
      double precision :: mu
      double precision :: s1(nw)
      double precision :: s1_ad(nw)
      double precision :: sum(nw)
      double precision :: sum1(nw)
      double precision :: sum1_ad(nw)
      double precision :: sum2(nw)
      double precision :: sum2_ad(nw)
      double precision :: sum_ad(nw)
      double precision :: x(nw)
      double precision :: xgama_u(40,nw)
      double precision :: xgama_u_ad(40,nw)
      double precision :: xim(21,nw)
      double precision :: xim_ad(21,nw)
      double precision :: xm(nw)
      double precision :: xq0u(21,nw)
      double precision :: xq0u_ad(21,nw)
      double precision :: xq1(21,nw)
      double precision :: xq1_ad(21,nw)
      double precision :: xr(nw)
      double precision :: xsu(21,nw)
      double precision :: xsu_ad(21,nw)
c initialise locals
      aa=0
      bb=0
      dl=0
      gu=0
      j=0
      k=0
      k1=0
      m=0
      mu=0
      s1=0
      sum=0
      sum1=0
      sum2=0
      x=0
      xgama_u=0
      xim=0
      xm=0
      xq0u=0
      xq1=0
      xr=0
      xsu=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      aa_ad = 0.
      bb_ad = 0.
      dl_ad = 0.
      s1_ad = 0.
      sum1_ad = 0.
      sum2_ad = 0.
      sum_ad = 0.
      xgama_u_ad = 0.
      xim_ad = 0.
      xq0u_ad = 0.
      xq1_ad = 0.
      xsu_ad = 0.
c      print*,'xx ..1',rho_mult_nad_ad, teta_u
c----------------------------------------------
c routine body
c----------------------------------------------
      m = 20
      dl = lai(1:nw)/m
      xm = 0.5*(1.-1.)
      xr = 0.5*(1.+1.)
      do j = 1, number
        x = xm+xr*points(j)
c        print*,'xx ..2',j,xgama_u(j,:),x(1),teta_u
        call fase_leaf(xgama_u(j,:),acos(x(1)),teta_u)
      end do
      do k = 1, m
        sum = 0.
        do j = 1, number
          sum = sum+2.*xgama_u(j,:)*xr*weights(j)*(xif(k+1,j,1:nw)
     $+xif(k,j,1:nw))/2.
        end do
        xsu(k,:) = sum
      end do
      do k = m, 1, -1
        sum1 = 0.
        do j = number/2+1, number
          sum1 = sum1+weights(j)*xr*2.*xgama_u(j,:)*
     $(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.
        end do
        xq0u(k,:) = sum1
      end do
      do k = 1, m
        sum2 = 0.
        do j = 1, number
          sum2 = sum2+2.*xgama_u(j,:)*xr*weights(j)*
     $(xi1u(k+1,j,1:nw)+xi1u(k,j,1:nw))/2.
        end do
        xq1(k,:) = sum2
      end do
      call  g_ross(gu,teta_u)
      mu = cos(teta_u)
      xim(m+1,:) = ximt(1:nw)+xi1(1:nw)
c      print*,'rho_mult_nad_ad',rho_mult_nad_ad
      xim_ad(1,:) = xim_ad(1,:)+rho_mult_nad_ad/(2.*abs(cos(teta_0)))
      rho_mult_nad_ad = 0.
      do k = 1, m
        xim(m+1,:) = ximt(1:nw)+xi1(1:nw)
        do k1 = m, k-(-1), -1
          s1 = xsu(k1,:)+xq1(k1,:)+xq0u(k1,:)
          aa = gu/2.-mu/dl
          bb = gu/2.+mu/dl
          xim(k1,:) = (s1-xim(k1+1,:)*aa)/bb
        end do
        s1 = xsu(k,:)+xq1(k,:)+xq0u(k,:)
        aa = gu/2.-mu/dl
        bb = gu/2.+mu/dl
        aa_ad = aa_ad-xim_ad(k,:)*(xim(k+1,:)/bb)
        bb_ad = bb_ad-xim_ad(k,:)*((s1-xim(k+1,:)*aa)/(bb*bb))
        s1_ad = s1_ad+xim_ad(k,:)/bb
c        print*,'xim_ad',xim_ad
        xim_ad(k+1,:) = xim_ad(k+1,:)-xim_ad(k,:)*(aa/bb)
        xim_ad(k,:) = 0.
        dl_ad = dl_ad-bb_ad*(mu/(dl*dl))
        bb_ad = 0.
        dl_ad = dl_ad+aa_ad*(mu/(dl*dl))
        aa_ad = 0.
        xq0u_ad(k,:) = xq0u_ad(k,:)+s1_ad
        xq1_ad(k,:) = xq1_ad(k,:)+s1_ad
        xsu_ad(k,:) = xsu_ad(k,:)+s1_ad
        s1_ad = 0.
      end do
      xi1_ad(1:nw) = xi1_ad(1:nw)+xim_ad(m+1,:)
      ximt_ad(1:nw) = ximt_ad(1:nw)+xim_ad(m+1,:)
      xim_ad(m+1,:) = 0.
      do k = m, 1, -1
        sum2_ad = 0.
        sum2_ad = sum2_ad+xq1_ad(k,:)
c        print*,'xq1_ad',xq1_ad
        xq1_ad(k,:) = 0.
        do j = number, 1, -1
          xgama_u_ad(j,:) = xgama_u_ad(j,:)+
     $sum2_ad*(2*xr*weights(j)
     $*(xi1u(k+1,j,1:nw)+xi1u(k,j,1:nw))/2.)
          xi1u_ad(k+1,j,1:nw) = 
     $xi1u_ad(k+1,j,1:nw)+sum2_ad*(2*xgama_u(j,:)
     $*xr*weights(j)/2.)
          xi1u_ad(k,j,1:nw) = 
     $xi1u_ad(k,j,1:nw)+sum2_ad*(2*xgama_u(j,:)
     $*xr*weights(j)/2.)
        end do
        sum2_ad = 0.
      end do
c      print*,xi1u_ad
      do k = 1, m
        sum1_ad = 0.
        sum1_ad = sum1_ad+xq0u_ad(k,:)
        xq0u_ad(k,:) = 0.
        do j = number, number/2+1, -1
          i0_ad(k+1,j,1:nw) = 
     $i0_ad(k+1,j,1:nw)+sum1_ad*(2*weights(j)*xr*
     $xgama_u(j,:)/2.)
          i0_ad(k,j,1:nw) = 
     $i0_ad(k,j,1:nw)+sum1_ad*(2*weights(j)*xr*
     $xgama_u(j,:)/2.)
          xgama_u_ad(j,:) = 
     $xgama_u_ad(j,:)+sum1_ad*(2*weights(j)*
     $xr*(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.)
        end do
        sum1_ad = 0.
      end do
      do k = m, 1, -1
        sum_ad = 0.
        sum_ad = sum_ad+xsu_ad(k,:)
        xsu_ad(k,:) = 0.
        do j = number, 1, -1
          xgama_u_ad(j,:) = 
     $xgama_u_ad(j,:)+sum_ad*(2*xr*weights(j)*
     $(xif(k+1,j,1:nw)+xif(k,j,1:nw))/2.)
          xif_ad(k+1,j,1:nw) = 
     $xif_ad(k+1,j,1:nw)+sum_ad*(2*xgama_u(j,:)*
     $xr*weights(j)/2.)
          xif_ad(k,j,1:nw) = 
     $xif_ad(k,j,1:nw)+sum_ad*(2*xgama_u(j,:)*
     $xr*weights(j)/2.)
        end do
        sum_ad = 0.
      end do
      do j = 1, number
        x = xm+xr*points(j)
        call fase_leafh_ad( xgama_u_ad(j,:),acos(x(1)),teta_u )
        xgama_u_ad(j,:) = 0.
      end do
      lai_ad(1:nw) = lai_ad(1:nw)+dl_ad/float(m)
      dl_ad = 0.

      end subroutine rho_mult_nadh_ad


      subroutine rho_mult_nad(vrho_mult_nad, teta_u )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vrho_mult_nad(nw)
      double precision :: teta_u

c==============================================
c declare local variables
c==============================================
      double precision :: aa(nw)
      double precision :: bb(nw)
      double precision :: dl(nw)
      double precision :: g0(nw)
      double precision :: gu(nw)
      integer :: i
      integer :: j
      integer :: k
      integer :: m
      double precision :: mu
      double precision :: s1(nw)
      double precision :: sum(nw)
      double precision :: sum1(nw)
      double precision :: sum2(nw)
      double precision :: x
      double precision :: xgama_u(40,nw)
      double precision :: xim(21,nw)
      double precision :: xm
      double precision :: xmu0
      double precision :: xq0u(21,nw)
      double precision :: xq1(21,nw)
      double precision :: xr
      double precision :: xsu(21,nw)
c initialise locals
      aa=0
      bb=0
      dl=0
      g0=0
      gu=0
      i=0
      j=0
      k=0
      m=0
      mu=0
      s1=0
      sum=0
      sum1=0
      sum2=0
      x=0
      xgama_u=0
      xim=0
      xm=0
      xmu0=0
      xq0u=0
      xq1=0
      xr=0
      xsu=0
c main code
      do i = 1, 21
        do j = 1, 20
        end do
      end do
      xmu0 = abs(cos(teta_0))
      m = 20
      dl = lai(1:nw)/m
      call g_ross(g0,teta_0)
      xm = 0.5*(1.-1.)
      xr = 0.5*(1.+1.)
      do j = 1, number
        x = xm+xr*points(j)
        call fase_leaf(xgama_u(j,:),acos(x),teta_u)
      end do
      print*,'m,nw',m,nw
      do k = 1, m
        sum = 0.
        do j = 1, number
c	  print*,'j,number,points(j),xm,xr',j,number,points(j),xm,xr
          x = xm+xr*points(j)
c	  print*,'xgama_u(j,:)',xgama_u(j,:)
c	  print*,'weights(j)',weights(j)
	  if (j == 1) then 
		print*,k
	  	print*,'xif(k+1,j,1:nw)',xif(k+1,j,1:nw)
    	  endif
c	  print*,'xif(k,j,1:nw)',xif(k,j,1:nw)
c	  print*,'sum',sum
          sum = sum+2.*xgama_u(j,:)*xr*weights(j)*(xif(k+1,j,1:nw)
     $+xif(k,j,1:nw))/2.
        end do
        xsu(k,:) = sum
      end do
c      print*,'xsu',xsu
      do k = m, 1, -1
        sum1 = 0.
        do j = number/2+1, number
          x = xm+xr*points(j)
          sum1 = sum1+weights(j)*xr*2.*xgama_u(j,:)*
     $(i0(k+1,j,1:nw)+i0(k,j,1:nw))/2.
        end do
        xq0u(k,:) = sum1
      end do
c      print*,'xq0u',xq0u
      do k = 1, m
        sum2 = 0.
        do j = 1, number
          x = xm+xr*points(j)
          sum2 = sum2+2.*xgama_u(j,:)*xr*weights(j)*(xi1u(k+1,j,1:nw)
     $+xi1u(k,j,1:nw))/2.
        end do
        xq1(k,:) = sum2
      end do
c      print*,'xq1',xq1
      call g_ross(gu,teta_u)
      mu = cos(teta_u)
      xim(m+1,:) = ximt(1:nw)+xi1(1:nw)
      do k = m, 1, -1
        s1 = xsu(k,:)+xq1(k,:)+xq0u(k,:)
        aa = gu/2.-mu/dl
        bb = gu/2.+mu/dl
        xim(k,:) = (s1-xim(k+1,:)*aa)/bb
      end do
c      print*,'xim',xim
      vrho_mult_nad = xim(1,:)/(2.*abs(cos(teta_0)))
c      print*,'vrho_mult_nad',vrho_mult_nad
c      print*,'xim(1,:)',xim(1,:)
c      print*,'teta_0',teta_0
c      print*,'(2.*abs(cos(teta_0)))',(2.*abs(cos(teta_0)))
      end  subroutine rho_mult_nad

      subroutine sun_fleckh_ad( sun_fleck_ad, teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision, intent(inout) :: sun_fleck_ad(nw)
      double precision :: teta_01

c==============================================
c declare local variables
c==============================================
      double precision :: a_trou(nw)
      double precision :: a_trou_ad(nw)
      double precision :: a_trouh(nw)
      double precision :: help_h(nw)
      double precision :: help_i(nw)
      double precision :: help_j(nw)
      double precision :: x_l_opt(nw)
      double precision :: x_lambda_trou(nw)
      double precision :: x_r1_ad(nw)
      double precision :: x_r2(nw)
      double precision :: x_trou(nw)
      double precision :: x_trou_ad(nw)
c initialise locals
      a_trou=0
      a_trouh=0
      help_h=0
      help_i=0
      help_j=0
      x_l_opt=0
      x_lambda_trou=0
      x_r2=0
      x_trou=0
c----------------------------------------------
c reset local adjoint variables
c----------------------------------------------
      a_trou_ad = 0.
      x_r1_ad = 0.
      x_trou_ad = 0.

c----------------------------------------------
c routine body
c----------------------------------------------
      x_l_opt = x_ly(1:nw)
      call g_ross(help_h,teta_01)
      x_r2 = abs(cos(teta_01))/(help_h*x_l_opt)
      call g_ross(help_i,teta_01)
      x_lambda_trou = -(log(0.9)*abs(cos(teta_01))/help_i)
      x_trou = x_lambda_trou/a_f(1:nw)
      call g_ross(help_j,teta_01)
      a_trou = (1.-x_trou*a_f(1:nw)*help_j/abs(cos(teta_01)))/x_trou
      x_r1_ad = x_r1_ad+sun_fleck_ad*sqrt(x_r2)
      sun_fleck_ad = 0.
      a_trou_ad = a_trou_ad+x_r1_ad*(1./(2.*sqrt(a_trou/pi))/pi)
      x_r1_ad = 0.
      a_trouh = cos(teta_01)
      a_f_ad(1:nw) = 
     $a_f_ad(1:nw)-a_trou_ad*(x_trou*help_j/abs(a_trouh)/x_trou)
      x_trou_ad = 
     $x_trou_ad-a_trou_ad*(a_f(1:nw)*help_j/abs(a_trouh)/x_trou+(
     $1.-x_trou*a_f(1:nw)*help_j/abs(a_trouh))/(x_trou*x_trou))
      a_trou_ad = 0.
      a_f_ad(1:nw) = 
     $a_f_ad(1:nw)-x_trou_ad*(x_lambda_trou/(a_f(1:nw)*a_f(1:nw)))
      x_trou_ad = 0.

      end subroutine sun_fleckh_ad


      subroutine sun_fleck( vsun_fleck,teta_01 )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vsun_fleck(nw)
      double precision :: teta_01

c==============================================
c declare local variables
c==============================================
      double precision :: a_trou(nw)
      double precision :: help_h(nw)
      double precision :: help_i(nw)
      double precision :: help_j(nw)
      double precision :: x_l_opt(nw)
      double precision :: x_lambda_trou(nw)
      double precision :: x_r1(nw)
      double precision :: x_r2(nw)
      double precision :: x_trou(nw)
c initialise locals
      a_trou=0
      help_h=0
      help_i=0
      help_j=0
      x_l_opt=0
      x_lambda_trou=0
      x_r1=0
      x_r2=0
      x_trou=0
c main code
      x_l_opt = x_ly(1:nw)
      call g_ross(help_h,teta_01)
      x_r2 = abs(cos(teta_01))/(help_h*x_l_opt)
      call g_ross(help_i,teta_01)
      x_lambda_trou = -(log(0.9)*abs(cos(teta_01))/help_i)
      x_trou = x_lambda_trou/a_f(1:nw)
      call g_ross(help_j,teta_01)
      a_trou = (1.-x_trou*a_f(1:nw)*help_j/abs(cos(teta_01)))/x_trou
      x_r1 = sqrt(a_trou/pi)
      vsun_fleck = sqrt(x_r2)*x_r1
      end  subroutine sun_fleck


      subroutine xh_leaf( vxh_leaf, xmu, xmu_l )
c******************************************************************
c******************************************************************
c** this routine was generated by automatic differentiation.     **
c** fastopt: transformation of algorithm in fortran, taf 1.9.69  **
c******************************************************************
c******************************************************************
c==============================================
c all entries are defined explicitly
c==============================================
      use mo_nad
      implicit none

c==============================================
c declare arguments
c==============================================
      double precision :: vxh_leaf(nw)
      double precision :: xmu
      double precision :: xmu_l

c==============================================
c declare local variables
c==============================================
      double precision :: x1
      double precision :: xfi(nw)
      double precision :: xh1(nw)
      double precision :: xh2(nw)
      double precision :: xh3(nw)
c initialise locals
      x1=0
      xfi=0
      xh1=0
      xh2=0
      xh3=0
c main code
      if (xmu .eq. 1.) then
        if (xmu_l .eq. 1.) then
          vxh_leaf = xmu*xmu_l
        else
          if (xmu_l .eq. (-1.)) then
            vxh_leaf = 0.
          else
            if (xmu_l .gt. 0.) then
              vxh_leaf = xmu*xmu_l
            else
              vxh_leaf = 0.
            endif
          endif
        endif
      else
        if (xmu_l .eq. 1.) then
          if (xmu .eq. 1.) then
            vxh_leaf = xmu*xmu_l
          else
            if (xmu .eq. (-1.)) then
              vxh_leaf = 0.
            else
              if (xmu .gt. 0.) then
                vxh_leaf = xmu*xmu_l
              else
                vxh_leaf = 0.
              endif
            endif
          endif
        else
          if (xmu .eq. (-1.)) then
            if (xmu_l .lt. 0.) then
              vxh_leaf = xmu*xmu_l
            else
              vxh_leaf = 0.
            endif
          else
            if (xmu_l .eq. (-1.)) then
              if (xmu .gt. 0.) then
                vxh_leaf = 0.
              else
                vxh_leaf = xmu*xmu_l
              endif
            else
              x1 = xmu*xmu_l/(sin(acos(xmu))*sin(acos(xmu_l)))
              if (x1 .gt. 1.) then
                vxh_leaf = xmu*xmu_l
              else
                if (x1 .lt. (-1.)) then
                  vxh_leaf = 0.
                else
                  xfi = acos(-x1)
                  xh1 = xmu*xmu_l*xfi
                  xh2 = sqrt(1.-xmu**2.)*sqrt(1.-xmu_l**2.)
                  xh3 = sin(xfi)
                  vxh_leaf = abs(xh1+xh2*xh3)/pi
                endif
              endif
            endif
          endif
        endif
      endif
      end  subroutine xh_leaf


