c=============================================================================c
        program MSE
c=============================================================================c
c
c  Purpose:  make a body-fitted Super-ellipse mesh
c
c  Author:   S. Scott Collis
c
c  Revised:  9-6-96
c  Revised:  3-11-2020
c
c=============================================================================c
c       implicit double precision (a-h,o-z)

        logical IRIS, DIAG
        parameter (IRIS = .false.)
        parameter (DIAG = .false.)

        parameter (zero=0.0d0,    pt5=0.5d0,  one=1.0d0,
     &             onept5=1.5d0,  two=2.0d0,  twopt5=2.5d0,
     &             three=3.0d0)
c
c.... must use a large mpts to make error in spline very small
c
        parameter (mpts=50000)
        dimension zz(mpts), s1(mpts), s2(mpts), ds1(mpts), ds2(mpts),
     &            dss1(mpts), dss2(mpts)

        parameter (mx=512,my=512)

        dimension xb(mx), yb(mx)
        dimension bn1(mx), bn2(mx)

        dimension xi(mx),  eta(my)

        dimension ss(mx), rr(my), dss(mx), drr(my), d2ss(mx), d2rr(my)

        dimension x(mx,my),    y(mx,my)
        dimension rm1(mx,my),  rm2(mx,my)
        dimension rn1(mx,my),  rn2(mx,my)
        dimension rjac(mx,my)
        dimension rm11(mx,my), rm12(mx,my), rm21(mx,my), rm22(mx,my)
        dimension rn11(mx,my), rn12(mx,my), rn21(mx,my), rn22(mx,my)
        dimension g11x(mx,my), g11y(mx,my), g12x(mx,my), g12y(mx,my)
        dimension g22x(mx,my), g22y(mx,my)

        dimension d(10), e(10), f1(10), f2(10), g0(10)

        common /stuff/ AR, rm, rn, xmin, xmax

        external xloc, yloc, calcs

c.... fourth order central difference ( 1 2 x 4 5 )

        parameter ( ga1 =  8.333333333333333333333E-02 )
        parameter ( ga2 = -6.666666666666666666667E-01 )
        parameter ( ga3 =  6.666666666666666666667E-01 )
        parameter ( ga4 = -8.333333333333333333333E-02 )

c.... fourth order one-sided ( x 2 3 4 5 )

        parameter ( gc1 = -2.083333333333333333333E+00 )
        parameter ( gc2 =  4.000000000000000000000E+00 )
        parameter ( gc3 = -3.000000000000000000000E+00 )
        parameter ( gc4 =  1.333333333333333333333E+00 )
        parameter ( gc5 = -2.500000000000000000000E-01 )

c.... fourth order biased difference ( 1 x 2 3 4 5 )

        parameter ( gb1 = -2.500000000000000000000E-01 )
        parameter ( gb2 = -8.333333333333333333333E-01 )
        parameter ( gb3 =  1.500000000000000000000E+00 )
        parameter ( gb4 = -5.000000000000000000000E-01 )
        parameter ( gb5 =  8.333333333333333333333E-02 )

        integer narg, iarg
        character(80) arg

        logical metric_ji
        integer xflag, yflag
c=============================================================================c
        metric_ji = .false.
        xflag = 1
        yflag = 1
c
c.... parse the argument list
c
        narg = iargc()
        do iarg = 1, narg
          call getarg(iarg,arg)
          select case (arg(1:3))
          case ('-ms')
            metric_ji = .true.
          case ('-ji')
            metric_ji = .true.
          case ('-x1')           ! exponential (default)
            xflag = 1
c         case ('-x2')           ! hyperbolic tangent
c           xflag = 2
          case ('-x3')           ! Mahesh in xi
            xflag = 3
c         case  ('-x4')          ! Mahesh in s
c           xflag = 4
          case ('-y1')           ! exponential (default)
            yflag = 1
          case ('-y2')           ! hyperbolic tangent
            yflag = 2
c         case ('-y3')           ! Mahesh
c           yflag = 3
          case ('-h')
            write(*,"('-----------------------------------------------')")
            write(*,"('Usage:  mse [options] ')")
            write(*,"('-----------------------------------------------')")
            write(*,"('   -h:  this help')")
            write(*,"('-----------------------------------------------')")
            write(*,"('  -ms:  write metrics in ji format')")
            write(*,"('  -ji:  write metrics in ji format')")
            write(*,"('  -x1:  exponential stretching in x (default)')")
c           write(*,"('  -x2:  hyperbolic tangent map in x')")
            write(*,"('  -x3:  Mahesh''s mapping in x')")
c           write(*,"('  -x4:  Mahesh''s mapping in s')")
            write(*,"('  -y1:  exponential stretching in y (default)')")
            write(*,"('  -y2:  hyperbolic tangent map in y')")
c           write(*,"('  -y3:  Mahesh''s mapping in y')")
            write(*,"('-----------------------------------------------')")
            call exit(0)
          case default
            write(*,"('Argument ',i2,' ignored.')") iarg
          end select
        end do
c
c.... keyboard input
c
        write(*,"('Enter AR (often 6) ==> ',$)")
        read(*,*) AR
        xmin = zero
        rmin = zero
        write(*,"('Enter xmax, rmax ==> ',$)")
        read(*,*) xmax, rmax
        write(*,"('Enter m (usually 4) ==> ',$)")
        read(*,*) rm
        rn = two
        write(*,"('Enter Nx, Ny ==> ',$)")
        read(*,*) nx, ny
c
c.... discretize in the body tangent direction
c
        smin = zero
        smax = arc(xmin,xmax)
        savg = (smin + smax) * pt5
        write(*,10) xmin, xmax, smax
        if (nx.gt.mx) stop 'nx > mx'
        dxi = one / real(nx-1)
        ds  = (smax-smin) / real(nx-1)

        write(*,*) 'Smax = ',smax,', xloc(smax) = ',xloc(xmin,smax)
c
c.... exponential map in the streamwise direction
c
        if (xflag.eq.1) then
          write(*,"('Enter dsmin ==> ',$)")
          read(*,*) dsmin
          sx = calcs( smin, smax, dsmin, dxi )
          write(*,*) 'Sx = ', sx
          c2 = log( dsmin / dxi )
          c1 = (log( sx * dsmin / dxi) - c2) / dxi
          do i = 1, nx
            xi(i)   = real(i-1) * dxi
            ss(i)   = smin + one / c1 * ( exp(c1 * xi(i) + c2) - exp(c2) )
            dss(i)  = exp(c1 * xi(i) + c2)
            d2ss(i) = c1 * exp(c1 * xi(i) + c2)
            if (i.ne.1) then
              write(10,30) xi(i), ss(i), dss(i), d2ss(i),
     &                     (ss(i)-ss(i-1))/dxi
            else
              write(10,30) xi(i), ss(i), dss(i), d2ss(i), zero
            end if
          end do
        end if
c
c.... Mahesh mapping, personal communication (6-5-96)
c
        if (xflag.eq.3) then
          write(*,"('Enter dsmin, b, sc ==> ',$)")
          read(*,*) dsmin, b, sc
          cm = ( two * b * tanh(b*sc) + (nx-1)*dsmin/smax *
     &           log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) ) /
     &         ( one - (nx-1)*dsmin/smax )
          do i = 1, nx
            xi(i)   = dble(i-1) * dxi
            ss(i)   = smin + smax*( cm * xi(i) + log( cosh(b*(xi(i)-sc)) /
     &                cosh(b*(xi(i)+sc)) ) ) /
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            dss(i)  = smax*(cm + b*tanh(b*(xi(i)-sc)) - b*tanh(b*(xi(i)+sc)))/
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
            d2ss(i) = smax*(-b**2*(tanh(b*(xi(i)-sc)))**2 +
     &                b**2*(tanh(b*(xi(i)+sc)))**2)/
     &                (cm + log( cosh(b*(one-sc)) / cosh(b*(one+sc)) ) )
          end do
        end if
c
c.... spline the tangent mapping function
c
        if (.false.) then
          npts = mpts
          if (npts.gt.mpts) stop 'npts > mpsts'
          ds = two / real(npts-1)
          c  = 0.333333333333333333333d0
          c1 = 4.0d0
          c2 = 20.0d0
          c3 = zero
          do i = 1, npts
            s1(i) = -one + real(i-1) * ds
            f = pt5 * c1 * tanh(c2*(s1(i)-c3))
            zz(i) = c * ( s1(i) + f + one - pt5 * c1 *
     &            tanh( c2*(-one-c3) ) ) - one
          end do
        end if
c
c.... spline the tangent mapping function
c
        if (.false.) then
          write(*,*) 'Discretize in the wall tangent direction'
          npts = mpts
          if (npts.gt.mpts) stop 'npts > mpsts'
          ds = one / real(npts-1)

          c  = 0.50251256281407d0       ! WARNING: Must be updated

          c1 = 1.0d0
          c2 = 150.0d0
          c3 = zero
          f0 = pt5 * c1 * tanh(c2*(zero-c3))

          d(1)  = 50.0d0
          e(1)  = 30.0d0
          f1(1) = -0.01d0
          f2(1) = 0.01d0

          d(2)  = 1.0d0
          e(2)  = 20.0d0
          f1(2) = 0.12d0
          f2(2) = 0.17d0

          d(3)  = 1.0d0
          e(3)  = 20.0d0
          f1(3) = 0.03d0
          f2(3) = 0.10d0

          kmax  = 3
          do k = 1, kmax
            g0(k) = (d(k)-one)/(two*e(k)) * log( Cosh(e(k)*(zero-f1(k)))/
     &            Cosh(e(k)*(zero-f2(k))) )
          end do

          do i = 1, npts
            s1(i) = zero + real(i-1) * ds
            f = pt5 * c1 * tanh(c2*(s1(i)-c3))
            zz(i) = s1(i) + f - f0
            do k = 1, kmax
              g = (d(k)-one)/(two*e(k)) * log( Cosh(e(k)*(s1(i)-f1(k)))/
     &           Cosh(e(k)*(s1(i)-f2(k))) )
              zz(i) = zz(i) + g - g0(k)
            end do
            zz(i) = c * ( zz(i) )
          end do
c
c.... compute the derivative of the mapping function and spline it
c
          ds1(1) = ( gc1 * zz(1) + gc2 * zz(2) + gc3 * zz(3) +
     &               gc4 * zz(4) + gc5 * zz(5) ) / ds
          ds1(2) = ( gb1 * zz(1) + gb2 * zz(2) + gb3 * zz(3) +
     &               gb4 * zz(4) + gb5 * zz(5) ) / ds
          do i = 3, npts-2
             ds1(i) = ( ga1 * zz(i-2) + ga2 * zz(i-1) +
     &                  ga3 * zz(i+1) + ga4 * zz(i+2) ) / ds
          end do
          ds1(npts-1) = -( gb1 * zz(npts) + gb2 * zz(npts-1) +
     &                     gb3 * zz(npts-2) +
     &                     gb4 * zz(npts-3) + gb5 * zz(npts-4) ) / ds
          ds1(npts) = -( gc1 * zz(npts) + gc2 * zz(npts-1) +
     &                   gc3 * zz(npts-2) +
     &                   gc4 * zz(npts-3) + gc5 * zz(npts-4) ) / ds
          do i = 1, npts
             ds1(i) = one / ds1(i)
          end do
c
c.... compute the second derivative of the mapping function
c
          dss1(1) = ( gc1 * ds1(1) + gc2 * ds1(2) + gc3 * ds1(3) +
     &                gc4 * ds1(4) + gc5 * ds1(5) ) / ds
          dss1(2) = ( gb1 * ds1(1) + gb2 * ds1(2) + gb3 * ds1(3) +
     &                gb4 * ds1(4) + gb5 * ds1(5) ) / ds
          do i = 3, npts-2
             dss1(i) = ( ga1 * ds1(i-2) + ga2 * ds1(i-1) +
     &                   ga3 * ds1(i+1) + ga4 * ds1(i+2) ) / ds
          end do
          dss1(npts-1) = -( gb1 * ds1(npts) + gb2 * ds1(npts-1) +
     &                      gb3 * ds1(npts-2) + gb4 * ds1(npts-3) +
     &                      gb5 * ds1(npts-4) ) / ds
          dss1(npts) = -( gc1 * ds1(npts) + gc2 * ds1(npts-1) +
     &                    gc3 * ds1(npts-2) +
     &                    gc4 * ds1(npts-3) + gc5 * ds1(npts-4) ) / ds
          do i = 1, npts
             dss1(i) = dss1(i) * ds1(i)
          end do

        end if

        call NR_SPLINE(zz,  s1,npts,1.0d11,1.0d11,  s2)
        call NR_SPLINE(zz, ds1,npts,1.0d11,1.0d11, ds2)
        call NR_SPLINE(zz,dss1,npts,1.0d11,1.0d11,dss2)
c
c.... arbitrary mapping function or uniform mesh
c
        if (.false.) then
          do i = 1, nx
            xi(i) = zero + real(i-1) * dxi
c           call NR_SPLINT(zz,s1,s2,npts, xi(i), ss(i), dss(i), d2ss(i))
            if (.true.) then
              call NR_SPLINT(zz,  s1,  s2,npts, xi(i),   ss(i), tmp, tmp)
              call NR_SPLINT(zz, ds1, ds2,npts, xi(i),  dss(i), tmp, tmp)
              call NR_SPLINT(zz,dss1,dss2,npts, xi(i), d2ss(i), tmp, tmp)
              ss(i)  = smin + ss(i) * smax
              dss(i) = dss(i) * smax
              d2ss(i) = d2ss(i) * smax
            else
              ss(i)   = smin + float(i-1) * ds
              dss(i)  = ds/dxi
              d2ss(i) = zero
            end if
            if (i.ne.1) then
              write(10,30) xi(i), ss(i), dss(i), d2ss(i),
     &                     (ss(i)-ss(i-1))/dxi
            else
              write(10,30) xi(i), ss(i), dss(i), d2ss(i), zero
            end if
          end do
        end if
c
c=============================================================================
c
c.... discretize in the body normal direction
c
        if (ny.gt.my) stop 'ny > my'
        deta = one / real(ny-1)
        dr   = (rmax-rmin) / real(ny-1)
        write(*,15) rmin, rmax
c
c.... exponential map in the wall normal direction
c
        if (yflag.eq.1) then
          write(*,"('Enter drmin ==> ',$)")
          read(*,*) drmin
          sr = calcs( rmin, rmax, drmin, deta )
          write(*,*) 'Sr = ', sr
          c2 = log( drmin / deta )
          c1 = (log( sr*drmin / deta) - c2) / deta
          do j = 1, ny
            eta(j)  = real(j-1) * deta
            rr(j)   = rmin + one / c1 * ( exp(c1 * eta(j) + c2) - exp(c2) )
            drr(j)  = exp(c1 * eta(j) + c2)
            d2rr(j) = c1 * exp(c1 * eta(j) + c2)
            if (j.ne.1) then
              write(20,30) eta(j), rr(j), drr(j), d2rr(j),
     &                     (rr(j)-rr(j-1))/deta
            else
              write(20,30) eta(j), rr(j), drr(j), d2rr(j), zero
            end if
          end do
        end if
c
c.... Hyperbolic tangent stretching
c
        if (yflag.eq.2) then
        rd1 = 0.0005d0                  ! set for R=2400 MSE, r=50
        rd2 = 5.0d0
        dd  = 5.36966703089523d0

c       rd1 = 0.0050d0                  ! set for R=2400 MSE, r=50
c       rd2 = 5.0d0
c       dd  = 3.898620676884022

c       rd1 = 0.0100d0                  ! set for R=2400 MSE, r=50
c       rd2 = 5.0d0
c       dd  = 3.422429472016738d0

        do j = 1, ny
          eta(j) = real(j-1) * deta
          rr(j) =  rmax*(pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             eta(j)))*pt5)/(Sqrt(rd2/rd1) +
     &             (one - Sqrt(rd2/rd1))*
     &             (pt5 + one/Tanh(dd*pt5)*Tanh(dd*(-pt5 +
     &             eta(j)))*pt5))
          drr(j) = dd*Sqrt(rd2/rd1)*rmax*Cosh(dd*pt5)*
     &             one/Cosh(dd*(-pt5 + eta(j)))*
     &             (Sinh(dd*(one - eta(j))) + Sinh(dd*eta(j)))/
     &             (Sqrt(rd2/rd1)*Sinh(dd*(one - eta(j))) +
     &             Sinh(dd*eta(j)))**2
          d2rr(j) = dd**2*Sqrt(rd2/rd1)*rmax*
     &              (-Cosh(dd*(one - three*eta(j))) +
     &              Sqrt(rd2/rd1)*Cosh(dd*(two - three*eta(j))) -
     &              Cosh(dd*(one - eta(j))) +
     &              two*Sqrt(rd2/rd1)*Cosh(dd*(one - eta(j))) -
     &              two*Cosh(dd*eta(j)) +
     &              Sqrt(rd2/rd1)*Cosh(dd*eta(j)))*
     &              (one/Cosh(dd*(-pt5 + eta(j))))**2*(Sinh(dd))/
     &              (two*(Sqrt(rd2/rd1)*(Sinh(dd*(one - eta(j)))) +
     &              (Sinh(dd*eta(j))))**3)
          write(20,30) eta(j), rr(j), drr(j), d2rr(j)
        end do
        end if
c
c=============================================================================c
c.... Build the mesh
c=============================================================================c
c
c.... Compute the boundary and outward normal
c
        j = 1
        do i = 1, nx
          if (i.eq.1) then
             xl = xloc( xmin, ss(i) )
          else
             xl = xloc( xold, ss(i) - ss(i-1) )
          end if
          if (xl.lt.AR) then
             yl = yloc( xl )
             th = atan2( one/AR * rm/rn * (one - xl/AR)**(rm-one),
     &            (one - (one-xl/AR)**rm)**((rn-one)/rn) )
          else
             yl = one
             th = zero
          end if
          bn1(i) = -sin(th)
          bn2(i) =  cos(th)

          xb(i) = xl
          yb(i) = yl

          write(30,30) xl, yl, th, bn1(i), bn2(i)
          xold = xl
        end do
        write(*,*) 'Making the mesh'
c
c... Quick diagnostic
c
#ifdef MSE_DEBUG
        do i = 2, nx
          write(*,*) xb(i-1), xb(i), arc(xb(i-1),xb(i)), ss(i), arc(0.0,xb(i))
        end do
#endif
c
c.... Make the mesh
c
        do j = 1, ny
          do i = 1, nx
            x(i,j) = xb(i) + rr(j) * bn1(i)
            y(i,j) = yb(i) + rr(j) * bn2(i)
          end do
        end do
        write(*,*) 'Making the metrics'
c
c.... write out the body.dat file
c
        open(9,file='body.dat',status='unknown')
        j = 1
        do i = 1, nx
           write(9,"(1(i5,1x),5(1pe20.13,1x))") i, ss(i), xb(i), yb(i),
     &                                          bn1(i), bn2(i)
        end do
        close(9)
c
c.... write out a coord.dat file for the output plane
c
        open(9,file='coord.dat',status='unknown')
        i = nx
        do j = 1, ny
           write(9,"(2(i5,1x),2(1pe13.6,1x))") 0, 0, x(i,j), y(i,j)
        end do
        close(9)
c
c.... write out a top file
c
        open(9,file='top.dat',status='unknown')
        j = ny
        do i = 1, nx
           write(9,"(1(i5,1x),2(1pe13.6,1x))") i, x(i,j), y(i,j)
        end do
        close(9)
c
c.... Make the metrics
c
        do j = 1, ny
c         write(*,*) 'j = ',j
          do i = 1, nx
c==============================================================================
c.... first derivative metrics
c==============================================================================
            xl = xb(i)
            yl = yb(i)

            if (xl .eq. zero) then
              dydx = 1.0d30             ! one / zero
            else if (xl .lt. AR) then
              dydx = one / AR * rm/rn * ( one - xl/AR )**(rm-one) *
     &               ( one - (one - xl/AR)**rm )**((one-rn)/rn)
            else
              dydx = zero
            end if
            dxbds  = one / sqrt(one + dydx**2)

            if (xl .eq. zero) then
              dxdy = zero
            else if (xl .lt. AR) then
              dxdy = AR * rn/rm * ( one - xl/AR )**(one-rm) *
     &               (one - (one - xl/AR)**rm)**((rn-one)/rn)
            else
              dxdy = 1.0d30             ! one / zero
            end if
            dybds = one / sqrt( dxdy**2 + one )

            if (xl .eq. zero) then
              dx = zero
              dy = one/AR * rm/rn * (one)**(rm-one)

              ddxdx = 1.0d30
              ddydx = one/AR * rm*(rm-one)/rn * (one)**(rm-two)*
     &                (-one/AR)

              if (rn.eq.two) then
                ddxdy = one
              else
                ddxdy = (rn-one)*yl**(rn-two)
              end if
              ddydy = (one-rm)/AR*(one-yl**rn)**(-one/rm)*yl**(rn-one)

              d2dxdx2 = 1.0d30
              d2dydx2 = rm*(two - three*rm + rm**2)*(one)**rm/
     &                  (rn*(AR)**3)

              if (rn.eq.two) then
                d2dxdy2 = zero
                d2dydy2 = (-one+rm)*(one-yl**rn)**(-one-one/rm)*
     &                    (rm-rm*rn-rm*yl**rn-rn*yl**rn+rm*rn*yl**rn)/(AR*rm)
              else
                d2dxdy2 = (-two + rn)*(-one + rn)*yl**(-three + rn)
                d2dydy2 = (-one+rm)*yl**(-two+rn)*(one-yl**rn)**(-one-one/rm)*
     &                    (rm-rm*rn-rm*yl**rn-rn*yl**rn+rm*rn*yl**rn)/(AR*rm)
              endif
            else if (xl .lt. AR) then
              dx = (one - (one - xl/AR)**rm)**((rn-one)/rn)
              dy = one/AR * rm/rn * (one - xl/AR)**(rm-one)

              ddxdx = (rn-one)/rn * (one - (one - xl/AR)**rm)**(-one/rn) *
     &                (rm/AR * (one - xl/AR)**(rm-one))
              ddydx = one/AR * rm*(rm-one)/rn * (one - xl/AR)**(rm-two)*
     &                (-one/AR)

              ddxdy = (rn-one)*yl**(rn-two)
              ddydy = (one-rm)/AR*(one-yl**rn)**(-one/rm)*yl**(rn-one)

              d2dxdx2 = rm*(-one + rn)*(one - xl/AR)**rm*
     &                  (one - (one - xl/AR)**rm)**(-one - one/rn)*
     &                  (rn - rm*rn - rm*(one - xl/AR)**rm -
     &                  rn*(one - xl/AR)**rm + rm*rn*(one - xl/AR)**rm)/
     &                  (rn**2*(-AR + xl)**2)
              d2dydx2 = rm*(two - three*rm + rm**2)*(one - xl/AR)**rm/
     &                  (rn*(AR - xl)**3)

              if (rn.eq.two) then
                d2dxdy2 = zero
                d2dydy2 = (-one+rm)*(one-yl**rn)**(-one-one/rm)*
     &                    (rm-rm*rn-rm*yl**rn-rn*yl**rn+rm*rn*yl**rn)/(AR*rm)
              else
                d2dxdy2 = (-two + rn)*(-one + rn)*yl**(-three + rn)
                d2dydy2 = (-one+rm)*yl**(-two+rn)*(one-yl**rn)**(-one-one/rm)*
     &                    (rm-rm*rn-rm*yl**rn-rn*yl**rn+rm*rn*yl**rn)/(AR*rm)
              endif
            end if

            if ( xl .ge. AR ) then
              dbn1 = zero
              dbn2 = zero
            else if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              dbn1 = ( -ddydy/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdy +
     &                  two*dy*ddydy)/(dx**2 + dy**2)**onept5 ) * dybds
              dbn2 = ( ddxdy/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdy +
     &                 two*dy*ddydy)/(dx**2 + dy**2)**onept5 ) * dybds
            else
              dbn1  = ( -ddydx/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdx +
     &                   two*dy*ddydx)/(dx**2 + dy**2)**onept5 ) * dxbds
              dbn2  = ( ddxdx/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdx +
     &                  two*dy*ddydx)/(dx**2 + dy**2)**onept5 ) * dxbds
            end if

            dsdxi  = dss(i)
            drdxi  = zero

            dsdeta = zero
            drdeta = drr(j)

            dxds  = dxbds + rr(j) * dbn1
            dxdr  = bn1(i)

            dyds  = dybds + rr(j) * dbn2
            dydr  = bn2(i)

            dxdxi  = dxds * dsdxi  + dxdr * drdxi
            dxdeta = dxds * dsdeta + dxdr * drdeta

            dydxi  = dyds * dsdxi  + dydr * drdxi
            dydeta = dyds * dsdeta + dydr * drdeta

            rjac(i,j) = one / ( dxdxi * dydeta - dxdeta * dydxi )

            rm1(i,j) =  dydeta * rjac(i,j)
            rm2(i,j) = -dxdeta * rjac(i,j)

            rn1(i,j) = -dydxi * rjac(i,j)
            rn2(i,j) =  dxdxi * rjac(i,j)

            if (j .eq. 1)  write(60,30) ss(i), bn1(i), dbn1, bn2(i), dbn2,
     &                     sqrt(dbn1**2 + dbn2**2)

            if (DIAG) then
            if (j .eq. 1)  write(40,30) ss(i), x(i,j), dxds,
     &                     (x(i+1,j)-x(i-1,j))/(ss(i+1)-ss(i-1))
            if (j .eq. 1)  write(50,30) ss(i), y(i,j), dyds,
     &                     (y(i+1,j)-y(i-1,j))/(ss(i+1)-ss(i-1))
            if (j .eq. 1)  write(60,30) ss(i), bn1(i), dbn1, bn2(i), dbn2,
     &                     sqrt(dbn1**2 + dbn2**2)
            if (j .eq. ny) write(65,30) ss(i), rm1(i,j), rn1(i,j), rm2(i,j),
     &                     rn2(i,j), rjac(i,j)
            if (j .eq. ny) write(66,30) ss(i), dxds, dsdxi, dxbds, dbn1
            if (j .eq. ny) write(67,30) ss(i), dydeta, dxdeta, dydxi, dxdxi
            end if

            if (j.eq.1) write(35,30) ss(i), sqrt(dbn1**2+dbn2**2)
c==============================================================================
c.... second derivative metrics
c==============================================================================
            if (xl .ge. AR) then
              d2xdy2  = 1.0d99 ! one / zero
              d2ydx2  = zero
              d2xbds2 = zero
              d2ybds2 = zero
            else if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              if (rn.eq.two) then
                d2xdy2 = AR*rn*(one - yl**rn)**(one/rm)*
     &                   (-rm + rm*rn + rm*yl**rn - rn*yl**rn)/
     &                   (rm**2*(-one + yl**rn)**2)
              else
                d2xdy2 = AR*rn*yl**(-two + rn)*(one - yl**rn)**(one/rm)*
     &                   (-rm + rm*rn + rm*yl**rn - rn*yl**rn)/
     &                   (rm**2*(-one + yl**rn)**2)
              end if
              d2ybds2 = -(one + dxdy**2)**(-onept5) * dxdy *
     &                  d2xdy2 * dybds
              d2xbds2 = d2xdy2*(dybds)**2 + dxdy*d2ybds2
            else
              d2ydx2 = rm*(one - xl/AR)**rm*(one-(one-xl/AR)**rm)**(one/rn)*
     &                  (rn - rm*rn + rm*(one - xl/AR)**rm -
     &                  rn*(one - xl/AR)**rm)/
     &                  (rn**2*(-AR + xl)**2*(-one + (one - xl/AR)**rm)**2)
              d2xbds2 = -(one + dydx**2)**(-onept5) * dydx *
     &                  d2ydx2 * dxbds
              d2ybds2 = d2ydx2*(dxbds)**2 + dydx*d2xbds2
            end if

            if ( xl .ge. AR ) then
              d2bn1 = zero
              d2bn2 = zero
            else ! if ( abs(bn1(i)) .gt. abs(bn2(i)) ) then
              d2bn1 = ((ddxdy*(dy*ddxdy-dx*ddydy)+dx*(dy*d2dxdy2-dx*d2dydy2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dx*(dy*ddxdy-dx*ddydy)*(dx*ddxdy+dy*ddydy))/
     &                (dx**2+dy**2)**(twopt5))*(dybds)**2 +
     &                (-ddydy/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdy +
     &                  two*dy*ddydy)/(dx**2 + dy**2)**onept5) * d2ybds2
              d2bn2 = ((ddydy*(dy*ddxdy-dx*ddydy)+dy*(dy*d2dxdy2-dx*d2dydy2))/
     &                (dx**2+dy**2)**(onept5) -
     &                (three*dy*(dy*ddxdy-dx*ddydy)*(dx*ddxdy+dy*ddydy))/
     &                (dx**2+dy**2)**(twopt5))*(dybds)**2 +
     &                (ddxdy/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdy +
     &                 two*dy*ddydy)/(dx**2 + dy**2)**onept5) * d2ybds2
c           else
c             d2bn1 = (three*dx*(ddydx*dx - ddxdx*dy)*(ddxdx*dx + ddydx*dy)/
c     &         (dx**2 + dy**2)**(twopt5) +
c     &         ddxdx*(-(ddydx*dx) + ddxdx*dy)/
c     &         (dx**2 + dy**2)**(onept5) +
c     &         dx*(dy*d2dxdx2 - dx*d2dydx2)/
c     &         (dx**2 + dy**2)**(onept5))*(dxbds)**2 +
c     &         (dx*(-(ddydx*dx) + ddxdx*dy)/(dx**2 + dy**2)**(onept5)) *
c     &          d2xbds2
c
c                     ((ddxdx*(dy*ddxdx-dx*ddydx)+dx*(dy*d2dxdx2-dx*d2dydx2))/
c     &                (dx**2+dy**2)**(onept5) -
c     &                (three*dx*(dy*ddxdx-dx*ddydx)*(dx*ddxdx+dy*ddydx))/
c     &                (dx**2+dy**2)**(twopt5))*(dxbds)**2 +
c     &               (-ddydx/(dx**2 + dy**2)**pt5 + pt5*dy*(two*dx*ddxdx +
c     &                  two*dy*ddydx)/(dx**2 + dy**2)**onept5) * d2xbds2
c
c             d2bn2 = (three*dy*(ddydx*dx - ddxdx*dy)*(ddxdx*dx + ddydx*dy)/
c     &         (dx**2 + dy**2)**(twopt5) +
c     &         ddydx*(-(ddydx*dx) + ddxdx*dy)/
c     &         (dx**2 + dy**2)**(onept5) +
c     &         dy*(dy*d2dxdx2 - dx*d2dydx2)/
c     &         (dx**2 + dy**2)**(onept5))*(dxbds)**2 +
c     &         (dy*(-(ddydx*dx) + ddxdx*dy)/(dx**2 + dy**2)**(onept5)) *
c     &         d2xbds2
c
c             ((ddydx*(dy*ddxdx-dx*ddydx)+dy*(dy*d2dxdx2-dx*d2dydx2))/
c     &                (dx**2+dy**2)**(onept5) -
c     &                (three*dy*(dy*ddxdx-dx*ddydx)*(dx*ddxdx+dy*ddydx))/
c     &                (dx**2+dy**2)**(twopt5))*(dxbds)**2 +
c     &               (ddxdx/(dx**2 + dy**2)**pt5 - pt5*dx*(two*dx*ddxdx +
c     &                 two*dy*ddydx)/(dx**2 + dy**2)**onept5) * d2xbds2
            end if

            d2sdxi2    = d2ss(i)
            d2sdxideta = zero
            d2sdeta2   = zero

            d2rdxi2    = zero
            d2rdxideta = zero
            d2rdeta2   = d2rr(j)

            d2xds2  = d2xbds2 + rr(j) * d2bn1
            d2xdsdr = dbn1
            d2xdr2  = zero

            d2yds2  = d2ybds2 + rr(j) * d2bn2
            d2ydsdr = dbn2
            d2ydr2  = zero

            d2xdxi2 = d2xds2 * dsdxi**2 + dxds * d2sdxi2 +
     &                d2xdsdr * drdxi * dsdxi + d2xdsdr * drdxi * dsdxi +
     &                d2xdr2 * drdxi**2 + dxdr * d2rdxi2

            d2xdxideta = d2xds2 * dsdeta * dsdxi + dxds * d2sdxideta +
     &                   d2xdsdr * drdeta * dsdxi + d2xdsdr * drdxi * dsdeta +
     &                   d2xdr2 * drdeta * drdxi + dxdr * d2rdxideta

            d2xdeta2 = d2xds2 * dsdeta**2 + dxds * d2sdeta2 +
     &                 d2xdsdr * drdeta * dsdeta + d2xdsdr * drdeta * dsdeta +
     &                 d2xdr2 * drdeta**2 + dxdr * d2rdeta2

            d2ydxi2 = d2yds2 * dsdxi**2 + dyds * d2sdxi2 +
     &                d2ydsdr * drdxi * dsdxi + d2ydsdr * drdxi * dsdxi +
     &                d2ydr2 * drdxi**2 + dydr * d2rdxi2

            d2ydxideta = d2yds2 * dsdeta * dsdxi + dyds * d2sdxideta +
     &                   d2ydsdr * drdeta * dsdxi + d2ydsdr * drdxi * dsdeta +
     &                   d2ydr2 * drdeta * drdxi + dydr * d2rdxideta

            d2ydeta2 = d2yds2 * dsdeta**2 + dyds * d2sdeta2 +
     &                 d2ydsdr * drdeta * dsdeta + d2ydsdr * drdeta * dsdeta +
     &                 d2ydr2 * drdeta**2 + dydr * d2rdeta2

            drjacdxi = -(d2xdxi2*dydeta + dxdxi*d2ydxideta - d2xdxideta*dydxi -
     &                   dxdeta*d2ydxi2) * rjac(i,j)**2

            drjacdeta = -(d2xdxideta*dydeta + dxdxi*d2ydeta2 - d2xdeta2*dydxi -
     &                    dxdeta*d2ydxideta) * rjac(i,j)**2

            rm11(i,j) = drjacdxi * dydeta * rm1(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dydeta * rn1(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn1(i,j)

            rm12(i,j) = drjacdxi * dydeta * rm2(i,j) +
     &                  d2ydxideta * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dydeta * rn2(i,j) +
     &                  d2ydeta2 * rjac(i,j) * rn2(i,j)

            rm21(i,j) = -( drjacdxi * dxdeta * rm1(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dxdeta * rn1(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn1(i,j) )

            rm22(i,j) = -( drjacdxi * dxdeta * rm2(i,j) +
     &                     d2xdxideta * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dxdeta * rn2(i,j) +
     &                     d2xdeta2 * rjac(i,j) * rn2(i,j) )

            rn11(i,j) = -( drjacdxi * dydxi * rm1(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm1(i,j) +
     &                     drjacdeta * dydxi * rn1(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn1(i,j) )

            rn12(i,j) = -( drjacdxi * dydxi * rm2(i,j) +
     &                     d2ydxi2 * rjac(i,j) * rm2(i,j) +
     &                     drjacdeta * dydxi * rn2(i,j) +
     &                     d2ydxideta * rjac(i,j) * rn2(i,j) )

            rn21(i,j) = drjacdxi * dxdxi * rm1(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm1(i,j) +
     &                  drjacdeta * dxdxi * rn1(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn1(i,j)

            rn22(i,j) = drjacdxi * dxdxi * rm2(i,j) +
     &                  d2xdxi2 * rjac(i,j) * rm2(i,j) +
     &                  drjacdeta * dxdxi * rn2(i,j) +
     &                  d2xdxideta * rjac(i,j) * rn2(i,j)

            if (DIAG) then
            if (j .eq. 1) write(70,30) ss(i), dxbds, d2xbds2, dybds, d2ybds2
            if (j .eq. 1) write(71,30) ss(i), bn1(i), dbn1, d2bn1
            if (j .eq. 1) write(72,30) ss(i), bn2(i), dbn2, d2bn2
            end if

            if (j .eq. ny) write(74,30) x(i,j), rm1(i,j), rn1(i,j), rm2(i,j),
     &                                  rn2(i,j), rjac(i,j)
            if (j .eq. ny) write(75,30) x(i,j), rm11(i,j), rm12(i,j),
     &                                  rm21(i,j), rm22(i,j)
            if (j .eq. ny) write(76,30) x(i,j), rn11(i,j), rn12(i,j),
     &                                  rn21(i,j), rn22(i,j)
            if (j .eq. ny) write(77,30) ss(i), d2xds2, d2xbds2, d2bn1
            if (j .eq. ny) write(78,30) ss(i), d2yds2, d2ybds2, d2bn2

            g11x(i,j) = d2xdxi2
            g11y(i,j) = d2ydxi2
            g12x(i,j) = d2xdxideta
            g12y(i,j) = d2ydxideta
            g22x(i,j) = d2xdeta2
            g22y(i,j) = d2ydeta2
          end do
        end do
c
c.... compute the error in the cross derivatives
c
        errn = zero
        errm = zero
        do i = 1, nx
          do j = 1, ny
            errm = errm + ( rm12(i,j) - rm21(i,j) )**2
            errn = errn + ( rn12(i,j) - rn21(i,j) )**2
          end do
        end do
        write(*,*) 'Error in m ',sqrt(errm)/real(nx*ny)
        write(*,*) 'Error in n ',sqrt(errn)/real(nx*ny)
c
c..... diagnostic
c
        j = 1
        do i = 1, nx
          write(80,30) ss(i),
     &               (-rm1(i,j)*rm2(i,j)*rm11(i,j) + rm1(i,j)**2*rm12(i,j) -
     &               rm2(i,j)**2*rm12(i,j) + rm1(i,j)*rm2(i,j)*rm22(i,j) ) *
     &               sqrt(rn1(i,j)**2 + rn2(i,j)**2) /
     &               sqrt(rm1(i,j)**2 + rm2(i,j)**2) /
     &               (rm1(i,j)*rn2(i,j)-rm2(i,j)*rn1(i,j)),
     &               (rn1(i,j)*rn2(i,j)*rn11(i,j) - rn1(i,j)**2*rn12(i,j) +
     &               rn2(i,j)**2*rn12(i,j) - rn1(i,j)*rn2(i,j)*rn22(i,j) ) *
     &               sqrt(rm1(i,j)**2 + rm2(i,j)**2) /
     &               sqrt(rn1(i,j)**2 + rn2(i,j)**2) /
     &               (rm1(i,j)*rn2(i,j)-rm2(i,j)*rn1(i,j))
        end do
c
c.... write out some Plot3d files
c
        nz = 1
        write(*,*) 'Writing plot3d files for ',nx, ny, nz
c
c.... write out binary if on an IRIS
c
        if (IRIS) then
          call wgrid(x, y, nx, ny, nz, mx, my, 'grid.bin'//char(0))
          call wdata(rm1, rn1, rm2, rn2, rjac, nx, ny, nz, mx, my,
     &               'm1.bin'//char(0))
          call wdata(rm11, rm12, rm21, rm22, rjac, nx, ny, nz, mx, my,
     &               'm11.bin'//char(0))
          call wdata(rn11, rn12, rn21, rn22, rjac, nx, ny, nz, mx, my,
     &               'n11.bin'//char(0))
          call wdata(g11x, g11y, g12x, g12y, g22x, nx, ny, nz, mx, my,
     &               'grad.bin'//char(0))
        else
c
c.... write out unformatted if on a CRAY
c
          open(unit=10,file='grid.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) (((real(x(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(y(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(zero),   i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='m1.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((real( rm1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real( rn1(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real( rm2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real( rn2(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='m11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((real(rm11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rm12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rm21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rm22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rm1(i,j)*rn1(i,j)+rm2(i,j)*rn2(i,j)),
     &              i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          open(unit=10,file='n11.dat',form='unformatted')
          write(10) nx, ny, nz
          write(10) 0.0, 0.0, 0.0, 0.0
          write(10) (((real(rn11(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rn12(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rn21(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rn22(i,j)), i=1,nx), j=1,ny), k = 1, nz),
     &              (((real(rjac(i,j)), i=1,nx), j=1,ny), k = 1, nz)
          close(10)

          if (metric_ji) then
c
c.... write out the metric file (Note the order of i and j are reversed)
c
            open (unit=10, file='metric.dat', form='unformatted',
     &            status='unknown')
            write(10) (( real( rm1(i,j)), j=1,ny), i=1,nx),
     &                (( real( rm2(i,j)), j=1,ny), i=1,nx),
     &                (( real( rn1(i,j)), j=1,ny), i=1,nx),
     &                (( real( rn2(i,j)), j=1,ny), i=1,nx),
     &                (( real(rm11(i,j)), j=1,ny), i=1,nx),
     &                (( real(rm12(i,j)), j=1,ny), i=1,nx),
     &                (( real(rm22(i,j)), j=1,ny), i=1,nx),
     &                (( real(rn11(i,j)), j=1,ny), i=1,nx),
     &                (( real(rn12(i,j)), j=1,ny), i=1,nx),
     &                (( real(rn22(i,j)), j=1,ny), i=1,nx)
            close(10)
          else
c
c.... write out the metric file in IJ ordering
c
            open (unit=10, file='metric.dat', form='unformatted',
     &            status='unknown')
            write(10) (( real( rm1(i,j)), i=1,nx), j=1,ny),
     &                (( real( rm2(i,j)), i=1,nx), j=1,ny),
     &                (( real( rn1(i,j)), i=1,nx), j=1,ny),
     &                (( real( rn2(i,j)), i=1,nx), j=1,ny),
     &                (( real(rm11(i,j)), i=1,nx), j=1,ny),
     &                (( real(rm12(i,j)), i=1,nx), j=1,ny),
     &                (( real(rm22(i,j)), i=1,nx), j=1,ny),
     &                (( real(rn11(i,j)), i=1,nx), j=1,ny),
     &                (( real(rn12(i,j)), i=1,nx), j=1,ny),
     &                (( real(rn22(i,j)), i=1,nx), j=1,ny)
            close(10)
          end if
        end if

        stop
 10     format('xmin = ',1pe13.6,' xmax = ',1pe13.6,' S = ',1pe13.6)
 15     format('rmin = ',1pe13.6,' rmax = ',1pe13.6)
 20     format(i5,6(1x,1pe13.6))
 30     format(7(1x,1pe20.13))
        end

c=============================================================================c
        function calcs( ximin1, ximax1, dxmin1, ds1)
c
c  Calculate a stretching ratio to fill a domain using exponential
c  stretching.
c
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximin, ximax, dxmin, ds

        external funcs, rtflsp
c=============================================================================c
        ximin = ximin1
        ximax = ximax1
        dxmin = dxmin1
        ds = ds1

c       calcs = rtflsp(funcs, 1.01e0, 1.02e0, 1.0e-11)
        calcs = zbrent(funcs, 1.0001e0, 1.5e0, 1.0e-11)

        return
        end
c=============================================================================c
        function funcs(sx)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuffs/ ximin, ximax, dxmin, ds
c=============================================================================c
        c2 = log( dxmin / ds )
        c1 = (log( sx*dxmin / ds) - c2) / ds

        funcs = ximax - ximin - one / c1 * ( exp(c1 + c2) - exp(c2) )

        return
        end
c=============================================================================c
        function yloc(x)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        yloc = ( one - ( one - x/AR )**rm )**(one/rn)

        return
        end
c=============================================================================c
        function xloc(x,ds)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        external rtsec, rtflsp, func, zbrent

        common /stuff/ AR, rm, rn, xmin, xmax
        common /distance/ darc, x1
c=============================================================================c
        darc = ds
        x1   = x

c       xloc = rtsec(func,x1,xmax,1.0e-11)
        xloc = rtflsp(func,x1,x1+two*ds,1.0e-11)
c       xloc = zbrent(func,x1,x1+two*ds,1.0e-11)

        return
        end
c=============================================================================c
        function func(x)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        external arc

        common /distance/ darc, x1
c=============================================================================c
        func = darc - arc(x1,x)

        return
        end
c=============================================================================c
        function arc(x1,x2)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        parameter EPS = 1.0e-10
        parameter HMIN = 1.0e-8

        external derivs1, derivs2, RKQCR

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        s = zero
        xtmp = AR * pt5

        if (x1 .eq. x2 ) then
           arc = zero
           return
        end if

!       if (x1 .gt. x2) then
!          write(*,*) x1, x2
!          stop 'Error in arc:  x1 > x2'
!       end if
!       if (x1 .lt. xmin) stop 'Error in arc:  x1 < xmin'
!       if (x2 .gt. xmax) stop 'Error in arc:  x2 > xmax'

        if (x1 .le. xtmp) then
           y1 = ( one - ( one - x1/AR )**rm )**(one/rn)
           if (x2 .le. xtmp) then
             y2 = ( one - ( one - x2/AR )**rm )**(one/rn)
           else
             y2 = ( one - ( one - xtmp/AR )**rm )**(one/rn)
           end if
           call ODEINTR(s,1,y1,y2,EPS,(y2-y1)*pt5,
     &                  HMIN,nok,nbad,derivs2,RKQCR)
c          write(*,*) "1: NOK = ", nok, ', NBAD = ', nbad
           if (x2 .gt. xtmp) then
             call ODEINTR(s,1,xtmp,x2,EPS,(x2-xtmp)*pt5,
     &                    HMIN,nok,nbad,derivs1,RKQCR)
c            write(*,*) "2: NOK = ", nok, ', NBAD = ', nbad
           end if
        else
           call ODEINTR(s,1,x1,x2,EPS,(x2-x1)*pt5,
     &                  HMIN,nok,nbad,derivs1,RKQCR)
c          write(*,*) "3: NOK = ", nok, ', NBAD = ', nbad
        end if

        arc = s

        return
        end
c=============================================================================c
        subroutine derivs1(n,s,x,ds)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        if (x.lt.AR) then
          dydx = one / AR * rm/rn * ( one - x/AR )**(rm-one) *
     &           ( one - (one - x/AR)**rm )**((one-rn)/rn)
        else
          dydx = zero
        end if

        ds = sqrt( one + dydx**2 )

        return
        end
c=============================================================================c
        subroutine derivs2(n,s,y,ds)
c=============================================================================c
c       implicit double precision (a-h,o-z)
        parameter (zero=0.0d0, pt5=0.5d0, one=1.0d0, two=2.0d0)

        common /stuff/ AR, rm, rn, xmin, xmax
c=============================================================================c
        x = AR * ( one - (one - y**rn)**(one/rm) )

c       if (x .gt. pt5*AR) stop 'Error in derivs2'

        dxdy = AR * rn/rm * ( one - x/AR )**(one-rm) *
     &         (one - (one - x/AR)**rm)**((rn-one)/rn)

        ds = sqrt( dxdy**2 + one )

        return
        end


module m
implicit none
contains
pure subroutine grow_vec(x,xadd) ! append xadd(:) to x(:)
real, allocatable, intent(in out) :: x(:)
real             , intent(in)     :: xadd(:)
real, allocatable                 :: temp(:)
integer                           :: nx
if (.not. allocated(x)) allocate (x(0))
nx   = size(x)
allocate (temp(nx + size(xadd)))
temp(:nx) = x
temp(nx+1:) = xadd
call move_alloc(temp,x)
end subroutine grow_vec
end module m
!
program grow_array
use m, only: grow_vec
implicit none
real   , allocatable :: a(:),xran(:)
integer, parameter   :: nmax = 3*10**6, ngrow = 1000, nt = 4
integer              :: na
real                 :: t(nt)
logical              :: print_check
allocate (xran(nmax))
call random_number(xran)
print_check = .false.
if (print_check) print "(2a15)","size","max|a-xran|"
call cpu_time(t(1))
allocate (a(0))
na = 0
do ! grow array in a subroutine with copying and move_alloc
   call grow_vec(a,xran(na+1:na+ngrow))
   na = size(a)
   if (na >= nmax) exit
end do
if (print_check) print "(i15,f15.10)",size(a),maxval(abs(a-xran))
call cpu_time(t(2))
a = [real ::]
na = 0
do ! grow array using RESHAPE -- suggested by FortranFan
   a = reshape(a,[na+ngrow],pad=xran(na+1:na+ngrow))
   na = size(a)
   if (size(a) >= nmax) exit
end do
if (print_check) print "(i15,f15.10)",size(a),maxval(abs(a-xran))
call cpu_time(t(3))
a = [real ::]
na = 0
do ! grow array using allocation on assignment (AoA)
   a = [a,xran(na+1:na+ngrow)]
   na = size(a)
   if (size(a) >= nmax) exit
end do
if (print_check) print "(i15,f15.10)",size(a),maxval(abs(a-xran))
call cpu_time(t(4))
print "(/,4a15)","method","move_alloc","reshape","AoA"
print "(a15,3f15.3)","time(s)",t(2:nt) - t(1:nt-1)
end program grow_array
! sample gfortran -O3 output on Windows:
!          method     move_alloc        reshape            AoA
!         time(s)          4.750         13.734         18.547
! sample gfortran -O3 output on WSL2:
!          method     move_alloc        reshape            AoA
!         time(s)          3.480          4.528          4.458


!========================================================================
! PROGRAMA PRINCIPAL DEL LA SIMULACION, LLAMA SUBRUTINAS PARA REALIZAR
! LA SIMULACION
!Autor: Martin Alejandro Paredes Sosa
!========================================================================
Program Main
  Use cte
  Implicit None
  Integer :: i, j, IStep , k, k2                            !CONTADORES
  Real :: VLRC, VI, V, VOld, VNew, DV, VN                   !ENERGIAS
  Real :: OldX, OldY, NewX, NewY                            !VALORES TEMP DE POSC
  Real :: RanX, RanY, Dummy                                 !VALORES ALEATORIOS
  Real :: MAcep, Ratio                                      !VARIABLES DE CONTROL DE DRMAX
  Logical :: Ctrl, Ctrl1, Ctrl1A, Ctrl2                     !CONTROL LOGICO
  Integer :: istat1, istat2
  Character (len=80) :: err_msg1, err_msg2

  !PEDIR DENSIDAD Y NUMERO DE PARTICULAS
  Write(*,*) "NUMERO DE PARTICULAS"
  Read(*,*) N
  Write(*,*) "CONCENTRACION REDUCIDA"
  Read(*,*) Dens
  Write(*,*) "NUMERO DE CICLOS"
  Read(*,*) NStep
  Write(*,*) "MONITOREO EN PANTALLA (CADA CAUNTOS CICLOS)"
  Read(*,*) IPrint
  Write(*,*) "NUMERO DE PASOS PARA GUARDAR CONFIGURACION"
  Read(*,*) ISave
  Write(*,*) "FRECUENCIA DE CORRECCION EN DESPLAZAMIENTO"
  Read(*,*) IRatio

  !ALOJAR ESPACIO EN MEOMORIA PARA LOS ARREGLO DE POSICION DE PARTICULAS
  Allocate( X(N), Y(N), STAT= istat1 , ERRMSG=err_msg1  )

  !GENERAR LA CONFIGURACION INICIAL
  Call ConfigIni
  Write(*,*) "CONFIGURACION INICIAL LISTA"

  !CALCULO/PARAMETROS PARA INICIALIZAR
  RCut = BoxL / 2.0
  dRMax = 0.1
  MAcep = 0.0
  k2 = 0
  NN = ( NStep- CEq ) / ISave

  !ALOJAR ESPACIO EN MEOMORIA PARA LOS ARREGLOS DE CONFIGURACION
  Allocate( CX(N,NN), CY(N,NN), STAT= istat2 , ERRMSG=err_msg2 )

  !CORRECCION DE LARGO ALCANCE
  VLRC = 0 !NO SE OCUPA LA CORRECCION POR SER DE CORTO ALCANCE

  !CALCULAR LA ENERGIA DE LA CONFIGURACION
  Call EnergyConfig(V)
  VI = V + VLRC
  Write(*,*) "ENERGIA DE LA CONFIGURACION INICIAL:",  VI

  !ABRIENDO ARCHIVOS PARA GUARDAR INFO DEL SISTEMA
  Open(2, File="ConFin.dat")
  Open(3, File="Terma.dat" )
  !MOVIMIENTO DE PARTICULAS ALEATORIA

  Configuracion: Do iStep = 1, NStep

     Particula: Do i = 1, N

        OldX = X(i)
        OldY = Y(i)
        !CALCULAR LA ENERGIA DE LA i-PARTICULA
        Call EnergyPart(OldX, OldY, i, VOld)
        !Write(*,*) IStep, VOld
        !go to 111

        !GENERAR VALORES ALEATORIOS PARA MOV TENTATIVOS
        Call Random_Number(RanX)
        Call Random_Number(RanY)
        !Write(*,*) Ranx, Rany

        !MOVIMIENTO TENTATIVO
        NewX = OldX + (2.0*RanX - 1.0)*dRMax
        NewY = OldY + (2.0*RanY - 1.0)*dRMax

        !CONDICIONES PERIODICAS (MANTENER MISMA N EN TODA CONFIGURACION)
        NewX = NewX - BoxL*Anint(NewX/BoxL)
        NewY = Newy - BoxL*Anint(NewY/BoxL)

        !CALCULAR LA ENERGIA DE LA PARTICULA EN LA NUEVA POSICION
        Call EnergyPart(NewX, NewY, i, VNew)

        !MONTECARLO (CRITERIO DE ACEPTACION O RECHAZO DE MOV)
        DV = VNew - VOld
        Call Random_Number(Dummy) !PARA CRITERIO ENTRE 0.0 Y 75.0
        !Write(*,*) Dummy
        !MONTECARLO (ACEPTANDO MOVIMIENTOS POR CRITERIOS)
        MONTECARLO1: If(DV .LT. 75.0 ) Then

           MONTECARLO2: If(DV .LE. 0.0 ) Then
              V = V + DV
              X(i) = NewX
              Y(i) = NewY
              MAcep = MAcep + 1.0 !MOVIMIENTO ACEPTADOS POR MONTECARLO

           ElseIf( EXP(-DV) .GT. Dummy ) Then
              V = V + DV
              X(i) = NewX
              Y(i) = NewY
              MAcep = MAcep + 1.0 !MOVIMIENTOS ACEPTADOS POR MONTECARLO

           End If MONTECARLO2
        End If MONTECARLO1

        !ENERGIA POR PARTICULA
        VN = (V+VLRC)/Real(N)

     End Do Particula

     !GUARDANDO LA TERMALIZACION DE CADA CONFIGURACION DEL SISTEMA
     Write(3,*) IStep, VN

     !AJUSTE DE DESPLAZAMIENTO DRMAX
     Ctrl1 = Mod(IStep, IRatio) == 0
     NdR : If (Ctrl1) Then

        Ratio =  MAcep / Real( N * IRatio  )                      !RAZON DE ACEPTADOS
        Ctrl1A = Ratio .GT. 0.5                                  !CRITERIO DE ACEPTACION DE MOVIMIENTOS

        Criterio : If ( Ctrl1A ) Then
           dRMax = dRMax * 1.05                                   !CRECER DESPLAZAMIENTO
        Else
           dRMax = dRMax * 0.95                                   !DISMINUIR DESPLAZAMIENTO
        End If Criterio

        MAcep = 0.0                                               !REINICIAR CONTADOR DE MOV ACEPTADOS

     End If NdR

     !MONITOREO EN PANTALLA
     Ctrl = Mod(IStep,IPrint) == 0                                !CADA QUE TANTO IMPRIMIR EN PANTALLA ENERGIA, DRMAX
     MonitoreoEne: If(Ctrl) Then

        Write(*,*)  ISTEP, VN, Ratio , dRMax

     End If MonitoreoEne

     !GUARDANDO CONFIGURACION (EN EQUILIBRIO)
     Ctrl2 = ( Mod(IStep,ISave) == 0 ) .AND. ( IStep .GT. CEq )
     SAV: If (Ctrl2) Then
        k2 = k2 + 1
        SAV1:Do k = 1 , N
           CX(k,k2) = X(k)
           CY(k,k2) = Y(k)
        End Do SAV1
     End If SAV

     !Write(*,*) "SAVE CONFIG: ", IStep                            !DEBUG

  End Do Configuracion

  Write(*,*) "DONE ALL CONFIGURATIONS"

  !GUARDAR CONFIG FINAL
  ConfigFin: Do i=1, N

     Write(2,*) X(i), Y(i)

  End Do ConfigFin
  Close (2)
  WRITE(*,*) "DONE SAVING CONFIG FINAL"

  Deallocate( X, Y )
  WRITE(*,*) "CLEAR MEMORY" !DEBUG

  Call GdrCalc
  WRITE(*,*) "GDR DONE CALC" !DEBUG

 ! Deallocate( CX, CY )!, STAT=istat1, ERRMSG = err_msg1 )
  !Write(*,*) istat1, err_msg1 !DEBUG
  Close(3)

  WRITE(*,*) "DONE"

End Program Main


MODULE Lateral_1D_Model

    USE TimeCatcher
    USE FloatPrecision
    USE ArraySize
    USE GRIDS
    USE hydro
    USE Topography
    USE Parameters

    IMPLICIT NONE

    contains

SUBROUTINE Cross_Sectional_Tau(Surface,Discharge)

    IMPLICIT NONE

    REAL(fp) , ALLOCATABLE , POINTER , DIMENSION(:)   :: Surface
    REAL(fp) , ALLOCATABLE , POINTER , DIMENSION(:)   :: Discharge

    INTEGER  , ALLOCATABLE , DIMENSION(:)             :: WetPoints
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:)           :: TTDepthQ
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:)           :: DWFriction
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:)           :: LateralDiff
    REAL(fp) , ALLOCATABLE , DIMENSION(:)             :: Sf
    REAL(fp) , DIMENSION(6,3001)                      :: amt

    INTEGER                                           :: Regrid_Time , NG
    REAL(fp) , parameter                              :: tol = 1.d-6
    REAL(fp)                                          :: CC1, CC2, fff, dc, det
    INTEGER                                           :: i, j, j1, j2, k, jc
    INTEGER                                           :: status
    CHARACTER(len=80)                                 :: err_msg

!   regrid--

    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_Ud
    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_TAU_TD
    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_Upsilon
    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_TTDepthQ
    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_DWFriction
    REAL(fp) , ALLOCATABLE , DIMENSION(:)           :: Re_LateralDiff
    REAL(fp)                                        :: Re_dx , Re_x , xl , xr
    INTEGER                                         :: jj
    INTEGER  , ALLOCATABLE , DIMENSION(:)           :: JSTART , JEND

! ALLOCATE arrays

    ALLOCATE(TTDepthQ(ML:MU,NL:NU),stat=status,errmsg=err_msg)
    ALLOCATE(DWFriction(ML:MU,NL:NU),stat=status,errmsg=err_msg)
    ALLOCATE(LateralDiff(ML:MU,NL:NU),stat=status,errmsg=err_msg)
    ALLOCATE(Sf(ML:MU),stat=status,errmsg=err_msg)
    ALLOCATE(WetPoints(ML:MU),stat=status,errmsg=err_msg)
    ALLOCATE(JSTART(ML:MU),stat=status,errmsg=err_msg)
    ALLOCATE(JEND(ML:MU),stat=status,errmsg=err_msg)

! get the water depth of the cross-section

    DO i = ML , MU-1
        DO j = NL , NU
            !TTDepthQ(i,j) = 0.5D0*(DEP0(i,j) + Surface(i) + DEP0(i+1,j) + Surface(i+1))
            IF(Discharge(i)>=0.D0) THEN
                TTDepthQ(i,j) = DEP0(i,j) + Surface(i)
            !ELSE IF(Discharge(i)<0.D0) THEN
            !    TTDepthQ(i,j) = DEP0(i+1,j) + Surface(i+1)
            ELSE
                TTDepthQ(i,j) = 0.5D0*(DEP0(i,j) + Surface(i) + DEP0(i+1,j) + Surface(i+1))
            !TTDepthQ(i,j) =DEP0(i,j) + Surface(i)
            END IF
        END DO
    END DO

! get the wet points of each cross-section

    DO i = ML , MU-1
        JSTART(i) = NL
        JEND(i) = NU
        WetPoints(i) = 0
        LPJ9: DO j = NL , NU
            IF(TTDepthQ(i,j)>0.D0) THEN
                JSTART(i) = j-1
                JEND(i)  = NL + NU - JSTART(i)
                WetPoints(i) = -JSTART(i) + JEND(i) - 1
                EXIT LPJ9
            END IF
        END DO LPJ9
        IF(JSTART(i)>(NU+NL)/2) THEN
            PAUSE 'error regrid'
        END IF
    END DO

   ! WetPoints(:) = 200
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =
!
!   LPI: Iterate the cross-sectional shear stress...
!
!= = = = = = = = = = = = = = = = = = = = = = = = = = = = =

    LPI:DO i = ML , MU

        TAU_TD(i,:) = 0.D0
        Ud(i,:)  = 0.D0
        gama(i) = 0.D0

! When discharge is zero, shear stress AND velocity are both zero.

        IF(Discharge(i)==0.D0)  THEN
            cycle LPI
        END IF

! = = = = = = = = = =
!
! To determine if re-griding is needed
!
! = = = = = = = = = =

        IF (WetPoints(i)>=19) THEN

! Calculate the friction coefficients

            DO j = NL , NU
                IF(TTDepthQ(i,j)>0.D0) THEN
                    DWFriction(i,j) = manning**2*8.D0*gra*TTDepthQ(i,j)**(-1.D0/3.D0)
                ELSE
                    DWFriction(i,j) = 0.D0
                END IF
            END DO

! Calculate the diffusion term

            DO j = NL , NU-1
                IF(TTDepthQ(i,j)>0.D0.AND.TTDepthQ(i,j+1)>0.D0) THEN
                    fff = manning**2*8.D0*gra*(0.5d0*(TTDepthQ(i,j)+TTDepthQ(i,j+1)))**(-1.D0/3.D0)
                    LateralDiff(i,j) = 0.125D0*Lambda*(TTDepthQ(i,j)+TTDepthQ(i,j+1))**2*sqrt(fff/8.D0)
                ELSE
                    LateralDiff(i,j) = 0.D0
                END IF
            END DO

! initial guess of Sf : Surface slope

            Sf(i) = 0.5d0

!  - - - - - - - - - - - - - - - - - - - - - -
! LPK: the iteration loop
! The upper limit of iteration times is 1000
!- - - - - - - - - - - - - - - - - - - - - - -

            LPK: DO k = 1 , 1000

                jc = 0

! - - - - - - - - - - - - - - - - - - - - - - - -
! LPJ: the loop calculate the transversal distribution
!      of the shear stress AND the velocity
! - - - - - - - - - - - - - - - - - - - - - - - -

                LPJ:DO j = NL , NU

                    j1 = j+1
                    j2 = j-1
                    IF(j==NL) j2 = j
                    IF(j==NU) j1 = j
                    jc = jc + 1

! Dry point

                    IF(TTDepthQ(i,j)<=0) THEN
                        amt(1,jc) = 0.D0
                        amt(2,jc) = 1.D0
                        amt(3,jc) = 0.D0
                        amt(4,jc) = 0.D0
                        cycle LPJ
                    END IF

! Edge points

                    IF(j==NL.OR.j==NU) THEN
                        amt(1,jc) = 0.D0
                        amt(2,jc) = DWFriction(i,j)/8.D0*UPSILON(i,j)
                        amt(3,jc) = 0.D0
                        amt(4,jc) = gra*TTDepthQ(i,j)*dabs(Sf(i))
                        cycle LPJ
                    END IF

! General case, first calculate the diffusion terms

                    CC1 = 1.D0/dx**2*LateralDiff(i,j-1)
                    CC2 = 1.D0/dx**2*LateralDiff(i,j)

! Fill the band matrix

                    amt(1,jc) = - CC2
                    amt(2,jc) = DWFriction(i,j)/8.D0*UPSILON(i,j) + CC1 + CC2
                    amt(3,jc) = - CC1
                    amt(4,jc) = gra*TTDepthQ(i,j)*dabs(Sf(i))

                END DO LPJ

!            IF(iiday==3099) THEN
                !open(111,file='amt1.txt')
                !DO j = 1 , jc
                !    write(111,'(50e25.15)') (amt(jj,j),jj=1,4),DWFriction(i,j)/8.D0,LateralDiff(I,J),UPSILON(i,j)
                !END DO
                !close(111)

!            END IF
                CALL solve3_LU(jc,amt)

    !        IF(i==57.AND.iicdxf==1099) THEN
                !open(111,file='amt2.txt')
                !DO j = 1 , jc
                !    write(111,'(50e25.15)') (amt(jj,j),jj=1,4)
                !END DO
                !close(111)
                !pause 'amt6'
    !        END IF

! get the velocity

                DO j = NL , NU
                    Ud(i,j) = sqrt(amt(4,j))
                    IF(Discharge(i)<0.D0) Ud(i,j) = - Ud(i,j)
                END DO

! estimate the discharge

                dc = 0.D0
                DO j = NL , NU-1
                    dc = dc + 0.25D0*(Ud(i,j)+Ud(i,j+1))*(dmax1(0.D0,TTDepthQ(i,j+1))+dmax1(0.D0,TTDepthQ(i,j)))*dx
                END DO

! compare with the actual discharge

                IF(dabs(dc-Discharge(i)) <= tol) THEN
                    DO j = 1 , jc
                        TAU_TD(i,j) = DWFriction(i,j)/8.D0*Ud(i,j)**2*rhow  !*UPSILON(i,j)
                    END DO

! calculate gama

                    gama(i) = 0.D0
                    DO j = NL , NU-1 , 1
                        IF(DWFriction(i,j)>0.D0.OR.DWFriction(i,j+1)>0.D0) THEN
                            gama(i) = gama(i) &
                                    & + 0.5D0 * (&
                                    &   DWFriction(i,j)/8.D0*Ud(i,j)**2*UPSILON(i,j) &
                                    & + DWFriction(i,j+1)/8.D0*Ud(i,j+1)**2*UPSILON(i,j+1) &
                                    & ) * dx
                        END IF
                    END DO
                    gama(i) = gama(i) / dabs(Discharge(i))

                    cycle LPI
                END IF
                Sf(i) = Sf(i)*(Discharge(i)/dc)**2
            END DO LPK

! error message

            IF(k==1001) THEN
                write(*,*) i , CD
                pause 'error1'
            END IF

! = = = = = = = =
! = = = = = = = =
!
! IF Wet Points is too few ----- Regriding
!
! = = = = = = = =
! = = = = = = = =

        ELSEIF(WetPoints(i)<19) THEN

! calculate multiple times

            Regrid_Time = 21 / (WetPoints(i)+2) + 1

! number of new points

            NG = Regrid_Time*WetPoints(i) + Regrid_Time + 1

! New Grid size

            Re_dx = dx / DBLE(Regrid_Time)

! Allocate arrays

            ALLOCATE(Re_TTDepthQ(1:NG),stat=status,errmsg=err_msg)
            ALLOCATE(Re_DWFriction(1:NG),stat=status,errmsg=err_msg)
            ALLOCATE(Re_LateralDiff(1:NG),stat=status,errmsg=err_msg)
            ALLOCATE(Re_Upsilon(1:NG),stat=status,errmsg=err_msg)
            ALLOCATE(Re_Ud(1:NG),stat=status,errmsg=err_msg)
            ALLOCATE(Re_TAU_TD(1:NG),stat=status,errmsg=err_msg)

! Calculate TTDepthQ after regrid

            DO j = 1 , NG
                Re_x = xx(JSTART(i)) + dble(j-1)*Re_dx
                LPR1:DO jj = JSTART(i) , JEND(i)-1
                    xl = xx(jj)
                    xr = xx(jj+1)
                    IF(Re_x>=xl.and.Re_x<=xr) THEN
                        Re_TTDepthQ(j) = ((Re_x-xl)*TTDepthQ(i,jj+1)+(xr-Re_x)*TTDepthQ(i,jj))/dx
                        Re_Upsilon(j) = ((Re_x-xl)*Upsilon(i,jj+1)+(xr-Re_x)*Upsilon(i,jj))/dx
                        EXIT LPR1
                    END IF
                END DO LPR1
            END DO

! Calculate the friction coefficients after regrid

            DO j = 1 , NG
                IF(Re_TTDepthQ(j)>0.D0) THEN
                    Re_DWFriction(j) = manning**2*8.D0*gra*Re_TTDepthQ(j)**(-1.D0/3.D0)
                ELSE
                    Re_DWFriction(j) = 0.D0
                END IF
            END DO

! Calculate the diffusion term after regrid

            DO j = 1 , NG-1
                IF(Re_TTDepthQ(j)>0.D0.AND.Re_TTDepthQ(j+1)>0.D0) THEN
                    fff = manning**2*8.D0*gra*(0.5d0*(Re_TTDepthQ(j)+Re_TTDepthQ(j+1)))**(-1.D0/3.D0)
                    Re_LateralDiff(j) = 0.125D0*Lambda*(Re_TTDepthQ(j)+Re_TTDepthQ(j+1))**2*sqrt(fff/8.D0)
                ELSE
                    Re_LateralDiff(j) = 0.D0
                END IF
            END DO

! initial guess of Sf : Surface slope

            Sf(i) = 0.5d0

!  - - - - - - - - - - - - - - - - - - - - - -
! LPK: the iteration loop
! The upper limit of iteration times is 1000
!- - - - - - - - - - - - - - - - - - - - - - -

            LPK2: DO k = 1 , 1000

                jc = 0

! - - - - - - - - - - - - - - - - - - - - - - - -
! LPJ: the loop calculate the transversal distribution
!      of the shear stress AND the velocity
! - - - - - - - - - - - - - - - - - - - - - - - -

                LPJ2:DO j = 1 , NG

                    j1 = j+1
                    j2 = j-1
                    IF(j==1) j2 = j
                    IF(j==NG) j1 = j
                    jc = jc + 1

! Dry point

                    IF(Re_TTDepthQ(j)<=0) THEN
                        amt(1,jc) = 0.D0
                        amt(2,jc) = 1.D0
                        amt(3,jc) = 0.D0
                        amt(4,jc) = 0.D0
                        cycle LPJ2
                    END IF

! Edge points

                    IF(j==1.OR.j==NG) THEN
                        write(*,*) cd,i
                        write(*,*) wetpoints(i),NG
                        write(*,*) jstart(i),jend(i)
                        write(*,*) Re_TTDepthQ(1),Re_TTDepthQ(NG)
                        write(*,*) TTDepthQ(i,jstart(i)),TTDepthQ(i,jend(i))
                        pause 'regrid error2'
                    END IF

! General case, first calculate the diffusion terms

                    CC1 = 1.D0/Re_dx**2*Re_LateralDiff(j-1)
                    CC2 = 1.D0/Re_dx**2*Re_LateralDiff(j)

! Fill the band matrix

                    amt(1,jc) = - CC2
                    amt(2,jc) = Re_DWFriction(j)/8.D0*Re_UPSILON(j) + CC1 + CC2
                    amt(3,jc) = - CC1
                    amt(4,jc) = gra*Re_TTDepthQ(j)*dabs(Sf(i))

                END DO LPJ2

!            IF(iiday==3099) THEN
                !open(111,file='amt1.txt')
                !DO j = 1 , jc
                !    write(111,'(50e25.15)') (amt(jj,j),jj=1,4),DWFriction(i,j)/8.D0,LateralDiff(I,J),UPSILON(i,j)
                !END DO
                !close(111)

!            END IF
                CALL solve3_LU(jc,amt)

    !        IF(i==57.AND.iicdxf==1099) THEN
                !open(111,file='amt2.txt')
                !DO j = 1 , jc
                !    write(111,'(50e25.15)') (amt(jj,j),jj=1,4)
                !END DO
                !close(111)
                !pause 'amt6'
    !        END IF

! get the velocity

                DO j = 1 , NG
                    Re_Ud(j) = sqrt(amt(4,j))
                    IF(Discharge(i)<0.D0) Re_Ud(j) = - Re_Ud(j)
                END DO

! estimate the discharge

                dc = 0.D0
                DO j = 1 , NG-1
                    dc = dc + 0.25D0*(Re_Ud(j)+Re_Ud(j+1))*(dmax1(0.D0,Re_TTDepthQ(j+1))+dmax1(0.D0,Re_TTDepthQ(j)))*Re_dx
                END DO

! compare with the actual discharge

                IF(dabs(dc-Discharge(i)) <= tol) THEN

                    DO j = 1 , jc
                        Re_TAU_TD(j) = Re_DWFriction(j)/8.D0*Re_Ud(j)**2*rhow
                    END DO

! fit back to coarse grid

                    jj = JSTART(i) - 1
                    DO j = 1 , NG , Regrid_Time
                        jj = jj + 1
                        Ud(i,jj) = Re_Ud(j)
                        TAU_TD(i,jj) = Re_TAU_TD(j)
                    END DO

! calculate gama

                    gama(i) = 0.D0
                    DO j = 1 , NG-1
                        IF(Re_DWFriction(j)>0.D0.OR.Re_DWFriction(j+1)>0.D0) THEN
                            gama(i) = gama(i) &
                                    & + 0.5D0 * (&
                                    &   Re_DWFriction(j)/8.D0*Re_Ud(j)**2*Re_UPSILON(j) &
                                    & + Re_DWFriction(j+1)/8.D0*Re_Ud(j+1)**2*Re_UPSILON(j+1) &
                                    & ) * Re_dx
                        END IF
                    END DO
                    gama(i) = gama(i) / dabs(Discharge(i))

!DEALLOCATE

                    DEALLOCATE(Re_TTDepthQ,stat=status,errmsg=err_msg)
                    DEALLOCATE(Re_DWFriction,stat=status,errmsg=err_msg)
                    DEALLOCATE(Re_LateralDiff,stat=status,errmsg=err_msg)
                    DEALLOCATE(Re_Upsilon,stat=status,errmsg=err_msg)
                    DEALLOCATE(Re_Ud,stat=status,errmsg=err_msg)
                    DEALLOCATE(Re_TAU_TD,stat=status,errmsg=err_msg)

                    cycle LPI

                END IF

                Sf(i) = Sf(i)*(Discharge(i)/dc)**2

            END DO LPK2

! error message

            IF(k==1001) THEN
                write(*,*) i , CD2
                pause 'LPK error1'
            END IF

        END IF

    END DO LPI

! Coupling the lateral 1d model with the longitudinal model.
! i.e., modify the friction coefficient of the longitudinal
! 1d model to match the intergral bed resistance calculated
! by 1d lateral model.

    !DO i = ML , MU
    !    IF(Discharge(i)==0.D0) THEN
    !        gama(i) = 0.D0
    !    ELSE
    !        gama(i) = 0.D0
    !        DO j = NL , NU-1 , 1
    !            IF(DWFriction(i,j)>0.D0.OR.DWFriction(i,j+1)>0.D0) THEN
    !                gama(i) = gama(i) &
    !                        & + 0.5D0 * (&
    !                        &   DWFriction(i,j)/8.D0*Ud(i,j)**2*UPSILON(i,j) &
    !                        & + DWFriction(i,j+1)/8.D0*Ud(i,j+1)**2*UPSILON(i,j+1) &
    !                        & ) * dx
    !            END IF
    !        END DO
    !        gama(i) = gama(i) / dabs(Discharge(i))
    !    END IF
    !END DO

! DEALLOCATE arrays

    DEALLOCATE(TTDepthQ,stat=status,errmsg=err_msg)
    DEALLOCATE(DWFriction,stat=status,errmsg=err_msg)
    DEALLOCATE(LateralDiff,stat=status,errmsg=err_msg)
    DEALLOCATE(Sf,stat=status,errmsg=err_msg)
    DEALLOCATE(WetPoints,stat=status,errmsg=err_msg)
    DEALLOCATE(JSTART,stat=status,errmsg=err_msg)
    DEALLOCATE(JEND,stat=status,errmsg=err_msg)

END SUBROUTINE Cross_Sectional_Tau

END MODULE Lateral_1D_Model


      subroutine densWr_out(AL,workr_n,kpt_dens,
     & ispin_dens,iw_dens,fdens_out,idens_out)
******************************************
cc     Written by Lin-Wang Wang, March 30, 2001.
*************************************************************************
**  copyright (c) 2003, The Regents of the University of California,
**  through Lawrence Berkeley National Laboratory (subject to receipt of any
**  required approvals from the U.S. Dept. of Energy).  All rights reserved.
*************************************************************************

******************************************

****************************************
***** this subroutine output the charge density.
******************************************

      use fft_data
      use load_data
      use data

      implicit double precision (a-h,o-z)

      include 'mpif.h'
      include 'param.escan_real'
***********************************************
       complex*16 workr_n(mg_nx)
       real*8,allocatable,dimension(:)  ::  temp_rho
       real*8 AL(3,3)
       character*20 fdens_out
       character*25 file_tmp
       integer status(MPI_STATUS_SIZE)
       integer kpt_dens(2),ispin_dens(2),iw_dens(2)
       complex*16 cai
**********************************************
       common /com123b/m1,m2,m3,ngb,nghb,ntype,rrcut,msb

      do 100 ikpt=kpt_dens(1),kpt_dens(2)     ! this sub is called by icolor=0 only

      call gen_G_comp(ikpt,0)
      call fftprep_comp(n1,n2,n3)

      ikpt_100=ikpt/100
      ikpt_10=(ikpt-ikpt_100*100)/10
      ikpt_1=ikpt-ikpt_100*100-ikpt_10*10
      file_tmp=trim(fdens_out)//char(48+ikpt_100)//
     &  char(48+ikpt_10)//char(48+ikpt_1)

      if(inode.eq.1) then
      open(11,file=file_tmp,form="unformatted")
      rewind(11)
      write(11) n1,n2,n3,nnodes,
     &  ispin_dens(1),ispin_dens(2),
     &  iw_dens(1),iw_dens(2)
      write(11) AL
      endif

      cai=dcmplx(0.d0,1.d0)

      do 80 iislda=ispin_dens(1),ispin_dens(2)

      call ugIO(ug_n,ikpt,2,0,iislda)

      do 80 m=iw_dens(1),iw_dens(2)

      call d3fft_comp(ug_n(1,m),workr_n,-1,ikpt)

ccccccc for idens_out=: 12,22, add the cphase,    output phi_k(r)
ccccccc for idens_out=: 11,21, do not add cphase, output u_k(r)
      if(idens_out.eq.12.or.idens_out.eq.22) then
      do ii=1,nr_n
       iit=ii+(inode-1)*nr_n-1
       it=iit/(n3*n2)
       jt=(iit-it*n3*n2)/n3
       kt=iit-it*n3*n2-jt*n3
       xt=AL(1,1)*it/n1+AL(1,2)*jt/n2+AL(1,3)*kt/n3
       yt=AL(2,1)*it/n1+AL(2,2)*jt/n2+AL(2,3)*kt/n3
       zt=AL(3,1)*it/n1+AL(3,2)*jt/n2+AL(3,3)*kt/n3

       workr_n(ii)=workr_n(ii)*cdexp(cai*(
     & xt*akx(ikpt)+yt*aky(ikpt)+zt*akz(ikpt)))
       enddo
       endif

       call mpi_barrier(MPI_COMM_K,ierr)

       if(inode.eq.1) then
       write(11) (dreal(workr_n(j)),j=1,nr_n),
     & (dimag(workr_n(j)),j=1,nr_n)
       endif

       do i=1,nnodes-1
      call mpi_barrier(MPI_COMM_K,ierr)
       if(inode==i+1) then
       call  mpi_send(workr_n,nr_n,MPI_DOUBLE_COMPLEX,0,
     &   100,MPI_COMM_K,ierr)
       endif
       if(inode.eq.1) then
        call mpi_recv(workr_n,nr_n,MPI_DOUBLE_COMPLEX,i,
     &   100,MPI_COMM_K,status,ierr)
       write(11) (dreal(workr_n(j)),j=1,nr_n),
     & (dimag(workr_n(j)),j=1,nr_n)
       endif
       enddo

80    continue
      if(inode.eq.1) close(11)
100   continue

      return
      end


      double precision function compute_slopes(sl,sr)
      implicit none

      double precision sl,sr, sc
      integer mth

c     # Use AMRClaw slopes  (use minimum in absolute value;  sign is
c     # chosen from centered (sc) slope
      sc = (sl + sr)/2.d0
      compute_slopes = min(abs(sl),abs(sr),abs(sc))*
     &      max(0.d0,sign(1.d0,sl*sr))*sign(1.d0,sc)

c     # Do this to guarantee that ghost cells are used; this is a check
c     # on the ghost-fill procedures.  Could raise an exception if face
c     # a patch communicates with more two or more procs.  If this
c     # is uncommented, also uncomment warning in fclaw2d_ghost_fill.cpp
c     compute_slopes = sc

      end


c> \file formk.f

c> \brief Forms the LEL^T factorization of the indefinite matrix K.
c>
c> This subroutine forms the LEL^T factorization of the indefinite matrix
c>
c> K = [-D -Y'ZZ'Y/theta     L_a'-R_z'  ]
c>     [L_a -R_z           theta*S'AA'S ]
c>                                    where E = [-I  0]
c>                                              [ 0  I]
c>
c> The matrix K can be shown to be equal to the matrix M^[-1]N
c>   occurring in section 5.1 of [1], as well as to the matrix
c>   Mbar^[-1] Nbar in section 5.3.
c>
c> @param n On entry n is the dimension of the problem.

c>          On exit n is unchanged.
c>
c> @param nsub On entry nsub is the number of subspace variables in free set.

c>             On exit nsub is not changed.
c>
c> @param ind On entry ind specifies the indices of subspace variables.

c>            On exit ind is unchanged.
c>
c> @param nenter On entry nenter is the number of variables entering the
c>                  free set.

c>               On exit nenter is unchanged.
c>
c> @param ileave On entry indx2(ileave),...,indx2(n) are the variables leaving
c>                  the free set.

c>               On exit ileave is unchanged.
c>
c> @param indx2 On entry indx2(1),...,indx2(nenter) are the variables entering
c>                 the free set, while indx2(ileave),...,indx2(n) are the
c>                 variables leaving the free set.

c>              On exit indx2 is unchanged.
c>
c> @param iupdat On entry iupdat is the total number of BFGS updates made so far.

c>               On exit iupdat is unchanged.
c>
c> @param updatd On entry 'updatd' is true if the L-BFGS matrix is updated.

c>               On exit 'updatd' is unchanged.
c>
c> @param wn On entry wn is unspecified.

c>           On exit the upper triangle of wn stores the LEL^T factorization
c>              of the 2*col x 2*col indefinite matrix
c>                         [-D -Y'ZZ'Y/theta     L_a'-R_z'  ]
c>                         [L_a -R_z           theta*S'AA'S ]
c>
c> @param wn1 On entry wn1 stores the lower triangular part of
c>                          [Y' ZZ'Y   L_a'+R_z']
c>                          [L_a+R_z   S'AA'S   ]
c>               in the previous iteration.

c>            On exit wn1 stores the corresponding updated matrices.

c>            The purpose of wn1 is just to store these inner products
c>            so they can be easily updated and inserted into wn.
c>
c> @param m On entry m is the maximum number of variable metric corrections
c>             used to define the limited memory matrix.

c>          On exit m is unchanged.
c>
c> @param ws On entry this stores S, a set of s-vectors, that defines the
c>              limited memory BFGS matrix.

c>           On exit this array is unchanged.
c>
c> @param wy On entry this stores Y, a set of y-vectors, that defines the
c>              limited memory BFGS matrix.

c>           On exit this array is unchanged.
c>
c> @param sy On entry this stores S'Y, that defines the
c>              limited memory BFGS matrix.

c>           On exit this array is unchanged.
c>
c> @param theta On entry theta is the scaling factor specifying B_0 = theta I.

c>              On exit theta is unchanged.
c>
c> @param col On entry col is the actual number of variable metric
c>               corrections stored so far.

c>            On exit col is unchanged.
c>
c> @param head On entry head is the location of the first s-vector (or y-vector)
c>                in S (or Y).

c>             On exit col is unchanged.
c>
c> @param info On entry info is unspecified.

c>             On exit info

=  0 for normal return;

c>
= -1 when the 1st Cholesky factorization failed;

c>
= -2 when the 2st Cholesky factorization failed.

      subroutine formk(n, nsub, ind, nenter, ileave, indx2, iupdat,
     +                 updatd, wn, wn1, m, ws, wy, sy, theta, col,
     +                 head, info)

      integer          n, nsub, m, col, head, nenter, ileave, iupdat,
     +                 info, ind(n), indx2(n)
      double precision theta, wn(2*m, 2*m), wn1(2*m, 2*m),
     +                 ws(n, m), wy(n, m), sy(m, m)
      logical          updatd
c
c     References:
c       [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
c       memory algorithm for bound constrained optimization'',
c       SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
c
c       [2] C. Zhu, R.H. Byrd, P. Lu, J. Nocedal, ``L-BFGS-B: a
c       limited memory FORTRAN code for solving bound constrained
c       optimization problems'', Tech. Report, NAM-11, EECS Department,
c       Northwestern University, 1994.
c
c       (Postscript files of these papers are available via anonymous
c        ftp to eecs.nwu.edu in the directory pub/lbfgs/lbfgs_bcm.)
c
c                           *  *  *
c
c     NEOS, November 1994. (Latest revision June 1996.)
c     Optimization Technology Center.
c     Argonne National Laboratory and Northwestern University.
c     Written by
c                        Ciyou Zhu
c     in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c     ************

      integer          m2,ipntr,jpntr,iy,is,jy,js,is1,js1,k1,i,k,
     +                 col2,pbegin,pend,dbegin,dend,upcl
      double precision ddot,temp1,temp2,temp3,temp4
      double precision one,zero
      parameter        (one=1.0d0,zero=0.0d0)

c     Form the lower triangular part of
c               WN1 = [Y' ZZ'Y   L_a'+R_z']
c                     [L_a+R_z   S'AA'S   ]
c        where L_a is the strictly lower triangular part of S'AA'Y
c              R_z is the upper triangular part of S'ZZ'Y.

      if (updatd) then
         if (iupdat .gt. m) then
c                                 shift old part of WN1.
            do 10 jy = 1, m - 1
               js = m + jy
               call dcopy(m-jy,wn1(jy+1,jy+1),1,wn1(jy,jy),1)
               call dcopy(m-jy,wn1(js+1,js+1),1,wn1(js,js),1)
               call dcopy(m-1,wn1(m+2,jy+1),1,wn1(m+1,jy),1)
  10        continue
         endif

c          put new rows in blocks (1,1), (2,1) and (2,2).
         pbegin = 1
         pend = nsub
         dbegin = nsub + 1
         dend = n
         iy = col
         is = m + col
         ipntr = head + col - 1
         if (ipntr .gt. m) ipntr = ipntr - m
         jpntr = head
         do 20 jy = 1, col
            js = m + jy
            temp1 = zero
            temp2 = zero
            temp3 = zero
c             compute element jy of row 'col' of Y'ZZ'Y
            do 15 k = pbegin, pend
               k1 = ind(k)
               temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr)
  15        continue
c             compute elements jy of row 'col' of L_a and S'AA'S
            do 16 k = dbegin, dend
               k1 = ind(k)
               temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr)
               temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr)
  16        continue
            wn1(iy,jy) = temp1
            wn1(is,js) = temp2
            wn1(is,jy) = temp3
            jpntr = mod(jpntr,m) + 1
  20     continue

c          put new column in block (2,1).
         jy = col
         jpntr = head + col - 1
         if (jpntr .gt. m) jpntr = jpntr - m
         ipntr = head
         do 30 i = 1, col
            is = m + i
            temp3 = zero
c             compute element i of column 'col' of R_z
            do 25 k = pbegin, pend
               k1 = ind(k)
               temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr)
  25        continue
            ipntr = mod(ipntr,m) + 1
            wn1(is,jy) = temp3
  30     continue
         upcl = col - 1
      else
         upcl = col
      endif

c       modify the old parts in blocks (1,1) and (2,2) due to changes
c       in the set of free variables.
      ipntr = head
      do 45 iy = 1, upcl
         is = m + iy
         jpntr = head
         do 40 jy = 1, iy
            js = m + jy
            temp1 = zero
            temp2 = zero
            temp3 = zero
            temp4 = zero
            do 35 k = 1, nenter
               k1 = indx2(k)
               temp1 = temp1 + wy(k1,ipntr)*wy(k1,jpntr)
               temp2 = temp2 + ws(k1,ipntr)*ws(k1,jpntr)
  35        continue
            do 36 k = ileave, n
               k1 = indx2(k)
               temp3 = temp3 + wy(k1,ipntr)*wy(k1,jpntr)
               temp4 = temp4 + ws(k1,ipntr)*ws(k1,jpntr)
  36        continue
            wn1(iy,jy) = wn1(iy,jy) + temp1 - temp3
            wn1(is,js) = wn1(is,js) - temp2 + temp4
            jpntr = mod(jpntr,m) + 1
  40     continue
         ipntr = mod(ipntr,m) + 1
  45  continue

c       modify the old parts in block (2,1).
      ipntr = head
      do 60 is = m + 1, m + upcl
         jpntr = head
         do 55 jy = 1, upcl
            temp1 = zero
            temp3 = zero
            do 50 k = 1, nenter
               k1 = indx2(k)
               temp1 = temp1 + ws(k1,ipntr)*wy(k1,jpntr)
  50        continue
            do 51 k = ileave, n
               k1 = indx2(k)
               temp3 = temp3 + ws(k1,ipntr)*wy(k1,jpntr)
  51        continue
         if (is .le. jy + m) then
               wn1(is,jy) = wn1(is,jy) + temp1 - temp3
            else
               wn1(is,jy) = wn1(is,jy) - temp1 + temp3
            endif
            jpntr = mod(jpntr,m) + 1
  55     continue
         ipntr = mod(ipntr,m) + 1
  60  continue

c     Form the upper triangle of WN = [D+Y' ZZ'Y/theta   -L_a'+R_z' ]
c                                     [-L_a +R_z        S'AA'S*theta]

      m2 = 2*m
      do 70 iy = 1, col
         is = col + iy
         is1 = m + iy
         do 65 jy = 1, iy
            js = col + jy
            js1 = m + jy
            wn(jy,iy) = wn1(iy,jy)/theta
            wn(js,is) = wn1(is1,js1)*theta
  65     continue
         do 66 jy = 1, iy - 1
            wn(jy,is) = -wn1(is1,jy)
  66     continue
         do 67 jy = iy, col
            wn(jy,is) = wn1(is1,jy)
  67     continue
         wn(iy,iy) = wn(iy,iy) + sy(iy,iy)
  70  continue

c     Form the upper triangle of WN= [  LL'            L^-1(-L_a'+R_z')]
c                                    [(-L_a +R_z)L'^-1   S'AA'S*theta  ]

c        first Cholesky factor (1,1) block of wn to get LL'
c                          with L' stored in the upper triangle of wn.
      !call dpofa(wn,m2,col,info)
      call dpotrf('U',col,wn,m2,info)

      if (info .ne. 0) then
         info = -1
         return
      endif
c        then form L^-1(-L_a'+R_z') in the (1,2) block.
      col2 = 2*col
      do 71 js = col+1 ,col2
         !call dtrsl(wn,m2,col,wn(1,js),11,info)

         ! TODO: can combine this loop into a single dtrsm call?
         call dtrsm('l','u','t','n',col,1,one,wn,m2,wn(1,js),col)
  71  continue

c     Form S'AA'S*theta + (L^-1(-L_a'+R_z'))'L^-1(-L_a'+R_z') in the
c        upper triangle of (2,2) block of wn.

      do 72 is = col+1, col2
         do 74 js = is, col2
               wn(is,js) = wn(is,js) + ddot(col,wn(1,is),1,wn(1,js),1)
  74        continue
  72     continue

c     Cholesky factorization of (2,2) block of wn.

      !call dpofa(wn(col+1,col+1),m2,col,info)
      call dpotrf('U',col,wn(col+1,col+1),m2,info)

      if (info .ne. 0) then
         info = -2
         return
      endif

      return

      end


!
!     CalculiX - A 3-dimensional finite element program
!     Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine e_c3d_u(co,kon,lakonl,p1,p2,omx,bodyfx,nbody,s,sm,
     &     ff,nelem,nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,
     &     alzero,ielmat,ielorien,norien,orab,ntmat_,
     &     t0,t1,ithermal,vold,iperturb,nelemload,
     &     sideload,xload,nload,idist,sti,stx,iexpl,plicon,
     &     nplicon,plkcon,nplkcon,xstiff,npmat_,dtime,
     &     matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme,
     &     ttime,time,istep,iinc,coriolis,xloadold,reltime,
     &     ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold,
     &     ne0,ipkon,thicke,
     &     integerglob,doubleglob,tieset,istartset,iendset,ialset,ntie,
     &     nasym,ielprop,prop)
!
!     computation of the element matrix and rhs for the user element
!     of type u1
!
!     This is a beam type element. Reference:
!     Yunhua Luo, An Efficient 3D Timoshenko Beam Element with
!     Consistent Shape Functions, Adv. Theor. Appl. Mech., Vol. 1,
!     2008, no. 3, 95-106
!
!     special case for which the beam axis goes through the
!     center of gravity of the cross section and the 1-direction
!     corresponds with a principal axis
!
      implicit none
!
      integer mass(*),stiffness,buckling,rhsi,coriolis
!
      character*8 lakonl
      character*20 sideload(*)
      character*80 matname(*),amat
      character*81 tieset(3,*)
!
      integer konl(26),nelemload(2,*),nbody,nelem,mi(*),kon(*),
     &     ielprop(*),null,index,mattyp,ithermal(*),iperturb(*),nload,
     &     idist,
     &     i,j,i1,nmethod,kk,nelcon(2,*),nrhcon(*),nalcon(2,*),
     &     ielmat(mi(3),*),ielorien(mi(3),*),ipkon(*),indexe,
     &     ntmat_,nope,norien,ihyper,iexpl,kode,imat,iorien,istiff,
     &     ncmat_,intscheme,istep,iinc,iflag,ipompc(*),nodempc(3,*),
     &     nmpc,ikmpc(*),ilmpc(*),ne0,ndof,istartset(*),iendset(*),
     &     ialset(*),ntie,integerglob(*),nasym,nplicon(0:ntmat_,*),
     &     nplkcon(0:ntmat_,*),npmat_
!
      real*8 co(3,*),xl(3,26),veold(0:mi(2),*),rho,s(60,60),bodyfx(3),
     &     ff(60),elconloc(21),coords(3),p1(3),elcon(0:ncmat_,ntmat_,*),
     &     p2(3),eth(6),rhcon(0:1,ntmat_,*),reltime,prop(*),
     &     alcon(0:6,ntmat_,*),alzero(*),orab(7,*),t0(*),t1(*),
     &     xloadold(2,*),vold(0:mi(2),*),xload(2,*),omx,e,un,um,tt,
     &     sm(60,60),sti(6,mi(1),*),stx(6,mi(1),*),t0l,t1l,coefmpc(*),
     &     elas(21),thicke(mi(3),*),doubleglob(*),dl,
     &     plicon(0:2*npmat_,ntmat_,*),plkcon(0:2*npmat_,ntmat_,*),
     &     xstiff(27,mi(1),*),plconloc(802),dtime,ttime,time,
     &     a,xi11,xi12,xi22,xk,e1(3),offset1,offset2,y1,y2,y3,z1,z2,z3
!
!
!
      if(lakonl(2:2).eq.'1') then
        call e_c3d_u1(co,kon,lakonl,p1,p2,omx,bodyfx,nbody,s,sm,
     &       ff,nelem,nmethod,elcon,nelcon,rhcon,nrhcon,alcon,nalcon,
     &       alzero,ielmat,ielorien,norien,orab,ntmat_,
     &       t0,t1,ithermal,vold,iperturb,nelemload,
     &       sideload,xload,nload,idist,sti,stx,iexpl,plicon,
     &       nplicon,plkcon,nplkcon,xstiff,npmat_,dtime,
     &       matname,mi,ncmat_,mass,stiffness,buckling,rhsi,intscheme,
     &       ttime,time,istep,iinc,coriolis,xloadold,reltime,
     &       ipompc,nodempc,coefmpc,nmpc,ikmpc,ilmpc,veold,
     &       ne0,ipkon,thicke,integerglob,doubleglob,tieset,istartset,
     &       iendset,ialset,ntie,nasym,ielprop,prop)
      else
        write(*,*) '*ERROR in e_c3d_u.f: user element'
        write(*,*) '       ',lakonl(1:5),' is not defined'
        call exit(201)
      endif
!
      return
      end


!
!  Copyright 2020 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!

# define DX(dt) idx(ix+(dt)),iy,iz
# define DY(dt) ix,idy(iy+(dt)),iz
# define DZ(dt) ix,iy,idz(iz+(dt))

subroutine zstencil_microAc_typical_seq(is_array,ie_array,is,ie,idx,idy,idz,igs,ige &
                                       ,tpsi,htpsi,V_local,Ac,div_Ac,lap0,lapt,nabt,k &
                                       )
  use math_constants,only : zi
  implicit none

  integer,intent(in) :: is_array(3),ie_array(3),is(3),ie(3)
  integer,intent(in) :: idx(is(1)-4:ie(1)+4),idy(is(2)-4:ie(2)+4),idz(is(3)-4:ie(3)+4)
  integer,intent(in) :: igs(3),ige(3)

  complex(8),intent(in)  :: tpsi   (is_array(1):ie_array(1),is_array(2):ie_array(2),is_array(3):ie_array(3))
  complex(8),intent(out) :: htpsi  (is_array(1):ie_array(1),is_array(2):ie_array(2),is_array(3):ie_array(3))
  real(8),   intent(in)  :: V_local(is(1):ie(1),is(2):ie(2),is(3):ie(3))
  real(8),   intent(in)  :: Ac(3,is(1):ie(1),is(2):ie(2),is(3):ie(3))
  real(8),   intent(in)  :: div_Ac(is(1):ie(1),is(2):ie(2),is(3):ie(3))
  real(8),   intent(in)  :: lap0
  real(8),   intent(in)  :: lapt(4,3), nabt(4,3)
  real(8),   intent(in)  :: k(3)

  integer    :: ix,iy,iz
  real(8)    :: kAc(3),div
  complex(8) :: w(3),v,psi0

  do iz=igs(3),ige(3)
  do iy=igs(2),ige(2)
  do ix=igs(1),ige(1)
    psi0 = tpsi(ix,iy,iz)
    kAc = k + Ac(:,ix,iy,iz)
    div = div_Ac(ix,iy,iz)

  ! laplacian of psi
    v =  lapt(1,1)*(tpsi(DX(1)) + tpsi(DX(-1))) &
      & +lapt(2,1)*(tpsi(DX(2)) + tpsi(DX(-2))) &
      & +lapt(3,1)*(tpsi(DX(3)) + tpsi(DX(-3))) &
      & +lapt(4,1)*(tpsi(DX(4)) + tpsi(DX(-4)))

    v =  lapt(1,2)*(tpsi(DY(1)) + tpsi(DY(-1))) &
      & +lapt(2,2)*(tpsi(DY(2)) + tpsi(DY(-2))) &
      & +lapt(3,2)*(tpsi(DY(3)) + tpsi(DY(-3))) &
      & +lapt(4,2)*(tpsi(DY(4)) + tpsi(DY(-4))) + v

    v =  lapt(1,3)*(tpsi(DZ(1)) + tpsi(DZ(-1))) &
      & +lapt(2,3)*(tpsi(DZ(2)) + tpsi(DZ(-2))) &
      & +lapt(3,3)*(tpsi(DZ(3)) + tpsi(DZ(-3))) &
      & +lapt(4,3)*(tpsi(DZ(4)) + tpsi(DZ(-4))) + v

  ! gradient of psi
    w(1) =  nabt(1,1)*(tpsi(DX(1)) - tpsi(DX(-1))) &
         & +nabt(2,1)*(tpsi(DX(2)) - tpsi(DX(-2))) &
         & +nabt(3,1)*(tpsi(DX(3)) - tpsi(DX(-3))) &
         & +nabt(4,1)*(tpsi(DX(4)) - tpsi(DX(-4)))

    w(2) =  nabt(1,2)*(tpsi(DY(1)) - tpsi(DY(-1))) &
         & +nabt(2,2)*(tpsi(DY(2)) - tpsi(DY(-2))) &
         & +nabt(3,2)*(tpsi(DY(3)) - tpsi(DY(-3))) &
         & +nabt(4,2)*(tpsi(DY(4)) - tpsi(DY(-4)))

    w(3) =  nabt(1,3)*(tpsi(DZ(1)) - tpsi(DZ(-1))) &
         & +nabt(2,3)*(tpsi(DZ(2)) - tpsi(DZ(-2))) &
         & +nabt(3,3)*(tpsi(DZ(3)) - tpsi(DZ(-3))) &
         & +nabt(4,3)*(tpsi(DZ(4)) - tpsi(DZ(-4)))

    htpsi(ix,iy,iz) = ( V_local(ix,iy,iz) + lap0 )* psi0 - 0.5d0* v           &
                    & + 0.5d0* ( kAc(1)**2 + kAc(2)**2 + kAc(3)**2 ) * psi0   &
                    & - zi* ( kAc(1) * w(1) + kAc(2) * w(2) + kAc(3) * w(3) ) &
                    & - zi*0.5d0* div * psi0 ! deviation from the Coulomb gauge condition (for numerical stability)
  end do
  end do
  end do
end subroutine


      subroutine depeqs(xu,cdep,a,b,phi,theta,x,depeq)
c
c
c     + + + PURPOSE + + +
c     Solves the deposition equation.
c
c     Called from subroutine DEPOS.
c     Author(s): G. Foster, M. Nearing
c     Reference in User Guide:
c
c     Changes: 1) Put the second parameter at the END of the list,
c                 since it gets MODIFIED.  Made the analogous changes
c                 in DEPOS which calles it.
c              2) Made this FUNCTION DEPEQ into a SUBROUTINE DEPEQS,
c                 since it modifies one of its arguments, and accesses
c                 common blocks.
c              3) PROUTE1.INC de-referenced, since MXPLAN is never used.
c
c     Version: This module recoded from WEPP version 90.92.
c     Date recoded: 01/11/91.
c     Recoded by: Charles R. Meyer.
c
c     + + + KEYWORDS + + +
c
c     + + + ARGUMENT DECLARATIONS + + +
      real xu, cdep, a, b, phi, theta, x, depeq
c
c     + + + ARGUMENT DEFINITIONS + + +
c     xu     - nondimensional distance on an OFE where current
c              deposition region begins
c     cdep   -
c     a      - shear stress coefficient for current slope section
c     b      - shear stress coefficient for current slope section
c     phi    - nondimensional deposition parameter for current OFE
c     theta  - nondimensional interrill detachment parameter for
c              current OFE
c     x      -
c     depeq  -
c
c     + + + COMMON BLOCKS + + +
      include 'cends1.inc'
c       read: ktrato
      include 'cinfco1.inc'
c       read: qostar
c
c     + + + LOCAL VARIABLES + + +
      real ratio, expon, tmpvr1
c     ratio  - temp variable to store parts of the depeq equation
c     expon  - temp variable to store parts of the depeq equation
c
c     + + + SUBROUTINES CALLED + + +
c     undflo
c
c     + + + END SPECIFICATIONS + + +
c
      if (abs(qostar+x).lt.10e-8) x = -qostar - 0.000001
c
      ratio = (xu+qostar) / (x+qostar)
c     if(ratio.gt.1.0) ratio=1.0
      if (qostar.ge.0.0.and.ratio.gt.1.0) ratio = 1.0
c
      expon = 1.0 + phi
      call undflo(ratio,expon)
c
      tmpvr1 = 2.0 * a * ktrato
      depeq = (tmpvr1*phi*(x+qostar)/(2.0+phi)) + (phi/(1.0+phi)) * (b*
     1    ktrato-theta-(tmpvr1*qostar)) + cdep * ratio ** expon
c
      return
      end