! solve the linear advection equation on a finite-volume grid using
! using Godunov's method (piecewise constant), piecewise linear, or
! piecewise parabolc reconstruction.
!
! u_t + a u_x = 0
!
! M. Zingale (2012-02-29)
!
! version 1.01 (2013-03-24):
!
!      bug fix in PLM slope computation -- now gets second-order for u
!      positive or negative, and a bug in the computation of the PPM
!      uminus -- we were missing the leftmost value
!
! To really test this for errors, compile as:
!
!   gfortran -g -O0 -fbacktrace -ffpe-trap=invalid,zero,overflow -finit-real=snan -Wuninitialized -o advect advect.f90
!

program advect

  implicit none

  ! the number of zones (nx) and number of guardcells (ng)
  integer, parameter :: nx = 64
  integer, parameter :: ng = 3

  ! the domain size
  double precision, parameter :: xmin = 0.d0
  double precision, parameter :: xmax = 1.d0

  ! the advection velocity
  double precision, parameter :: a = 1.d0

  ! the CFL number
  double precision, parameter :: cfl = 0.8d0

  ! initial condition type
  integer, parameter :: inittype = 2

  ! slope type (1=godunov, 2=plm, 3=ppm)
  integer, parameter :: islopetype = 3

  integer, parameter :: plmlimiter = 1

  ! maximum simulation time
  double precision, parameter :: tmax = 5.d0

  double precision, dimension(2*ng + nx) :: x
  double precision, dimension(2*ng + nx) :: u, ul, ur, f
  double precision, dimension(2*ng + nx) :: uinit

  double precision :: dx
  double precision :: time, dt

  integer :: imin, imax

  ! setup the grid and set the initial conditions
  call grid(nx, ng, xmin, xmax, dx, x)

  imin = ng+1
  imax = ng+nx

  call init(nx, ng, inittype, x, u)
  uinit = u

  time = 0.d0

  call output(nx, ng, inittype, islopetype, plmlimiter, a, time, x, u)

  ! evolution loop -- construct the interface states, solve the Riemann
  ! problem, and update the solution to the new time level
  do while (time < tmax)

     call fillBC(nx, ng, u)

     call timestep(nx, ng, dx, a, cfl, u, dt)
     if (time + dt > tmax) then
        dt = tmax - time
     endif

     call states(nx, ng, dx, dt, a, islopetype, plmlimiter, u, ul, ur)

     call riemann(nx, ng, a, ul, ur, f)

     call update(nx, ng, dx, dt, u, f)

     time = time + dt

  enddo

  call output(nx, ng, inittype, islopetype, plmlimiter, a, time, x, u)

  print *, 'N, error: ', nx, sqrt(dx*sum((u(imin:imax)-uinit(imin:imax))**2))

end program advect

!============================================================================
! grid: create the grid
!============================================================================
subroutine grid(nx, ng, xmin, xmax, dx, x)

  implicit none

  integer :: nx, ng
  double precision :: xmin, xmax

  double precision :: dx
  double precision, dimension(2*ng+nx) :: x

  integer :: i

  ! create the grid
  dx = (xmax - xmin)/dble(nx)

  do i = 1, 2*ng+nx
     x(i) = (i-ng-0.5d0)*dx + xmin
  enddo

  return
end subroutine grid

!============================================================================
! init: set the initial conditions
!============================================================================
subroutine init(nx, ng, inittype, x, u)

  implicit none

  integer :: nx, ng
  integer :: inittype

  double precision, dimension(2*ng+nx) :: x, u

  integer :: i, imin, imax

  double precision, parameter :: pi = 3.14159d0

  imin = ng+1
  imax = ng+nx

  ! loop over all the zones and set the initial conditions.  To be
  ! consistent with the finite-volume discretization, we should store
  ! the zone averages here, but, to second-order accuracy, it is
  ! sufficient to evaluate the initial conditions at the zone center.

  do i = imin, imax

     if (inittype == 1) then
        ! sin wave
        u(i) = sin(2.d0*pi*x(i))

     else if (inittype == 2) then
        ! square wave
        if (x(i) > 0.333d0 .and. x(i) < 0.666d0) then
           u(i) = 1.d0
        else
           u(i) = 0.d0
        endif

     else if (inittype == 3) then
        ! wave packet
        u(i) = sin(16.d0*pi*x(i))*exp(-36.d0*(x(i)-0.5d0)**2)

     else if (inittype == 4) then
        ! gaussian
        u(i) = exp(-(x(i)-0.5d0)**2/0.1d0**2)

     endif

  enddo

  return
end subroutine init

!============================================================================
! output: write out the solution
!============================================================================
subroutine output(nx, ng, inittype, islopetype, plmlimiter, a, time, x, u)

  implicit none

  integer :: nx, ng

  integer :: inittype, islopetype, plmlimiter

  double precision :: a

  double precision :: time

  double precision, dimension(2*ng+nx) :: x, u

  character (len=4) :: time_string
  character (len=16) :: slope, init, res

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  if (islopetype == 1) then
     slope = "godunov"
  else if (islopetype == 2) then
     if (plmlimiter == 1) then
        slope = "plm+MC"
     else if (plmlimiter == 2) then
        slope = "plm+SBee"
     endif
  else if (islopetype == 3) then
     slope = "ppm"
  endif

  if (inittype == 1) then
     init = "sine"
  else if (inittype == 2) then
     init = "tophat"
  else if (inittype == 3) then
     init = "packet"
  else if (inittype == 4) then
     init = "gaussian"
  endif

  ! open the output file
  write (time_string, '(f4.2)') time
  write (res, '(i8)') nx

  open(unit=10, file="advect-"//trim(slope)//"-"//trim(init)//"-nx="//trim(adjustl(res))//"-t="//time_string, status="unknown")

  write (10,*) "# advection problem: u_t + a u_x = 0"
  write (10,*) "# a = ", a
  write (10,*) "# init = ", inittype
  write (10,*) "# slope type = ", islopetype
  if (islopetype == 2) then
     write (10,*) "# plm limiter = ", plmlimiter
  endif
  write (10,*) "# time = ", time

  do i = imin, imax
     write (10,*) x(i), u(i)
  enddo

  return
end subroutine output

!============================================================================
! fillBC: fill the boundary conditions
!============================================================================
subroutine fillBC(nx, ng, u)

  implicit none

  integer :: nx, ng
  double precision, dimension(2*ng+nx) :: u

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  ! left boundary
  do i = 1, imin-1
     u(i) = u(imax-ng+i)
  enddo

  ! right boundary
  do i = imax+1, 2*ng+nx
     u(i) = u(i-imax+ng)
  enddo

  return
end subroutine fillBC

!============================================================================
! timestep: compute the new timestep
!============================================================================
subroutine timestep(nx, ng, dx, a, cfl, u, dt)

  implicit none

  integer :: nx, ng
  double precision :: dx
  double precision :: a, cfl
  double precision, dimension(2*ng+nx) :: u
  double precision :: dt

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  ! in the linear advection equation, the timestep is trivial
  dt = cfl*dx/abs(a)

  return
end subroutine timestep

!============================================================================
! states: compute the interface states used in solving the Riemann problem
!============================================================================
subroutine states(nx, ng, dx, dt, a, islopetype, plmlimiter, u, ul, ur)

  implicit none

  integer :: nx, ng
  integer :: islopetype, plmlimiter

  double precision, dimension(2*ng+nx) :: u, ul, ur
  double precision, dimension(2*ng+nx) :: slope

  double precision, dimension(2*ng+nx) :: uminus, uplus
  double precision :: du0, dup
  double precision :: slope1, slope2

  double precision :: a
  double precision :: dx, dt

  double precision :: minmod, maxmod

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  ! compute the centered difference for linear slopes
  if (islopetype == 1) then

     ! Godunov's method (piecewise constant)

     ! for each interface, we want to construct the left and right
     ! states.  Here, interface i refers to the left edge of zone i

     ! interfaces imin to imax+1 affect the data in zones [imin,imax]
     do i = imin, imax+1

        ! the left state on the current interface comes from zone i-1.
        ul(i) = u(i-1)

        ! the right state on the current interface comes from zone i
        ur(i) = u(i)

     enddo

  else if (islopetype == 2) then

     if (plmlimiter == 1) then
        ! PLM with MC limiter

        ! interface states are found by Taylor expansion in time
        ! (through dt/2) and space (dx/2 toward the interface)

        ! for each interface, we want to construct the left and right
        ! states.  Here, interface i refers to the left edge of zone i

        do i = imin-1, imax+1

           slope(i) = minmod(minmod(2.d0*(u(i) - u(i-1))/dx, &
                                    2.d0*(u(i+1) - u(i))/dx), &
                             0.5d0*(u(i+1) - u(i-1))/dx)

        enddo

     else if (plmlimiter == 2) then
        ! PLM with SuperBee limiter

        do i = imin-1, imax+1
           slope1 = minmod((u(i+1) - u(i))/dx, &
                            2.d0*(u(i) - u(i-1))/dx)

           slope2 = minmod(2.d0*(u(i+1) - u(i))/dx, &
                          (u(i) - u(i-1))/dx)

           slope(i) = maxmod(slope1, slope2)
        enddo

     endif

     ! interfaces imin to imax+1 affect the data in zones [imin,imax]
     do i = imin, imax+1

        ! the left state on the current interface comes from zone i-1.
        ul(i) = u(i-1) + 0.5*dx*(1.d0 - a*(dt/dx))*slope(i-1)

        ! the right state on the current interface comes from zone i
        ur(i) = u(i) - 0.5*dx*(1.d0 + a*(dt/dx))*slope(i)

     enddo

  else if (islopetype == 3) then

     ! PPM

     ! refer to the PPM paper for equation references

     ! use a cubic interpolation polynomial to find the edge states in
     ! zone i -- uminus(i) and uplus(i).  Here we loop over
     ! interfaces.
     do i = imin-2, imax+1

        ! du (C&W Eq. 1.7)
        du0 = 0.5*(u(i+1) - u(i-1))
        dup = 0.5*(u(i+2) - u(i))

        ! limiting (C&W Eq. 1.8)
        if ((u(i+1) - u(i))*(u(i) - u(i-1)) > 0) then
           du0 = sign(1.0d0,du0)*min(abs(du0), 2.0*abs(u(i) - u(i-1)), &
                                               2.0*abs(u(i+1) - u(i)))
        else
           du0 = 0.0
        endif

        if ((u(i+2) - u(i+1))*(u(i+1) - u(i)) > 0) then
           dup = sign(1.0d0,dup)*min(abs(dup), 2.0*abs(u(i+1) - u(i)), &
                                               2.0*abs(u(i+2) - u(i+1)))
        else
           dup = 0.0
        endif

        ! cubic (C&W Eq. 1.6)
        uplus(i) = 0.5*(u(i) + u(i+1)) - (1.0/6.0)*(dup - du0)
        uminus(i+1) = uplus(i)

     enddo

     ! now limit (C&W 1.10).  Here the loop is over cells, and
     ! considers the values on either side of the center of the cell
     ! (uminus and uplus)
     do i = imin-1, imax+1
        if ( (uplus(i) - u(i))*(u(i) - uminus(i)) <= 0.0) then
           uminus(i) = u(i)
           uplus(i) = u(i)

        else if ( (uplus(i) - uminus(i))*(u(i) - 0.5*(uminus(i) + uplus(i))) > &
                  (uplus(i) - uminus(i))**2/6.0 ) then
           uminus(i) = 3.0*u(i) - 2.0*uplus(i)

        else if ( -(uplus(i) - uminus(i))**2/6.0 > &
                   (uplus(i) - uminus(i))*(u(i) - 0.5*(uminus(i) + uplus(i))) ) then
           uplus(i) = 3.0*u(i) - 2.0*uminus(i)

        endif

     enddo

     ! finally integrate under the parabola (C&W Eq. 1.12), away from
     ! the interface.  Here the loop is over interfaces.  ul and ur are
     ! the left and right states at the interface.
     do i = imin, imax+1

        ul(i) = uplus(i-1) - 0.5*a*(dt/dx)*( (uplus(i-1) - uminus(i-1)) - &
             (1.0 - (2.0/3.0)*a*(dt/dx))*6.0*(u(i-1) - 0.5*(uminus(i-1) + uplus(i-1))) )

        ur(i) = uminus(i) + 0.5*a*(dt/dx)*( (uplus(i) - uminus(i)) + &
             (1.0 - (2.0/3.0)*a*(dt/dx))*6.0*(u(i) - 0.5*(uminus(i) + uplus(i))) )

     enddo

  endif

  return
end subroutine states

!============================================================================
! riemann: solve the Riemann problem
!============================================================================
subroutine riemann(nx, ng, a, ul, ur, f)

  implicit none

  integer :: nx, ng
  double precision, dimension(2*ng+nx) :: ul, ur, f

  double precision :: a

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  ! loop over all the interfaces and solve the Riemann problem.  Here,
  ! since we are doing the linear advection eq, we just use the advection
  ! velocity to tell us which direction is upwind, and use that state

  if (a >= 0.d0) then
     do i = imin, imax+1
        f(i) = a*ul(i)
     enddo

  else
     do i = imin, imax+1
        f(i) = a*ur(i)
     enddo

  endif

  return
end subroutine riemann

!============================================================================
! update: conservatively update the solution to the new time level
!============================================================================
subroutine update(nx, ng, dx, dt, u, f)

  implicit none

  integer :: nx, ng

  double precision :: dx, dt

  double precision, dimension(2*ng+nx) :: u, f

  integer :: i, imin, imax

  imin = ng+1
  imax = ng+nx

  do i = imin, imax
     u(i) = u(i) + (dt/dx)*(f(i) - f(i+1))
  enddo

  return
end subroutine update

!============================================================================
! various limiter functions
!============================================================================
function minmod(a,b)

  implicit none

  double precision :: a, b
  double precision :: minmod

  if (abs(a) < abs(b) .and. a*b > 0.d0) then
     minmod = a
  else if (abs(b) < abs(a) .and. a*b > 0) then
     minmod = b
  else
     minmod = 0.d0
  endif

  return
end function minmod

function maxmod(a,b)

  implicit none

  double precision :: a, b
  double precision :: maxmod

  if (abs(a) > abs(b) .and. a*b > 0.d0) then
     maxmod = a
  else if (abs(b) > abs(a) .and. a*b > 0) then
     maxmod = b
  else
     maxmod = 0.d0
  endif

  return
end function maxmod


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
cc                                                                    cc
cc                 mnspin : splint test program                       cc
cc                                                                    cc
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      real t(20),c(20),wrk(20)
      integer i,j,k,k1,n,nk1,ier
      real a,aint,ak,b,exint,splint
c  as an example we calculate some integrals of the form
c          / b
c         !     (1-x)**k  dx
c      a /
c
c  main loop for the different spline degrees.
      do 30 k=1,5
        k1 = k+1
        ak = k1
c  find the b-spline representation of the polynomial (1-x)**k.
        n = 2*k1
        j = n
        do 10 i=1,k1
          c(i) = 0.
          t(i) = 0.
          t(j) = 0.1e+01
          j = j-1
  10    continue
        c(1) = 0.1e+01
c  insert a number of knots
        call insert(0,t,n,c,k,0.8e0,t,n,c,20,ier)
        call insert(0,t,n,c,k,0.4e0,t,n,c,20,ier)
        call insert(0,t,n,c,k,0.3e0,t,n,c,20,ier)
        call insert(0,t,n,c,k,0.1e0,t,n,c,20,ier)
c  print the data for the spline.
        write(6,900) k
        write(6,905)
        write(6,910) (t(i),i=1,n)
        nk1 = n-k1
        write(6,915)
        write(6,920) (c(i),i=1,nk1)
c  loop for the different integration limits a and b.
        a = 0.
        b = 0.1e+01
        write(6,925)
        do 20 j=1,4
c  calculate the value of the spline integral
          aint = splint(t,n,c,k,a,b,wrk)
c  calculate the exact value of the integral
          exint = ((0.1e01-a)**k1-(0.1e01-b)**k1)/ak
          write(6,930) a,b,aint,exint
          a = a+0.1e0
          b = b-0.3e0
  20    continue
  30  continue
      stop
c  format statements.
 900  format(25h0degree of the spline k =,i2)
 905  format(1x,21hposition of the knots)
 910  format(5x,15f5.1)
 915  format(1x,21hb-spline coefficients)
 920  format(5x,8f9.5)
 925  format(1h0,5x,1ha,6x,1hb,6x,6hsplint,7x,5hexint)
 930  format(1x,2f7.1,2f12.5)
      end


!file: coord_desc_iter_p.f90
subroutine coord_desc_iter_p(prec, corr, latent, weight_p, & !output
                             observation_p, & !inputs :: data
                             lambda_ridge_p, lambda_glasso_p, & !inputs :: parameters
                             p, pop_dep, pop_indep, &
                             dim_pop, num_pop_dep, num_pop_indep, & !inputs :: p-wise
                             num_pop, num_trial) !inputs :: dimension
    implicit none

    ! inputs
    integer, intent(in) :: p, dim_pop, num_pop, num_trial
    integer, intent(in) :: num_pop_dep, num_pop_indep
    integer, dimension(num_pop_dep), intent(in) :: pop_dep
    integer, dimension(num_pop_indep), intent(in) :: pop_indep
    real(8) :: lambda_ridge_p
    real(8), dimension(num_pop_dep), intent(in) :: lambda_glasso_p
    real(8), dimension(dim_pop, num_trial), intent(in) :: observation_p

    ! in-outputs
    real(8), dimension(num_pop, num_pop) :: prec, corr
    real(8), dimension(num_pop, num_trial) :: latent
    real(8), dimension(dim_pop) :: weight_p

!f2py intent(inplace) prec
!f2py intent(inplace) corr
!f2py intent(inplace) latent
!f2py intent(inplace) weightp

    ! local variables
    integer :: i, info
    integer, dimension(num_pop_indep) :: ipiv_indep
    real(8), dimension(num_pop_indep) :: work_indep
    real(8), dimension(num_pop_indep, num_pop_indep) :: cinv_prec_indep

    integer, dimension(num_pop_dep) :: ipiv_dep
    real(8), dimension(num_pop_dep) :: work_dep
    real(8), dimension(num_pop_dep, num_pop_dep) :: inv_prec_dep

    real(8), dimension(num_pop_dep) :: prec_p_dep, corr_p_dep

    integer, dimension(dim_pop) :: ipiv_p
    real(8), dimension(dim_pop) :: obs_p_mean, work_p, weight_p_old
    real(8), dimension(dim_pop, dim_pop) :: cov_p, inv_cov_p
    real(8), dimension(num_pop_dep) :: latent_dep_mean
    real(8), dimension(dim_pop, num_pop_dep) :: cov_p_dep

    integer, dimension(num_pop-1) :: pop_notp
    real(8) :: latent_p_mean
    real(8), dimension(num_pop-1) :: latent_notp_mean

    external DGETRF
    external DGETRI

    ! update precision matrix
    if (num_pop_dep == 0) then
        prec(p,p) = 1
        prec(p,pop_indep) = 0
        prec(pop_indep,p) = 0
    else
        if (num_pop_indep == 0) then
            inv_prec_dep = prec(pop_dep, pop_dep)
        else
            cinv_prec_indep = prec(pop_indep, pop_indep)

            call DGETRF(num_pop_indep, num_pop_indep, cinv_prec_indep, num_pop_indep, &
                        ipiv_indep, info)

            if (info /= 0) then
                stop 'Conditional precision is numerically singular!'
            end if

            call DGETRI(num_pop_indep, cinv_prec_indep, num_pop_indep, ipiv_indep, &
                        work_indep, num_pop_indep, info)

            if (info /= 0) then
                stop 'Conditional precision inversion failed!'
            end if

            inv_prec_dep = prec(pop_dep, pop_dep) - &
            matmul(prec(pop_dep, pop_indep), &
                   matmul(cinv_prec_indep, prec(pop_indep, pop_dep)))
        end if

        call DGETRF(num_pop_dep, num_pop_dep, inv_prec_dep, num_pop_dep, &
                    ipiv_dep, info)

        if (info /= 0) then
            stop 'Precision is numerically singular!'
        end if

        call DGETRI(num_pop_dep, inv_prec_dep, num_pop_dep, ipiv_dep, work_dep, &
                    num_pop_dep, info)

        if (info /= 0) then
            stop 'Precision inversion failed!'
        end if

        prec_p_dep = prec(p, pop_dep)
        corr_p_dep = corr(p, pop_dep)

        do i = 1, num_pop_dep
            prec_p_dep(i) = - corr_p_dep(i) - &
                dot_product(inv_prec_dep(i,:i-1), prec_p_dep(:i-1)) - &
                dot_product(inv_prec_dep(i,i+1:), prec_p_dep(i+1:))
            prec_p_dep(i) = sign(max(abs(prec_p_dep(i))-lambda_glasso_p(i), 0.0) / &
                                 inv_prec_dep(i,i), &
                                 prec_p_dep(i))
        end do

        prec(p,p) = 1 + dot_product(prec_p_dep, &
                        sum(inv_prec_dep * spread(prec_p_dep, 1, num_pop_dep), dim = 2))
        prec(p,pop_dep) = prec_p_dep
        prec(pop_dep,p) = prec_p_dep
        prec(p,pop_indep) = 0
        prec(pop_indep,p) = 0
    end if

    ! update weight
    weight_p_old = weight_p

    obs_p_mean = sum(observation_p, dim = 2) / num_trial
    cov_p = matmul(observation_p, transpose(observation_p)) / num_trial - &
            matmul(reshape(obs_p_mean, (/dim_pop,1/)), reshape(obs_p_mean, (/1,dim_pop/)))
    do i = 1, dim_pop
        cov_p(i,i) = cov_p(i,i) + lambda_ridge_p
    end do

    latent_dep_mean = sum(latent(pop_dep,:), dim = 2) / num_trial
    cov_p_dep = matmul(observation_p, transpose(latent(pop_dep,:))) / num_trial - &
    matmul(reshape(obs_p_mean, (/dim_pop,1/)), reshape(latent_dep_mean, (/1,num_pop_dep/)))

    inv_cov_p = cov_p

    call DGETRF(dim_pop, dim_pop, inv_cov_p, dim_pop, ipiv_p, info)

    if (info /= 0) then
        stop 'Covariance is numerically singular!'
    end if

    call DGETRI(dim_pop, inv_cov_p, dim_pop, ipiv_p, work_p, dim_pop, info)

    if (info /= 0) then
        stop 'Covariance inversion failed!'
    end if

    weight_p = reshape(matmul(inv_cov_p, &
        matmul(cov_p_dep, reshape(prec_p_dep ,(/num_pop_dep,1/)))),(/dim_pop/))

    if (dot_product(weight_p, weight_p) == 0) then
        weight_p = weight_p_old
    else
        weight_p = - weight_p / sqrt( &
        dot_product(weight_p, sum(cov_p * spread(weight_p, 1, dim_pop), dim = 2)))
    end if

    ! update latent
    latent(p,:) = sum(observation_p * spread(weight_p, 2, num_trial), dim = 1)

    ! update correlation
    latent_p_mean = sum(latent(p,:)) / num_trial
    pop_notp = pack((/(i,i=1,num_pop)/), (/(i,i=1,num_pop)/) /= p)
    latent_notp_mean = sum(latent(pop_notp,:), dim=2) / num_trial

    corr(p,pop_notp) = sum(latent(pop_notp,:) * &
        spread(latent(p,:), 1, num_pop-1), dim = 2) / num_trial - &
        latent_p_mean * latent_notp_mean
    corr(pop_notp,p) = corr(p,pop_notp)

end subroutine coord_desc_iter_p


*----------------------------------------------------------------------*
!>    returns the nroot eigenvectors of a davidson subspace
!!
!!    @param[in] dvdsbsp davidson subspace
!!    @param[out] vecs(ndim:nroot) eigenvectors
!!    @param[out] eigr(nroot) real part of eigenvalues
!!    @param[out] eigi(nroot) imaginary part of eigenvalues
!!    @param[in] nroot number or requested eigenvectors
!!    @param[in] ndim dimension of the eigenvectors has to be identical to the dimension of the subspace
*----------------------------------------------------------------------*
      subroutine dvdsbsp_get_eigenvec(dvdsbsp, vecs, eigr, eigi, nroot,
     &     ndim)
*----------------------------------------------------------------------*
      implicit none
      include 'stdunit.h'
      include 'mdef_me_list.h'
      include 'def_file_array.h'
      include 'def_davidson_subspace.h'

      integer, parameter::
     &     ntest = 000
      character(len=*),parameter::
     &     i_am="dvdsbsp_get_eigenvec"

      type(davidson_subspace_t),intent(inout)::
     &     dvdsbsp

      integer,intent(in)::
     &     nroot, ndim

      real(8),intent(inout)::
     &     eigr(nroot), eigi(nroot), vecs(ndim,nroot)

      real(8),allocatable::
     &     xmat(:),           !submatrix only
     &     xscr(:),             !scratch
     &     totvecs(:,:),        ! all eigenvectors
     &     toteigr(:),toteigi(:) ! all eigenvalues

      integer::
     &     maxdim,
     &     ii

      integer::
     &     ierr

      if (ntest.ge.100) then
         call write_title(lulog,wst_dbg_subr,i_am)
         write(lulog,*) "eigenvectors for ",nroot,"roots requested"
         write(lulog,*)  ndim," dimensions available"
      end if
      if(dvdsbsp%ncursub.ne.ndim) call quit(1,i_am,
     &     "requested dimension inconsistent with subspace.")

      allocate(xmat(ndim*ndim),xscr(ndim*ndim),totvecs(ndim,ndim),
     &     toteigr(ndim),toteigi(ndim) )

      maxdim=dvdsbsp%nmaxsub
      if (.not.dvdsbsp%with_metric)then
!      if(.True.)then
         if (ndim .eq. maxdim)then
            call eigen_asym(ndim, dvdsbsp%vMv_mat, toteigr, toteigi,
     &           totvecs, xscr, ierr)
         else
            call extract_submatrix(dvdsbsp%vMv_mat,  maxdim,  xmat,ndim) !vMv_mat -> xmat
            call eigen_asym(ndim, xmat, toteigr, toteigi,
     &           totvecs, xscr, ierr)
         end if
      else !with metric
         if (ndim .eq. maxdim)then
            call eigen_asym_met(ndim, dvdsbsp%vMv_mat, dvdsbsp%vSv_mat,
     &           toteigr, toteigi,
     &           totvecs, xscr, ierr)
         else
            call extract_submatrix(dvdsbsp%vMv_mat,  maxdim,  xmat,ndim) !vMv_mat -> xmat
            call extract_submatrix(dvdsbsp%vSv_mat,  maxdim,  xscr,ndim) !vSv_mat -> xscr
            call eigen_asym_met(ndim, xmat, xscr, toteigr, toteigi,
     &           totvecs, xscr, ierr) !xscr =vSv_matrix and scratch

         end if
      end if

      eigi=toteigi(1:nroot)
      eigr=toteigr(1:nroot)
!      do ii=1,nroot
!         if (eigi(ii).gt.0) call quit(2,i_am,
!     &        "imaginary eigenvalue detected")
!      end do

      if(ntest.ge.100)then
         write (lulog,*) "eigenvalues"
         do ii=1,ndim
            write (lulog,*)  toteigr(ii), toteigi(ii)
         end do
      end if
      do ii=1,nroot
        vecs(1:ndim,ii)=totvecs(1:ndim,ii)
      end do

      deallocate(xmat,xscr,totvecs,
     &     toteigr,toteigi)
      return
      contains

*----------------------------------------------------------------------*
!>   extracts th upper left  submatrix  of mat_in to mat_out
!!
!!   @param mat_in a nmat_in x nmat_in matrix
!!   @param nmat_in dimension of mat_in
!!   @param mat_out extracted nmat_out x nmat_out matrix
!!   @param nmat_out dimension of mat_out
*----------------------------------------------------------------------*
      subroutine extract_submatrix(mat_in,  nmat_in, mat_out, nmat_out)
*----------------------------------------------------------------------*
      implicit none
      character(len=*),parameter::
     &     i_am="extract_submatrix"
      integer,parameter::
     &     ntest=00

      integer,intent(in)::
     &     nmat_in,                !> actual dimension of matrix
     &     nmat_out                 !> dimension of filled part

      real(8),dimension(:),intent(in)::
     &     mat_in
      real(8),dimension(:),intent(out)::
     &     mat_out

      integer::
     &     kdx, idx, jdx

      if (ntest.ge.100)
     &     call write_title(lulog,wst_dbg_subr,i_am)

      do idx=1,nmat_out
         do jdx=1,nmat_out
            mat_out(nmat_out*(idx-1) + jdx)
     &           =mat_in(nmat_in*(idx-1) + jdx)
         end do
      end do
      return
      end subroutine

      end subroutine


      FUNCTION VRG1(IP,IG)
C     'VRG1' IS A FUNCTION WHICH EVALUATES THE RELATIVE GRAVITATIONAL
C     POTENTIAL FOR THE SATELLITE.
C
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8 IP,IG(3,3),IPRMG,J2,J3,J4,J22
C
      COMMON/CNBODY/ J2,J3,J4,J22,ZJ20,ZMU,WWO,FLAT,AEARTH
C
      COMMON/DEBUG3/ ISWTCH
C
      COMMON/VECTRS/ XSAT(3),XSATDT(3),AD(3)
C
      DIMENSION XS(3),XIG(3)
C
      RAD=0.0D0
      DO 10 I=1,3
   10 RAD=RAD + XSAT(I)*XSAT(I)
      X3RAD=XSAT(3)*XSAT(3)/RAD
      RAD=DSQRT(RAD)
C
      DO 20 I=1,3
   20 XS(I)=XSAT(I)/RAD
C
      XSIG=0.0D0
      DO 30 I=1,3
   30 XSIG=XSIG + XS(I)*IG(I,3)
C
      DO 40 I=1,3
      XIG(I)=0.0D0
      DO 40 J=1,3
   40 XIG(I)=XIG(I) + XS(J)*IG(J,I)
C
      IPRMG=0.0D0
      DO 50 I=1,3
   50 IPRMG=IPRMG + XIG(I)*XS(I)
C
      RADSQR=RAD*RAD
      RADCBE=RAD*RADSQR
      ASQR=AEARTH*AEARTH
C
      Z2O=ZJ20*ASQR/RADSQR
      ZM3=ZMU/RADCBE
C
      VRG1=ZM3/2.D0*IP*(1.D0 + 1.5D0*Z2O - 7.5D0*Z2O*X3RAD)
     .    -1.5D0*ZM3*IPRMG*(1.D0 + 2.5D0*Z2O - 17.5D0*Z2O*X3RAD)
     .    +1.5D0*ZM3*Z2O*IG(3,3) - 1.5D1*ZM3*Z2O*XS(3)*XSIG
C
      IF(ISWTCH.NE.0) RETURN
      WRITE(6,10000) X3RAD,RAD,IPRMG,RADSQR,RADCBE,ASQR,Z2O,ZM3,XSIG
      WRITE(6,10001)
      WRITE(6,10002) (XS(I),I=1,3)
       WRITE(6,10003)
      WRITE(6,10002) (XIG(I),I=1,3)
      RETURN
C
10000 FORMAT('0',3X,'X3RAD ',G20.13,2X,'RAD ',G20.13,2X,'IPRMG ',G20.13/
     .           3X,'RADSQR ',G20.13,2X,'RADCBE ',G20.13,2X,'ASQR ',
     .           G20.13,2X/3X,'Z2O ',G20.13,2X,'ZM3 ',G20.13,2X,'XSIG ',
     .           G20.13)
10001 FORMAT('0',3X,'XS')
10002 FORMAT('0',3X,3(G20.13,2X))
10003 FORMAT('0',3X,'XIG')
C
      END


SUBROUTINE SFHSTAT(pos,model,ssfr6,ssfr7,ssfr8,ave_age)

  !compute basic statistics given a parameterized star formation history.
  !required inputs are the parameter set and a single element output
  !structure from compsp

  USE sps_vars
  IMPLICIT NONE

  TYPE(PARAMS), INTENT(in)    :: pos
  TYPE(COMPSPOUT), INTENT(in) :: model
  REAL(SP), INTENT(inout)     :: ssfr6,ssfr7,ssfr8,ave_age
  REAL(SP) :: dt

  !---------------------------------------------------------------!
  !---------------------------------------------------------------!

  dt = 10**model%age/1E9 - pos%sf_start

  IF (dt.LT.0.) THEN
     WRITE(*,*) 'SFHSTAT ERROR: dt<0.0, stopping....'
     STOP
  ENDIF

  !compute mass-weighted stellar age of tau component
  IF (pos%sfh.EQ.1) THEN
     ave_age = pos%tau*(1.-EXP(-dt/pos%tau)*(dt/pos%tau+1.))/&
          (1.-EXP(-dt/pos%tau))
     ssfr6 = (EXP(-(dt-1E-3)/pos%tau)-EXP(-dt/pos%tau))/(1.-EXP(-dt/pos%tau))
     ssfr7 = (EXP(-(dt-1E-2)/pos%tau)-EXP(-dt/pos%tau))/(1.-EXP(-dt/pos%tau))
     ssfr8 = (EXP(-(dt-1E-1)/pos%tau)-EXP(-dt/pos%tau))/(1.-EXP(-dt/pos%tau))
  ELSE IF (pos%sfh.EQ.4) THEN
     ave_age = (2.-EXP(-dt/pos%tau)*(dt/pos%tau*(dt/pos%tau+2.)+2.))*&
          pos%tau/(1.-EXP(-dt/pos%tau)*(dt/pos%tau+1))
     ssfr6 = (EXP(-(dt-1E-3)/pos%tau)*((dt-1E-3)/pos%tau)-&
          EXP(-dt/pos%tau)*(dt/pos%tau))/&
          (1.-EXP(-dt/pos%tau)*(dt/pos%tau+1))
     ssfr7 = (EXP(-(dt-1E-2)/pos%tau)*((dt-1E-2)/pos%tau)-&
          EXP(-dt/pos%tau)*(dt/pos%tau))/&
          (1.-EXP(-dt/pos%tau)*(dt/pos%tau+1))
     ssfr8 = (EXP(-(dt-1E-1)/pos%tau)*((dt-1E-1)/pos%tau)-&
          EXP(-dt/pos%tau)*(dt/pos%tau))/&
          (1.-EXP(-dt/pos%tau)*(dt/pos%tau+1))
  ELSE
     WRITE(*,*) 'SFHSTAT ERROR: you should not be calling sfhstat '//&
          'for sfh types NE 1 or 4, stopping....'
     STOP
  ENDIF

  !add constant component
  ave_age = ave_age*(1.-pos%const) + pos%const*dt/2.
  ssfr6   = ssfr6  *(1.-pos%const) + pos%const*1E-3/dt
  ssfr7   = ssfr7  *(1.-pos%const) + pos%const*1E-2/dt
  ssfr8   = ssfr8  *(1.-pos%const) + pos%const*1E-1/dt

  !convert to lookback time
  ave_age = dt - ave_age

  !only add the burst if the burst has happened
  IF (10**model%age/1E9.GT.pos%tburst) &
       ave_age = (1.-pos%fburst)*ave_age + pos%fburst*pos%tburst
  IF (dt-pos%tburst.LE.1E-3) ssfr6 = ssfr6 + pos%fburst
  IF (dt-pos%tburst.LE.1E-2) ssfr7 = ssfr7 + pos%fburst
  IF (dt-pos%tburst.LE.1E-1) ssfr8 = ssfr8 + pos%fburst

  !convert from integral(SFR) to log(<SSFR>), in 1/Gyr
  ssfr6 = LOG10(MAX(ssfr6/model%mass_csp/1E-3,tiny_number))
  ssfr7 = LOG10(MAX(ssfr7/model%mass_csp/1E-2,tiny_number))
  ssfr8 = LOG10(MAX(ssfr8/model%mass_csp/1E-1,tiny_number))

END SUBROUTINE SFHSTAT


!======================================================================
!
! !IROUTINE: WETBULBCALC -- Calculate wet bulb temperature (C)
!
! !DESCRIPTION:
!
!   Calculates wet bulb temperature in C, given pressure in
!      temperature in K and mixing ratio in kg/kg.
!
! !INPUT:
!    nx     - index for x dimension
!    ny     - index for y dimension
!    nz     - index for z dimension
!    prs    - pressure (mb)
!    tmk    - temperature (K)
!    qvp    - water vapor mixing ratio (kg/kg)
!
! !OUTPUT:
!    twb    - Wet bulb temperature (C)
!
! !ASSUMPTIONS:
!
! !REVISION HISTORY:
!     2009-March  - Mark T. Stoelinga - from RIP4.5
!     2010-August - J. Schramm
!     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
!
! !INTERFACE:
! ------------------------------------------------------------------

! NCLFORTSTART
SUBROUTINE WETBULBCALC(prs, tmk, qvp, twb, nx, ny, nz, psafile, errstat, errmsg)
    USE wrf_constants, ONLY : ALGERR, GAMMA, GAMMAMD, TLCLC1, TLCLC2, TLCLC3, &
                          EPS, TLCLC4, THTECON1, THTECON2, THTECON3

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: twb

    INTEGER, INTENT(IN) :: nx, ny, nz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: prs
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: tmk
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: qvp
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: twb
    CHARACTER(LEN=*), INTENT(IN) :: psafile
    INTEGER, INTENT(INOUT) :: errstat
    CHARACTER(LEN=*), INTENT(INOUT) :: errmsg

!NCLEND

    INTEGER :: i, j, k
    INTEGER :: jt, ip
    REAL(KIND=8) :: q, t, p, e, tlcl, eth
    REAL(KIND=8) :: fracip, fracip2, fracjt, fracjt2
    REAL(KIND=8), DIMENSION(150) :: PSADITHTE, PSADIPRS
    REAL(KIND=8), DIMENSION(150,150) :: PSADITMK
    REAL(KIND=8) :: tonpsadiabat

    INTEGER :: l1, h1, mid1, rang1, l2, h2, mid2, rang2
    INTEGER :: errcnt1, errcnt2, bad_i, bad_j, bad_k
    REAL(KIND=8) :: bad_p, bad_eth
    !INTEGER :: ip, ipch, jt, jtch

    errcnt1 = 0
    errcnt2 = 0
    bad_i = -1
    bad_j = -1
    bad_k = -1

    !  Before looping, set lookup table for getting temperature on
    !  a pseudoadiabat.

    CALL DLOOKUP_TABLE(PSADITHTE, PSADIPRS, PSADITMK, psafile, errstat, errmsg)

    IF (errstat .NE. 0) THEN
        RETURN
    END IF

    !$OMP PARALLEL DO COLLAPSE(3) PRIVATE (i, j, k, jt, ip, q, t, p, e, tlcl, &
    !$OMP eth, fracip, fracip2, fracjt, fracjt2, l1, h1, mid1, rang1, l2, h2, &
    !$OMP mid2, rang2, tonpsadiabat) REDUCTION(+:errcnt1, errcnt2) &
    !$OMP SCHEDULE(runtime)
    DO k=1,nz
        DO j=1,ny
            DO i=1,nx
                q = MAX(qvp(i,j,k), 1.D-15)
                t = tmk(i,j,k)
                p = prs(i,j,k)/100.
                e = q*p/(EPS + q)
                tlcl = TLCLC1/(LOG(t**TLCLC2/e) - TLCLC3) + TLCLC4
                eth = t*(1000./p)**(GAMMA*(1. + GAMMAMD*q))*&
                    EXP((THTECON1/tlcl - THTECON2)*q*(1. + THTECON3*q))

                ! Now we need to find the temperature (in K) on a moist adiabat
                ! (specified by eth in K) given pressure in hPa.  It uses a
                ! lookup table, with data that was generated by the Bolton (1980)
                ! formula for theta_e.

                ! First check if pressure is less than min pressure in lookup table.
                ! If it is, assume parcel is so dry that the given theta-e value can
                ! be interpretted as theta, and get temperature from the simple dry
                ! theta formula.

                IF (p .LE. PSADIPRS(150)) THEN
                    tonpsadiabat = eth*(p/1000.)**GAMMA
                ELSE
                    ! Otherwise, look for the given thte/prs point in the lookup table.
                    jt = -1
                    l1 = 1
                    h1 = 149
                    rang1 = h1 - l1
                    mid1 = (h1 + l1) / 2
                    DO WHILE(rang1 .GT. 1)
                        IF (eth .GE. psadithte(mid1)) THEN
                             l1 = mid1
                        ELSE
                             h1 = mid1
                        END IF
                        rang1 = h1 - l1
                        mid1 = (h1 + l1) / 2
                    END DO
                    jt = l1

                    ip = -1
                    l2 = 1
                    h2 = 149
                    rang2 = h2 - l2
                    mid2 = (h2 + l2) / 2
                    DO WHILE(rang2 .GT. 1)
                        IF (p .LE. psadiprs(mid2)) THEN
                            l2 = mid2
                        ELSE
                            h2 = mid2
                        END IF
                        rang2 = h2 - l2
                        mid2 = (h2 + l2) / 2
                    END DO
                    ip = l2

                    IF (jt .EQ. -1 .OR. ip .EQ. -1) THEN
                        errcnt1 = errcnt1 + 1
                        !$OMP CRITICAL
                        ! Only do this the first time
                        IF (bad_i .EQ. -1) THEN
                            bad_i = i
                            bad_j = j
                            bad_k = k
                            bad_p = p
                            bad_eth = eth
                        END IF
                        !$OMP END CRITICAL
                        CYCLE
                    ENDIF

                    fracjt = (eth - PSADITHTE(jt))/(PSADITHTE(jt+1) - PSADITHTE(jt))
                    fracjt2 = 1. - fracjt
                    fracip = (PSADIPRS(ip) - p)/(PSADIPRS(ip) - PSADIPRS(ip+1))
                    fracip2 = 1. - fracip

                    IF (PSADITMK(ip,jt) .GT. 1e9 .OR. PSADITMK(ip+1,jt) .GT. 1e9 .OR. &
                        PSADITMK(ip,jt+1) .GT. 1e9 .OR. PSADITMK(ip+1,jt+1) .GT. 1e9) THEN
                        errcnt2 = errcnt2 + 1
                        !$OMP CRITICAL
                        ! Only do this the first time
                        IF (bad_i .EQ. -1) THEN
                            bad_i = i
                            bad_j = j
                            bad_k = k
                            bad_p = p
                            bad_eth = eth
                        END IF
                        !$OMP END CRITICAL
                        CYCLE
                    ENDIF

                    tonpsadiabat = fracip2*fracjt2*PSADITMK(ip,jt) + &
                                   fracip*fracjt2*PSADITMK(ip+1,jt) + &
                                   fracip2*fracjt*PSADITMK(ip,jt+1) + &
                                   fracip*fracjt*PSADITMK(ip+1,jt+1)
                ENDIF

                twb(i,j,k) = tonpsadiabat

            END DO
        END DO
    END DO

    !$OMP END PARALLEL DO

    IF (errcnt1 > 0) THEN
        errstat = ALGERR
        WRITE(errmsg, *) "Outside of lookup table bounds. i=", bad_i, ",j=", bad_j, ",k=", bad_k, ",p=", bad_p, ",eth=", bad_eth
        RETURN
    END IF

    IF (errcnt2 > 0) THEN
        errstat = ALGERR
        WRITE(errmsg, *) "PRS and THTE unreasonable. i=", bad_i, ",j=", bad_j, ",k=", bad_k, ",p=", bad_p, ",eth=", bad_eth
        RETURN
    END IF

    RETURN

END SUBROUTINE WETBULBCALC

! !IROUTINE: omgcalc -- Calculate omega (dp/dt)
!
! !DESCRIPTION:
!
!   Calculate approximate omega, based on vertical velocity w (dz/dt).
!   It is approximate because it cannot take into account the vertical
!   motion of pressure surfaces.
!
! !INPUT:
!    mx - index for x dimension
!    my - index for y dimension
!    mx -  index for vertical dimension
!    qvp - water vapor mixing ratio (kg/kg)
!    tmk - temperature (K)
!    www - vertical velocity (m/s)
!    prs -  pressure (Pa)
!
! !OUTPUT:
!    omg - omega (Pa/sec)
!
! !ASSUMPTIONS:
!
! !REVISION HISTORY:
!     2009-March  - Mark T. Stoelinga - from RIP4.5
!     2010-August - J. Schramm
!     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
!
! ------------------------------------------------------------------

!NCLFORTSTART
SUBROUTINE OMGCALC(qvp, tmk, www, prs, omg, mx, my, mz)
    USE wrf_constants, ONLY : G, RD, EPS

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: omg

    INTEGER,INTENT(IN) :: mx, my, mz
    REAL(KIND=8), INTENT(IN), DIMENSION(mx,my,mz) :: qvp
    REAL(KIND=8), INTENT(IN), DIMENSION(mx,my,mz) :: tmk
    REAL(KIND=8), INTENT(IN), DIMENSION(mx,my,mz) :: www
    REAL(KIND=8), INTENT(IN), DIMENSION(mx,my,mz) :: prs
    REAL(KIND=8), INTENT(OUT), DIMENSION(mx,my,mz) :: omg

!NCLEND

    ! Local variables
    INTEGER :: i, j, k
    !REAL(KIND=8), PARAMETER :: GRAV=9.81, RGAS=287.04, EPS=0.622

    !$OMP PARALLEL DO COLLAPSE(3) SCHEDULE(runtime)
    DO k=1,mz
        DO j=1,my
            DO i=1,mx
                omg(i,j,k) = -G*prs(i,j,k)/&
                              (RD*((tmk(i,j,k)*(EPS + qvp(i,j,k)))/&
                              (EPS*(1. + qvp(i,j,k)))))*www(i,j,k)
            END DO
       END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE OMGCALC

!======================================================================
!
! !IROUTINE: VIRTUAL_TEMP -- Calculate virtual temperature (K)
!
! !DESCRIPTION:
!
!   Calculates virtual temperature in K, given temperature
!      in K and mixing ratio in kg/kg.
!
! !INPUT:
!    NX     - index for x dimension
!    NY     - index for y dimension
!    NZ     - index for z dimension
!    RATMIX - water vapor mixing ratio (kg/kg)
!    TEMP   - temperature (K)
!
! !OUTPUT:
!    TV     - Virtual temperature (K)
!
! !ASSUMPTIONS:
!
! !REVISION HISTORY:
!     2009-March  - Mark T. Stoelinga - from RIP4.5
!     2010-August - J. Schramm
!     2014-March - A. Jaye - modified to run with NCL and ARW wrf output
!
! ------------------------------------------------------------------
!NCLFORTSTART
SUBROUTINE VIRTUAL_TEMP(temp, ratmix, tv, nx, ny, nz)
    USE wrf_constants, ONLY : EPS

    IMPLICIT NONE

    !f2py threadsafe
    !f2py intent(in,out) :: tv

    INTEGER, INTENT(IN) :: nx, ny, nz
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: temp
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(IN) :: ratmix
    REAL(KIND=8), DIMENSION(nx,ny,nz), INTENT(OUT) :: tv

!NCLEND

    INTEGER :: i,j,k
    !REAL(KIND=8),PARAMETER :: EPS = 0.622D0

    !$OMP PARALLEL DO COLLAPSE(3) SCHEDULE(runtime)
    DO k=1,nz
        DO j=1,ny
            DO i=1,nx
                tv(i,j,k) = temp(i,j,k)*(EPS + ratmix(i,j,k))/(EPS*(1.D0 + ratmix(i,j,k)))
            END DO
        END DO
    END DO
    !$OMP END PARALLEL DO

    RETURN

END SUBROUTINE VIRTUAL_TEMP


c=======================================================================
c
c     subroutine ALLOCMVRFR
c
c     Markowitz Mean-Variance strategy with a risk-free asset
c
c     w(i), i=1,...,n the riskly assets (portfolio weights)
c     w(0), the risk-free asset
c
c     Min[ w*Q*w ]
c      s.t.
c     rho*w + rfr*w(0) >= delta     (target return)
c     C*w <= b                      (linear constraints)
c     Cinf(i) <= w(i) <= Csup(i)    (riskly assets lower/upper bounds)
c     Cinf(0) <= w(0) <= Csup(0)    (risk-free asset lower/upper bounds)
c
c        Q   : covariance matrix (n by n)
c        rho : expected returns  (n)
c        rfr : risk-free rate
c
c-----------------------------------------------------------------------
      SUBROUTINE allocmvrfr ( n, cov, rho, rfr,
     &                        neq, nin, ccst, bcst, cinf, csup,
     &                        cinfrfr, csuprfr, mu,
     &                        iwork, dwork, wopt, wrf, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : number of assets                               integer
c       cov     : covariance matrix (n*n)                         double
c       rho     : expected returns (n)                            double
c       rfr     : expected risk-free rate                         double
c       neq     : number equality constraints                    integer
c       nin     : number inequality constraints                  integer
c       ccst    : matrix of constraints (nasset*(neq+nin))        double
c       bcst    : vector initial of constraints (neq+nin)         double
c       cinf    : lower bound (n)                                 double
c       csup    : upper bound (n)                                 double
c       cinfrfr : risk-free asset lower bound                     double
c       csuprfr : risk-free asset upper bound                     double
c       mu      : performance target                              double
c
c     WORKSPACE
c       iwork  : 3*n + 2*nin + neq + 7                           integer
c       dwork  : n*(2*n+nin+neq+11) + 4*nin + 2*neq + 12          double
c
c     OUTPUT
c       wopt   : optimal portfolio (n)                             double
c       wrf    : optimal risk-free asset                           double
c       info   : diagnostic argument                              integer
c
c     CALL
c       SEV     : vector sum
c       OPMV    : computing optimization for ALLOCMV
c       TESTSDP : matrix SDP test
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info, neq, nin
      DOUBLE PRECISION mu, rfr, cinfrfr, csuprfr, wrf
      DOUBLE PRECISION cov(*), rho(*), cinf(*), csup(*),
     &                 ccst(n,*), bcst(*), wopt(*)
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER piwo, pisdp, pdwo, pdsdp
      DOUBLE PRECISION sum, mutest
c
c     external subroutines
      EXTERNAL opmvrfr, testsdp, SEV
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0          ! diagnostic argument
c
c     pointers for integer work space : iwork
c     ---------------------------------------
      pisdp = 1
c     pisdp : pointer for TESTSDP (n)
      piwo  = 1
c     piwo  : pointer for OPMVRFR (3*n + 2*nin + neq + 7)
c
c     Total size of iwork array = 3*n + 2*nin + neq + 7
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdsdp = 1
c     pdsdp : pointer for TESTSDP (n*(2*n + 7))
      pdwo  = 1
c     pdwo  : pointer for OPMVRFR
c             n*(n + neq + nin + 11) + 2*neq  + 4*nin + 12
c
c     Total size of dwork array =  n*(2*n+nin+neq+11) + 4*nin + 2*neq + 12
c
c-----------------------------------------------------------------------
c
c     covariance matrix SDP (-1.E-50) ?
      CALL testsdp (n, cov, iwork(pisdp), dwork(pdsdp), info)
      IF (info .NE. 0) THEN
         info = -108
         RETURN
      ENDIF
c
c     tests constraints compatibility
      mutest = -1.E+8
      CALL  opmvrfr ( n, cov, rho, rfr, mutest, neq, nin, ccst, bcst,
     &                cinf, csup, cinfrfr, csuprfr,
     &                iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -100
        RETURN
      ENDIF
c
c     optimization: mean-variance (with risk-free asset)
      CALL opmvrfr ( n, cov, rho, rfr, mu, neq, nin, ccst, bcst,
     &               cinf, csup, cinfrfr, csuprfr,
     &               iwork(piwo), dwork(pdwo), wopt, info )
      IF (info .EQ. 1001) THEN
        info = -101
      ENDIF
c
c     risk-free asset position
      CALL SEV ( n, wopt, sum )
      wrf = 1.0 - sum
      RETURN
      END


      function df (y,x)
c     implicit double precision (a-h,o-z)                                    dp
c
      common /cont/ had(4), ityp2d
      dimension y(2,4), x(2,4)
c
      ac1=+y(1,2)*(y(2,3)-y(2,4))+y(1,3)*(y(2,4)-y(2,2))+y(1,4)*(y(2,2)
     1 -y(2,3))
      ac2=+y(1,2)*(y(2,4)-y(2,1))+y(1,4)*(y(2,1)-y(2,2))+y(1,1)*(y(2,2)
     1 -y(2,4))
      au1=+x(1,2)*(x(2,3)-x(2,4))+x(1,3)*(x(2,4)-x(2,2))+x(1,4)*(x(2,2)
     1 -x(2,3))
      au2=+x(1,2)*(x(2,4)-x(2,1))+x(1,4)*(x(2,1)-x(2,2))+x(1,1)*(x(2,2)
     1 -x(2,4))
      if (ityp2d.ge.1) go to 20
      dfe=((y(1,2)+y(1,3)+y(1,4))*ac1+(y(1,1)+y(1,2)+y(1,4))*ac2)/((x(1,
     1 2)+x(1,3)+x(1,4))*au1+(x(1,1)+x(1,2)+x(1,4))*au2)
      return
   20 df=(ac1+ac2)/(au1+au2)
      return
      end


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE LINLEN (MP, COOR, LINKP, KNUM, LNUM, KT, I3, J1, J2,
     &   J3, DIST, ERR)
C***********************************************************************

C  SUBROUTINE LINLEN = CALCULATES THE LENGTH OF A GIVEN LINE

C***********************************************************************

C  VARIABLES USED:
C     NID   = AN ARRAY OF UNIQUE NODE IDENTIFIERS.
C     REAL  = .TRUE. FOR AN ACTUAL GENERATION
C           = .FALSE. FOR A TRIAL GENERATION
C     ERR   = .TRUE. IF AN ERROR WAS ENCOUNTERED
C     J1    = POINTER FOR THE FIRST POINT
C     J2    = POINTER FOR THE SECOND POINT
C     J3    = POINTER FOR THE THIRD POINT
C     MAXNP = MAXIMUM NUMBER OF NODES ON THE PERIMETER
C             NOTE: MAXNP MUST BE ADJUSTED FOR THE CURRENT
C                   LOCATION IN X, Y, & NID
C     KT    = THE LINE TYPE:
C           = 1 FOR STRAIGHT LINES
C           = 2 FOR CORNER LINES
C           = 3 FOR ARC WITH CENTER GIVEN
C           = 4 FOR ARC WITH THIRD POINT ON THE ARC
C           = 5 FOR PARABOLA
C           = 6 FOR ARC WITH RADIUS GIVEN

C***********************************************************************

      DIMENSION COOR (2, MP), LINKP (2, MP)

      LOGICAL ERR

      PI = ATAN2(0.0, -1.0)

      DIST = 0.
      ERR = .TRUE.

C  STRAIGHT LINE GENERATION

      IF (KT.EQ.1) THEN
         YDIFF = COOR (2, J2) -COOR (2, J1)
         XDIFF = COOR (1, J2) -COOR (1, J1)
         DIST = SQRT (YDIFF ** 2 + XDIFF ** 2)
         IF (DIST.EQ.0.) THEN
            WRITE (*, 10000) KNUM
            RETURN
         ENDIF

C  CORNER GENERATION

      ELSEIF (KT.EQ.2) THEN
         XDA = COOR (1, J3) -COOR (1, J1)
         YDA = COOR (2, J3) -COOR (2, J1)
         XDB = COOR (1, J2) -COOR (1, J3)
         YDB = COOR (2, J2) -COOR (2, J3)
         DA = SQRT (XDA ** 2 + YDA ** 2)
         DB = SQRT (XDB ** 2 + YDB ** 2)
         IF ((DA.EQ.0.) .OR. (DB.EQ.0.) )THEN
            WRITE (*, 10000) KNUM
            RETURN
         ENDIF
         DIST = DA+DB

C  CIRCULAR ARC

      ELSEIF ((KT.EQ.3) .OR. (KT.EQ.4) .OR. (KT.EQ.6) )THEN
         XSTART = COOR (1, J1)
         YSTART = COOR (2, J1)
         CALL ARCPAR (MP, KT, KNUM, COOR, LINKP, J1, J2, J3, I3,
     &      XCEN, YCEN, THETA1, THETA2, TANG, R1, R2, ERR, ICCW, ICW,
     &      XK, XA)

C  GENERATE THE CIRCLE

         ANG = THETA1
         DEL = TANG/30
         DO 100 I = 2, 29
            ANG = ANG+DEL
            RADIUS = XA * EXP (XK * ANG)
            XEND = XCEN+COS (ANG) * RADIUS
            YEND = YCEN+SIN (ANG) * RADIUS
            DIST = DIST+SQRT ((XEND-XSTART) ** 2 + (YEND-YSTART) ** 2)
            XSTART = XEND
            YSTART = YEND
  100    CONTINUE
         XEND = COOR (1, J2)
         YEND = COOR (2, J2)
         DIST = DIST+SQRT ((XEND-XSTART) ** 2 + (YEND-YSTART) ** 2)

C  ELIPSE

      ELSEIF (KT .EQ. 7) THEN
         XSTART = COOR (1, J1)
         YSTART = COOR (2, J1)
         CALL ELPSPR (MP, KT, KNUM, COOR, LINKP, J1, J2, J3,
     &      I3, XCEN, YCEN, THETA1, THETA2, TANG, IDUM1, IDUM2,
     &      AVALUE, BVALUE, ERR)

C  GENERATE THE ELIPSE

         ANG = THETA1
         DEL = TANG/30
         DO 110 I = 2, 29
            ANG = ANG+DEL
            RADIUS = SQRT ( (AVALUE **2 * BVALUE **2) /
     &         ( (BVALUE **2 * COS (ANG) **2) +
     &         (AVALUE **2 * SIN (ANG) **2) ) )
            XEND = XCEN+COS (ANG) * RADIUS
            YEND = YCEN+SIN (ANG) * RADIUS
            DIST = DIST+SQRT ((XEND-XSTART) ** 2 + (YEND-YSTART) ** 2)
            XSTART = XEND
            YSTART = YEND
  110    CONTINUE
         XEND = COOR (1, J2)
         YEND = COOR (2, J2)
         DIST = DIST+SQRT ((XEND-XSTART) ** 2 + (YEND-YSTART) ** 2)

C     PARABOLA

      ELSEIF (KT.EQ.5) THEN

C  CHECK LEGITIMACY OF DATA

         XMID =  (COOR (1, J1) +COOR (1, J2) ) * 0.5
         YMID =  (COOR (2, J1) +COOR (2, J2) ) * 0.5
         DOT =  (COOR (1, J2) -COOR (1, J1) ) * (COOR (1, J3) -XMID)
     &      + (COOR (2, J2) -COOR (2, J1) ) * (COOR (2, J3) -YMID)
         PERP = SQRT ((COOR (1, J2) -COOR (1, J1) ) ** 2 +
     &      (COOR (2, J2) - COOR (2, J1) ) ** 2) *
     &      SQRT ((COOR (1, J3) -XMID) ** 2 + (COOR (2, J3)
     &      -YMID) ** 2)
         IF (DOT.GE.0.05 * PERP) THEN
            WRITE (*, 10030) KNUM
            RETURN
         ENDIF

C  GETARC LENGTH

         HALFW = SQRT ((COOR (1, J2) -COOR (1, J1) ) ** 2 +
     &      (COOR (2, J2) - COOR (2, J1) ) ** 2 )  * 0.5
         IF (HALFW.EQ.0.) THEN
            WRITE (*, 10000) KNUM
            RETURN
         ENDIF
         HEIGHT = SQRT ((XMID-COOR (1, J3) ) ** 2
     &      + (YMID-COOR (2, J3) ) ** 2)
         COEF = HEIGHT/HALFW ** 2
         TCOEF = 2.0 * COEF

C  PARC IS A STATEMENT FUNCTION

         PLEFT = PARC (-TCOEF * HALFW, TCOEF)
         ARCTOT = 2.0 * PARC (TCOEF * HALFW, TCOEF)
         ARCDEL = ARCTOT/30
         ARCNXT = ARCDEL
         ARCNOW = 0.0
         THETA = ATAN2 (COOR (2, J2) -COOR (2, J1) , COOR (1, J2)
     &      - COOR (1, J1) )

C  CORRECT FOR ORIENTATION

         CROSS =  (COOR (1, J3) -XMID) *  (COOR (2, J2) -COOR (2, J1) )-
     &      (COOR (2, J3) -YMID) *  (COOR (1, J2) -COOR (1, J1) )
         IF (CROSS.LT.0.0) THETA = THETA+PI
         SINT = SIN (THETA)
         COST = COS (THETA)

C  FIND POINTS APPROXIMATELY BY INTEGRATION

         XL = -HALFW
         FL = SQRT (1.0+ (TCOEF * XL) ** 2)
         KOUNT = 1
         DELX = 2.0 * HALFW/200.0
         XSTART = COOR (1, J1)
         YSTART = COOR (2, J1)
         DO 120 I = 1, 100
            FM = SQRT (1.0+ (TCOEF * (XL+DELX) ) ** 2)
            XR = - HALFW + DBLE(I) * 2.0 * DELX
            FR = SQRT (1.0+ (TCOEF * XR) ** 2)
            ARCOLD = ARCNOW
            ARCNOW = ARCNOW+DELX * (FL+4.0 * FM+FR) / 3.0
            IF (ARCNOW.GE.ARCNXT) THEN

C  COMPUTE POSITION IN LOCAL COORDINATE SYSTEM

               FRAC =  (ARCNXT-ARCOLD) / (ARCNOW-ARCOLD)
               XK = XL+FRAC * 2.0 * DELX
               YK = COEF * XK ** 2

C  CORRECT FOR ORIENTATION PROBLEM

               IF (CROSS.LT.0.0) XK = -XK

C  ROTATE IN LINE WITH GLOBAL COORDINATE SYSTEM

               ROTX = XK * COST - YK * SINT
               ROTY = YK * COST + XK * SINT

C  RESTORE XK

               IF (CROSS.LT.0.0) XK = -XK

C  TRANSLATE

               XEND = ROTX+COOR (1, J3)
               YEND = ROTY+COOR (2, J3)
               DIST = DIST+SQRT ((XEND-XSTART) ** 2 + (YEND-YSTART) **2)
               KOUNT = KOUNT+1
               XSTART = XEND
               YSTART = YEND

C  PREPARE FOR NEXT POINT

               IF (KOUNT.GE.29) GOTO 130
               ARCNXT = ARCNXT+ARCDEL

C  RESTART INTEGRATION

               XR = XK
               FR = SQRT (1.0+ (TCOEF * XR) ** 2)

C  CORRECT FOR INTEGRATION ERROR

               ARCNOW = PARC (TCOEF * XR, TCOEF) -PLEFT
            ENDIF
            XL = XR
            FL = FR
  120    CONTINUE
  130    CONTINUE
         XEND = COOR (1, J2)
         YEND = COOR (2, J2)
         DIST = DIST+SQRT ((XEND-XSTART) ** 2+ (YEND-YSTART) ** 2)
      ENDIF

C     NORMAL EXIT

      ERR = .FALSE.
      RETURN

10000 FORMAT (' ZERO LINE LENGTH ENCOUNTERED FOR LINE', I5)
10030 FORMAT (' POINTS GIVEN FOR LINE', I5, ' DO NOT DEFINE A PARABOLA')

      END