!! generate an initial model for spherical geometry with a
!! uniform composition.  Here we take a base density and temperature
!! and use HSE and constant entropy to generate the model.

program init_1d

  use bl_types
  use bl_constants_module
  use bl_error_module
  use eos_module, only: eos, eos_input_rt, eos_init
  use eos_type_module, only: eos_t
  use extern_probin_module, only: use_eos_coulomb
  use network
  use actual_burner_module, only: actual_burner_init
  use fundamental_constants_module, only: Gconst
  use urca_composition_module

  implicit none

  integer :: i, j, n

  integer :: nx

  real (kind=dp_t) :: temp_base, dens_base

  real (kind=dp_t), allocatable :: xzn_hse(:), xznl(:), xznr(:)
  real (kind=dp_t), allocatable :: model_hse(:,:), M_enclosed(:)

  ! define convenient indices for the scalars
  integer, parameter :: nvar = 3 + nspec
  integer, parameter :: idens = 1, &
                        itemp = 2, &
                        ipres = 3, &
                        ispec = 4

  real (kind=dp_t), parameter :: M_sun = 1.9891e33

  ! we'll get the composition indices from the network module
  integer, save :: ihe4, ic12, io16, ine20, ine23, ina23, img23

  integer :: narg
  character(len=128) :: params_file

  real (kind=dp_t), save :: xmin, xmax, dCoord

  real (kind=dp_t) :: dens_zone, temp_zone, pres_zone
  real (kind=dp_t) :: dpd, dpt, dsd, dst

  real (kind=dp_t) :: p_want, drho, dtemp, delx
  real (kind=dp_t), allocatable :: entropy_store(:), entropy_want(:)

  real (kind=dp_t) :: g_zone, try_tol

  real (kind=dp_t) :: TOL = 1.e-11

  integer :: MAX_ITER = 1000000
  integer :: MAX_RETRY = 50

  integer :: iter, iretry

  logical :: converged_hse, fluff

  real (kind=dp_t), save :: low_density_cutoff, smallx, dens_conv_zone, M_conv_zone

  logical :: test_hse_convergence = .true.

  real (kind=dp_t), save :: temp_before_fluff, temp_fluff

  character (len=128) :: fluff_type = "continuous"

  logical :: isentropic

  character (len=256) :: outfile, prefix
  character (len=8) num

  real (kind=dp_t) :: max_hse_error, dpdr, rhog

  real (kind=dp_t) :: dtol_fac = 0.000001_dp_t

  integer :: i_conv, i_fluff

  type (eos_t) :: eos_state

  namelist /params/ nx, dens_base, temp_base, &
       low_density_cutoff, dens_conv_zone, M_conv_zone, temp_fluff, &
       test_hse_convergence, TOL, MAX_ITER, dtol_fac, &
       xmin, xmax, &
       fluff_type, &
       c12_in, c12_out, o16_in, o16_out, &
       ne23_in, ne23_out, na23_in, na23_out, &
       urca_23_dens, urca_shell_type, shell_atan_kappa, &
       na_ne_23, prefix

  ! determine if we specified a runtime parameters file or use the default
  narg = command_argument_count()

  if (narg == 0) then
     params_file = "_params"
  else
     call get_command_argument(1, value = params_file)
  endif

  ! define the defaults parameters for this model
  nx = 1280

  smallx = 1.d-10

  xmin = 0_dp_t
  xmax = 5.d8

  dens_base = 2.6d9
  temp_base = 6.d8

  dens_conv_zone = -1.d0
  M_conv_zone = 2.0d0

  low_density_cutoff =1.d-4
  temp_fluff = 1.d7

  c12_in   = 0.0_dp_t
  c12_out  = 0.0_dp_t
  o16_in   = 0.0_dp_t
  o16_out  = 0.0_dp_t
  ne23_in  = 0.0_dp_t
  ne23_out = 0.0_dp_t
  na23_in  = 0.0_dp_t
  na23_out = 0.0_dp_t

  prefix = "spherical"

  ! check the namelist for any changed parameters
  open(unit=11, file=params_file, status="old", action="read")
  read(unit=11, nml=params)
  close(unit=11)

  ! Initialize the temperature interior to fluff
  ! (used to calculate fluff temperature for various values of fluff_type)
  temp_before_fluff = temp_fluff

  ! initialize the EOS and network

  ! use_eos_coulomb comes in from extern_probin_module -- override
  ! here if desired
  use_eos_coulomb = .true.
  call eos_init()
  call network_init()
  call actual_burner_init()

  ! Initialize the composition module
  call init_urca_composition()

!-----------------------------------------------------------------------------
! Create a 1-d uniform grid that is identical to the mesh that we are
! mapping onto, and then we want to force it into HSE on that mesh.
!-----------------------------------------------------------------------------

! allocate storage
  allocate(xzn_hse(nx))
  allocate(xznl(nx))
  allocate(xznr(nx))
  allocate(model_hse(nx,nvar))
  allocate(M_enclosed(nx))
  allocate(entropy_want(nx))
  allocate(entropy_store(nx))

! compute the coordinates of the new gridded function
  dCoord = (xmax - xmin) / dble(nx)

  do i = 1, nx
     xznl(i) = xmin + (dble(i) - 1.0_dp_t)*dCoord
     xznr(i) = xmin + (dble(i))*dCoord
     xzn_hse(i) = 0.5_dp_t*(xznl(i) + xznr(i))
  enddo

  fluff = .false.

  ! call the EOS one more time for this zone and then go on to the next
  eos_state%T     = temp_base
  eos_state%rho   = dens_base
  call set_urca_composition(eos_state)

  ! (t, rho) -> (p, s)
  call eos(eos_input_rt, eos_state)

  ! make the initial guess be completely uniform
  model_hse(:,idens) = eos_state%rho
  model_hse(:,itemp) = eos_state%T
  model_hse(:,ipres) = eos_state%p

  do i = 1, nspec
     model_hse(:,ispec-1+i) = eos_state%xn(i)
  enddo

  entropy_want(:) = eos_state%s

  ! keep track of the mass enclosed below the current zone
  M_enclosed(1) = FOUR3RD*M_PI*(xznr(1)**3 - xznl(1)**3)*model_hse(1,idens)

!-----------------------------------------------------------------------------
! HSE + entropy solve
!-----------------------------------------------------------------------------

  isentropic = .true.

  do i = 2, nx

     delx = xzn_hse(i) - xzn_hse(i-1)

     ! as the initial guess for the temperature and density, use the previous
     ! zone
     dens_zone = model_hse(i-1,idens)
     temp_zone = model_hse(i-1,itemp)
     eos_state % rho = dens_zone
     eos_state % T = temp_zone
     call set_urca_composition(eos_state)
     eos_state % p = model_hse(i-1, ipres)
     eos_state % s = entropy_want(i)

     g_zone = -Gconst*M_enclosed(i-1)/(xznl(i)*xznl(i))

     !-----------------------------------------------------------------------
     ! iteration loop
     !-----------------------------------------------------------------------

     ! start off the Newton loop by saying that the zone has not converged
     converged_hse = .FALSE.

     if (.not. fluff) then

        do iretry = 1, MAX_RETRY
           try_tol = TOL*(1.1d0**(iretry-1))
           do iter = 1, MAX_ITER
              call iter_dens_temp(dens_zone, temp_zone, eos_state, &
                                  g_zone, delx, tol, dtol_fac, dens_conv_zone, low_density_cutoff, temp_fluff, &
                                  isentropic, test_hse_convergence, converged_hse, fluff, &
                                  fluff_type, &
                                  i_fluff, i_conv, i)
              if (converged_hse) then
                 exit
              end if
           enddo
           if (converged_hse) then
              exit
           else if (iretry == MAX_RETRY) then
              call bl_error("ERROR: HSE non-convergence with retries!")
           end if
        enddo

        if (temp_zone < temp_fluff) then
           if (fluff_type .eq. "constant") then
              call get_fluff_temperature(temp_zone, temp_fluff, temp_before_fluff, fluff_type)
           endif
           isentropic = .false.
        endif

     else
        dens_zone = low_density_cutoff
        call get_fluff_temperature(temp_zone, temp_fluff, temp_before_fluff, fluff_type)
     endif

     ! call the EOS one more time for this zone and then go on to the next
     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     call set_urca_composition(eos_state)

     ! (t, rho) -> (p, s)
     call eos(eos_input_rt, eos_state)

     pres_zone = eos_state%p

     dpd = eos_state%dpdr

     ! update the thermodynamics in this zone
     model_hse(i,idens) = dens_zone
     model_hse(i,itemp) = temp_zone
     model_hse(i,ipres) = pres_zone
     do j = 1, nspec
        model_hse(i,ispec-1+j) = eos_state%xn(j)
     enddo

     print *, i, dens_zone, temp_zone

     M_enclosed(i) = M_enclosed(i-1) + &
          FOUR3RD*M_PI*(xznr(i) - xznl(i))* &
            (xznr(i)**2 +xznl(i)*xznr(i) + xznl(i)**2)*model_hse(i,idens)

     if (M_enclosed(i) > M_conv_zone*M_sun .and. isentropic) then

        i_conv = i
        isentropic = .false.

     endif

  enddo

  print *, 'mass = ', M_enclosed(nx)/M_sun

  write(num,'(i8)') nx
  outfile = trim(prefix) // ".hse." // trim(adjustl(num))

  open (unit=50, file=outfile, status="unknown")

  write (50,1001) "# npts = ", nx
  write (50,1001) "# num of variables = ", nvar
  write (50,1002) "# density"
  write (50,1002) "# temperature"
  write (50,1002) "# pressure"

  do n = 1, nspec
     write (50,1003) "# ", spec_names(n)
  enddo

1000 format (1x, 12(g26.16, 1x))
1001 format(a, i5)
1002 format(a)
1003 format(a,a)

  do i = 1, nx

     write (50,1000) xzn_hse(i), model_hse(i,idens), model_hse(i,itemp), model_hse(i,ipres), &
          (model_hse(i,ispec-1+n), n=1,nspec)

  enddo

  ! compute the maximum HSE error
  max_hse_error = -1.d30

  do i = 2, nx-1
     g_zone = -Gconst*M_enclosed(i-1)/xznr(i-1)**2
     dpdr = (model_hse(i,ipres) - model_hse(i-1,ipres))/delx
     rhog = HALF*(model_hse(i,idens) + model_hse(i-1,idens))*g_zone

     if (dpdr /= ZERO .and. model_hse(i,idens) > low_density_cutoff) then
        max_hse_error = max(max_hse_error, abs(dpdr - rhog)/abs(dpdr))
     endif

     if (dpdr /= 0) then
        print *, i, real(model_hse(i,idens)), real(model_hse(i,itemp)), real(dpdr), real(rhog), abs(dpdr - rhog)/abs(dpdr)
     endif
  enddo

  print *, 'maximum HSE error = ', max_hse_error
  print *, ' '

  print *, 'total mass (Msun) = ', M_enclosed(i_fluff)/M_sun
  print *, 'convective zone mass (Msun) = ', M_enclosed(i_conv)/M_sun
  print *, 'convective zone boundary density (g/cm^3) = ', model_hse(i_conv, idens)
  print *, 'convective zone boundary radius (cm) = ', xzn_hse(i_conv)
  print *, 'convective zone boundary index = ', i_conv

  close (unit=50)

end program init_1d

subroutine get_fluff_temperature(temp, temp_fluff, temp_previous, fluff_type)

  ! There are 2 kinds of fluff temperature handling:
  ! 1) fluff_type = "constant"   : fluff is at the temperature temp_fluff in the inputs
  ! 2) fluff_type = "continuous" : fluff is at the same temperature as the material
  !                                immediately interior to the fluff.

  use bl_types, only: dp_t
  use bl_error_module

  implicit none

  real (kind=dp_t), intent(out)   :: temp
  real (kind=dp_t), intent(in)    :: temp_fluff, temp_previous
  character (len=128), intent(in) :: fluff_type

  if (fluff_type .eq. "constant") then
     temp = temp_fluff
  else if (fluff_type .eq. "continuous") then
     temp = temp_previous
  else
     call bl_error("ERROR: invalid fluff_type")
  end if

end subroutine get_fluff_temperature

subroutine iter_dens_temp(dens_zone, temp_zone, eos_state_inwards, &
                          g_zone, delx, tol, dtol_fac, dens_conv_zone, low_density_cutoff, temp_fluff, &
                          isentropic, test_hse_convergence, converged_hse, fluff, &
                          fluff_type, &
                          i_fluff, i_conv, izone)

  ! Do one rho, T iteration
  use bl_constants_module
  use bl_types, only: dp_t
  use bl_error_module
  use eos_type_module, only: eos_t
  use eos_module, only: eos, eos_input_rt
  use urca_composition_module

  implicit none

  real (kind=dp_t), intent(inout) :: dens_zone, temp_zone
  type (eos_t), intent(in) :: eos_state_inwards
  real (kind=dp_t), intent(in) :: g_zone, dens_conv_zone, delx, tol, dtol_fac, low_density_cutoff, temp_fluff
  logical, intent(inout) :: isentropic
  logical, intent(in) :: test_hse_convergence
  logical, intent(out) :: converged_hse, fluff
  integer, intent(out) :: i_fluff, i_conv
  integer, intent(in) :: izone
  character (len=128), intent(in) :: fluff_type

  type (eos_t) :: eos_state
  real (kind=dp_t) :: pres_zone, entropy
  real (kind=dp_t) :: A, B, dAdT, dAdrho, dBdT, dBdrho
  real (kind=dp_t) :: dpd, dpt, dsd, dst
  real (kind=dp_t) :: p_want, drho, dtemp
  real (kind=dp_t) :: dpdr, rhog, temp_before_fluff

  if (isentropic) then

     p_want = eos_state_inwards % p + &
          delx*0.5_dp_t*(dens_zone + eos_state_inwards % rho)*g_zone

     ! now we have two functions to zero:
     !   A = p_want - p(rho,T)
     !   B = entropy_want - s(rho,T)
     ! We use a two dimensional Taylor expansion and find the deltas
     ! for both density and temperature

     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     call set_urca_composition(eos_state)

     ! (t, rho) -> (p, s)
     call eos(eos_input_rt, eos_state)

     entropy = eos_state%s
     pres_zone = eos_state%p

     dpt = eos_state%dpdt
     dpd = eos_state%dpdr
     dst = eos_state%dsdt
     dsd = eos_state%dsdr

     A = p_want - pres_zone
     B = eos_state_inwards % s - entropy

     dAdT = -dpt
     dAdrho = 0.5d0*delx*g_zone - dpd
     dBdT = -dst
     dBdrho = -dsd

     dtemp = (B - (dBdrho/dAdrho)*A)/ &
          ((dBdrho/dAdrho)*dAdT - dBdT)

     drho = -(A + dAdT*dtemp)/dAdrho

     dens_zone = max((ONE-dtol_fac)*dens_zone, &
          min(dens_zone + drho, (ONE+dtol_fac)*dens_zone))

     temp_zone = max((ONE-dtol_fac)*temp_zone, &
          min(temp_zone + dtemp, (ONE+dtol_fac)*temp_zone))

     ! check if the density falls below our minimum cut-off --
     ! if so, floor it
     if (dens_zone < low_density_cutoff) then

        i_fluff = izone

        dens_zone = low_density_cutoff

        temp_before_fluff = eos_state_inwards % T

        call get_fluff_temperature(temp_zone, temp_fluff, temp_before_fluff, fluff_type)

        converged_hse = .TRUE.
        fluff = .TRUE.
        return

     endif

     if (dens_zone < dens_conv_zone .and. isentropic) then

        i_conv = izone
        isentropic = .false.

     endif

     if (test_hse_convergence) then

        ! Check to see if HSE is satisfied to relative tolerance TOL

        ! Call EOS again using the new values of dens_zone and temp_zone
        ! to get pres_zone ...
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        call set_urca_composition(eos_state)

        ! (t, rho) -> (p, s)
        call eos(eos_input_rt, eos_state)

        pres_zone = eos_state%p

        ! Compute dpdr
        dpdr = (pres_zone - eos_state_inwards % p)/delx

        ! Compute rho*g
        rhog = HALF*(dens_zone + eos_state_inwards % rho)*g_zone

        if (abs(dpdr - rhog) < TOL*abs(dpdr)) then
           converged_hse = .TRUE.
           return
        endif

     else

        ! Check to see if drho and dtemp are under the relative tolerance TOL
        if (abs(drho) < TOL*dens_zone .and. abs(dtemp) < TOL*temp_zone) then
           converged_hse = .TRUE.
           return
        endif

     endif

  else

     ! do isothermal
     p_want = eos_state_inwards % p + &
          delx*0.5*(dens_zone + eos_state_inwards % rho)*g_zone

     temp_zone = eos_state_inwards % T

     eos_state%T     = temp_zone
     eos_state%rho   = dens_zone
     call set_urca_composition(eos_state)

     ! (t, rho) -> (p, s)
     call eos(eos_input_rt, eos_state)

     entropy = eos_state%s
     pres_zone = eos_state%p

     dpd = eos_state%dpdr

     drho = (p_want - pres_zone)/(dpd - 0.5*delx*g_zone)

     dens_zone = max(0.9*dens_zone, &
          min(dens_zone + drho, 1.1*dens_zone))

     if (dens_zone < low_density_cutoff) then

        i_fluff = izone

        dens_zone = low_density_cutoff

        temp_before_fluff = eos_state_inwards % T

        call get_fluff_temperature(temp_zone, temp_fluff, temp_before_fluff, fluff_type)

        converged_hse = .TRUE.
        fluff = .TRUE.
        return

     endif

     if (test_hse_convergence) then

        ! Check to see if HSE is satisfied to relative tolerance TOL

        ! Call EOS again using the new values of dens_zone and temp_zone
        ! to get pres_zone ...
        eos_state%T     = temp_zone
        eos_state%rho   = dens_zone
        call set_urca_composition(eos_state)

        ! (t, rho) -> (p, s)
        call eos(eos_input_rt, eos_state)

        pres_zone = eos_state%p

        ! Compute dpdr
        dpdr = (pres_zone - eos_state_inwards % p)/delx

        ! Compute rho*g
        rhog = HALF*(dens_zone + eos_state_inwards % rho)*g_zone

        if (abs(dpdr - rhog) < TOL*abs(dpdr)) then
           converged_hse = .TRUE.
           return
        endif

     else

        ! Check to see if drho is under the relative tolerance TOL
        if (abs(drho) < TOL*dens_zone) then
           converged_hse = .TRUE.
           return
        endif

     endif

  endif

  ! if (.NOT. converged_hse) then
  !    print *, 'Error zone did not converge in init_1d'
  !    print *, 'integrate up'
  !    print *, 'trial density (dens_zone): ', dens_zone
  !    print *, 'trial temperature (temp_zone): ', temp_zone
  !    print *, 'current pressure (pres_zone): ', pres_zone
  !    print *, 'desired pressure (p_want): ', p_want
  !    print *, 'desired pressure rel tolerance: ', abs(pres_zone-p_want)/pres_zone
  !    print *, 'delta density (drho): ', drho
  !    print *, 'delta temperature (dtemp): ', dtemp
  !    print *, 'pressure gradient (dpdr): ', dpdr
  !    print *, 'density * gravitational accel. (rhog): ', rhog
  !    print *, 'difference... abs(dpdr-rhog): ', abs(dpdr-rhog)
  !    print *, 'target... TOL*abs(dpdr): ', TOL*abs(dpdr)
  !    call bl_error('Error: HSE non-convergence')
  ! endif

end subroutine iter_dens_temp


      SUBROUTINE MB02PD( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
     $                   EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
     $                   IWORK, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve (if well-conditioned) the matrix equations
C
C        op( A )*X = B,
C
C     where X and B are N-by-NRHS matrices, A is an N-by-N matrix and
C     op( A ) is one of
C
C        op( A ) = A   or   op( A ) = A'.
C
C     Error bounds on the solution and a condition estimate are also
C     provided.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     FACT    CHARACTER*1
C             Specifies whether or not the factored form of the matrix A
C             is supplied on entry, and if not, whether the matrix A
C             should be equilibrated before it is factored.
C             = 'F':  On entry, AF and IPIV contain the factored form
C                     of A. If EQUED is not 'N', the matrix A has been
C                     equilibrated with scaling factors given by R
C                     and C. A, AF, and IPIV are not modified.
C             = 'N':  The matrix A will be copied to AF and factored.
C             = 'E':  The matrix A will be equilibrated if necessary,
C                     then copied to AF and factored.
C
C     TRANS   CHARACTER*1
C             Specifies the form of the system of equations as follows:
C             = 'N':  A * X = B     (No transpose);
C             = 'T':  A**T * X = B  (Transpose);
C             = 'C':  A**H * X = B  (Transpose).
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of linear equations, i.e., the order of the
C             matrix A.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of right hand sides, i.e., the number of
C             columns of the matrices B and X.  NRHS >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the matrix A.  If FACT = 'F' and EQUED is not 'N',
C             then A must have been equilibrated by the scaling factors
C             in R and/or C.  A is not modified if FACT = 'F' or 'N',
C             or if FACT = 'E' and EQUED = 'N' on exit.
C             On exit, if EQUED .NE. 'N', the leading N-by-N part of
C             this array contains the matrix A scaled as follows:
C             EQUED = 'R':  A := diag(R) * A;
C             EQUED = 'C':  A := A * diag(C);
C             EQUED = 'B':  A := diag(R) * A * diag(C).
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     AF      (input or output) DOUBLE PRECISION array, dimension
C             (LDAF,N)
C             If FACT = 'F', then AF is an input argument and on entry
C             the leading N-by-N part of this array must contain the
C             factors L and U from the factorization A = P*L*U as
C             computed by DGETRF.  If EQUED .NE. 'N', then AF is the
C             factored form of the equilibrated matrix A.
C             If FACT = 'N', then AF is an output argument and on exit
C             the leading N-by-N part of this array contains the factors
C             L and U from the factorization A = P*L*U of the original
C             matrix A.
C             If FACT = 'E', then AF is an output argument and on exit
C             the leading N-by-N part of this array contains the factors
C             L and U from the factorization A = P*L*U of the
C             equilibrated matrix A (see the description of A for the
C             form of the equilibrated matrix).
C
C     LDAF    (input) INTEGER
C             The leading dimension of the array AF.  LDAF >= max(1,N).
C
C     IPIV    (input or output) INTEGER array, dimension (N)
C             If FACT = 'F', then IPIV is an input argument and on entry
C             it must contain the pivot indices from the factorization
C             A = P*L*U as computed by DGETRF; row i of the matrix was
C             interchanged with row IPIV(i).
C             If FACT = 'N', then IPIV is an output argument and on exit
C             it contains the pivot indices from the factorization
C             A = P*L*U of the original matrix A.
C             If FACT = 'E', then IPIV is an output argument and on exit
C             it contains the pivot indices from the factorization
C             A = P*L*U of the equilibrated matrix A.
C
C     EQUED   (input or output) CHARACTER*1
C             Specifies the form of equilibration that was done as
C             follows:
C             = 'N':  No equilibration (always true if FACT = 'N');
C             = 'R':  Row equilibration, i.e., A has been premultiplied
C                     by diag(R);
C             = 'C':  Column equilibration, i.e., A has been
C                     postmultiplied by diag(C);
C             = 'B':  Both row and column equilibration, i.e., A has
C                     been replaced by diag(R) * A * diag(C).
C             EQUED is an input argument if FACT = 'F'; otherwise, it is
C             an output argument.
C
C     R       (input or output) DOUBLE PRECISION array, dimension (N)
C             The row scale factors for A.  If EQUED = 'R' or 'B', A is
C             multiplied on the left by diag(R); if EQUED = 'N' or 'C',
C             R is not accessed.  R is an input argument if FACT = 'F';
C             otherwise, R is an output argument.  If FACT = 'F' and
C             EQUED = 'R' or 'B', each element of R must be positive.
C
C     C       (input or output) DOUBLE PRECISION array, dimension (N)
C             The column scale factors for A.  If EQUED = 'C' or 'B',
C             A is multiplied on the right by diag(C); if EQUED = 'N'
C             or 'R', C is not accessed.  C is an input argument if
C             FACT = 'F'; otherwise, C is an output argument.  If
C             FACT = 'F' and EQUED = 'C' or 'B', each element of C must
C             be positive.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             (LDB,NRHS)
C             On entry, the leading N-by-NRHS part of this array must
C             contain the right-hand side matrix B.
C             On exit,
C             if EQUED = 'N', B is not modified;
C             if TRANS = 'N' and EQUED = 'R' or 'B', the leading
C             N-by-NRHS part of this array contains diag(R)*B;
C             if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', the leading
C             N-by-NRHS part of this array contains diag(C)*B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
C             If INFO = 0 or INFO = N+1, the leading N-by-NRHS part of
C             this array contains the solution matrix X to the original
C             system of equations.  Note that A and B are modified on
C             exit if EQUED .NE. 'N', and the solution to the
C             equilibrated system is inv(diag(C))*X if TRANS = 'N' and
C             EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or
C             'C' and EQUED = 'R' or 'B'.
C
C     LDX     (input) INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     RCOND   (output) DOUBLE PRECISION
C             The estimate of the reciprocal condition number of the
C             matrix A after equilibration (if done).  If RCOND is less
C             than the machine precision (in particular, if RCOND = 0),
C             the matrix is singular to working precision.  This
C             condition is indicated by a return code of INFO > 0.
C             For efficiency reasons, RCOND is computed only when the
C             matrix A is factored, i.e., for FACT = 'N' or 'E'.  For
C             FACT = 'F', RCOND is not used, but it is assumed that it
C             has been computed and checked before the routine call.
C
C     FERR    (output) DOUBLE PRECISION array, dimension (NRHS)
C             The estimated forward error bound for each solution vector
C             X(j) (the j-th column of the solution matrix X).
C             If XTRUE is the true solution corresponding to X(j),
C             FERR(j) is an estimated upper bound for the magnitude of
C             the largest element in (X(j) - XTRUE) divided by the
C             magnitude of the largest element in X(j).  The estimate
C             is as reliable as the estimate for RCOND, and is almost
C             always a slight overestimate of the true error.
C
C     BERR    (output) DOUBLE PRECISION array, dimension (NRHS)
C             The componentwise relative backward error of each solution
C             vector X(j) (i.e., the smallest relative change in
C             any element of A or B that makes X(j) an exact solution).
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
C
C     DWORK   DOUBLE PRECISION array, dimension (4*N)
C             On exit, DWORK(1) contains the reciprocal pivot growth
C             factor norm(A)/norm(U). The "max absolute element" norm is
C             used. If DWORK(1) is much less than 1, then the stability
C             of the LU factorization of the (equilibrated) matrix A
C             could be poor. This also means that the solution X,
C             condition estimator RCOND, and forward error bound FERR
C             could be unreliable. If factorization fails with
C             0 < INFO <= N, then DWORK(1) contains the reciprocal pivot
C             growth factor for the leading INFO columns of A.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             > 0:  if INFO = i, and i is
C                   <= N:  U(i,i) is exactly zero.  The factorization
C                          has been completed, but the factor U is
C                          exactly singular, so the solution and error
C                          bounds could not be computed. RCOND = 0 is
C                          returned.
C                   = N+1: U is nonsingular, but RCOND is less than
C                          machine precision, meaning that the matrix is
C                          singular to working precision.  Nevertheless,
C                          the solution and error bounds are computed
C                          because there are a number of situations
C                          where the computed solution can be more
C                          accurate than the value of RCOND would
C                          suggest.
C             The positive values for INFO are set only when the
C             matrix A is factored, i.e., for FACT = 'N' or 'E'.
C
C     METHOD
C
C     The following steps are performed:
C
C     1. If FACT = 'E', real scaling factors are computed to equilibrate
C        the system:
C
C        TRANS = 'N':  diag(R)*A*diag(C)     *inv(diag(C))*X = diag(R)*B
C        TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
C        TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
C
C        Whether or not the system will be equilibrated depends on the
C        scaling of the matrix A, but if equilibration is used, A is
C        overwritten by diag(R)*A*diag(C) and B by diag(R)*B
C        (if TRANS='N') or diag(C)*B (if TRANS = 'T' or 'C').
C
C     2. If FACT = 'N' or 'E', the LU decomposition is used to factor
C        the matrix A (after equilibration if FACT = 'E') as
C           A = P * L * U,
C        where P is a permutation matrix, L is a unit lower triangular
C        matrix, and U is upper triangular.
C
C     3. If some U(i,i)=0, so that U is exactly singular, then the
C        routine returns with INFO = i. Otherwise, the factored form
C        of A is used to estimate the condition number of the matrix A.
C        If the reciprocal of the condition number is less than machine
C        precision, INFO = N+1 is returned as a warning, but the routine
C        still goes on to solve for X and compute error bounds as
C        described below.
C
C     4. The system of equations is solved for X using the factored form
C        of A.
C
C     5. Iterative refinement is applied to improve the computed
C        solution matrix and calculate error bounds and backward error
C        estimates for it.
C
C     6. If equilibration was used, the matrix X is premultiplied by
C        diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
C        that it solves the original system before equilibration.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., Sorensen, D.
C         LAPACK Users' Guide: Second Edition, SIAM, Philadelphia, 1995.
C
C     FURTHER COMMENTS
C
C     This is a simplified version of the LAPACK Library routine DGESVX,
C     useful when several sets of matrix equations with the same
C     coefficient matrix  A and/or A'  should be solved.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTORS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Apr. 1999.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Condition number, matrix algebra, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         EQUED, FACT, TRANS
      INTEGER           INFO, LDA, LDAF, LDB, LDX, N, NRHS
      DOUBLE PRECISION  RCOND
C     ..
C     .. Array Arguments ..
      INTEGER           IPIV( * ), IWORK( * )
      DOUBLE PRECISION  A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
     $                  BERR( * ), C( * ), DWORK( * ), FERR( * ),
     $                  R( * ), X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL           COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
      CHARACTER         NORM
      INTEGER           I, INFEQU, J
      DOUBLE PRECISION  AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
     $                  ROWCND, RPVGRW, SMLNUM
C     ..
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANTR
      EXTERNAL          LSAME, DLAMCH, DLANGE, DLANTR
C     ..
C     .. External Subroutines ..
      EXTERNAL          DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY,
     $                  DLAQGE, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C     ..
C     .. Save Statement ..
      SAVE              RPVGRW
C     ..
C     .. Executable Statements ..
C
      INFO = 0
      NOFACT = LSAME( FACT,  'N' )
      EQUIL  = LSAME( FACT,  'E' )
      NOTRAN = LSAME( TRANS, 'N' )
      IF( NOFACT .OR. EQUIL ) THEN
         EQUED = 'N'
         ROWEQU = .FALSE.
         COLEQU = .FALSE.
      ELSE
         ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
         COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         SMLNUM = DLAMCH( 'Safe minimum' )
         BIGNUM = ONE / SMLNUM
      END IF
C
C     Test the input parameters.
C
      IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
     $     THEN
         INFO = -1
      ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $                                LSAME( TRANS, 'C' ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
     $         ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
         INFO = -10
      ELSE
         IF( ROWEQU ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO 10 J = 1, N
               RCMIN = MIN( RCMIN, R( J ) )
               RCMAX = MAX( RCMAX, R( J ) )
   10       CONTINUE
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -11
            ELSE IF( N.GT.0 ) THEN
               ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               ROWCND = ONE
            END IF
         END IF
         IF( COLEQU .AND. INFO.EQ.0 ) THEN
            RCMIN = BIGNUM
            RCMAX = ZERO
            DO 20 J = 1, N
               RCMIN = MIN( RCMIN, C( J ) )
               RCMAX = MAX( RCMAX, C( J ) )
   20       CONTINUE
            IF( RCMIN.LE.ZERO ) THEN
               INFO = -12
            ELSE IF( N.GT.0 ) THEN
               COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
            ELSE
               COLCND = ONE
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( LDB.LT.MAX( 1, N ) ) THEN
               INFO = -14
            ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
               INFO = -16
            END IF
         END IF
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02PD', -INFO )
         RETURN
      END IF
C
      IF( EQUIL ) THEN
C
C        Compute row and column scalings to equilibrate the matrix A.
C
         CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
         IF( INFEQU.EQ.0 ) THEN
C
C           Equilibrate the matrix.
C
            CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
     $                   EQUED )
            ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
            COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
         END IF
      END IF
C
C     Scale the right hand side.
C
      IF( NOTRAN ) THEN
         IF( ROWEQU ) THEN
            DO 40 J = 1, NRHS
               DO 30 I = 1, N
                  B( I, J ) = R( I )*B( I, J )
   30          CONTINUE
   40       CONTINUE
         END IF
      ELSE IF( COLEQU ) THEN
         DO 60 J = 1, NRHS
            DO 50 I = 1, N
               B( I, J ) = C( I )*B( I, J )
   50       CONTINUE
   60    CONTINUE
      END IF
C
      IF( NOFACT .OR. EQUIL ) THEN
C
C        Compute the LU factorization of A.
C
         CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
         CALL DGETRF( N, N, AF, LDAF, IPIV, INFO )
C
C        Return if INFO is non-zero.
C
         IF( INFO.NE.0 ) THEN
            IF( INFO.GT.0 ) THEN
C
C              Compute the reciprocal pivot growth factor of the
C              leading rank-deficient INFO columns of A.
C
               RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
     $                  DWORK )
               IF( RPVGRW.EQ.ZERO ) THEN
                  RPVGRW = ONE
               ELSE
                  RPVGRW = DLANGE( 'M', N, INFO, A, LDA, DWORK ) /
     $                     RPVGRW
               END IF
               DWORK( 1 ) = RPVGRW
               RCOND = ZERO
            END IF
            RETURN
         END IF
C
C        Compute the norm of the matrix A and the
C        reciprocal pivot growth factor RPVGRW.
C
         IF( NOTRAN ) THEN
            NORM = '1'
         ELSE
            NORM = 'I'
         END IF
         ANORM = DLANGE( NORM, N, N, A, LDA, DWORK )
         RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, DWORK )
         IF( RPVGRW.EQ.ZERO ) THEN
            RPVGRW = ONE
         ELSE
            RPVGRW = DLANGE( 'M', N, N, A, LDA, DWORK ) / RPVGRW
         END IF
C
C        Compute the reciprocal of the condition number of A.
C
         CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, DWORK, IWORK,
     $                INFO )
C
C        Set INFO = N+1 if the matrix is singular to working precision.
C
         IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
     $      INFO = N + 1
      END IF
C
C     Compute the solution matrix X.
C
      CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
      CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
C
C     Use iterative refinement to improve the computed solution and
C     compute error bounds and backward error estimates for it.
C
      CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
     $             LDX, FERR, BERR, DWORK, IWORK, INFO )
C
C     Transform the solution matrix X to a solution of the original
C     system.
C
      IF( NOTRAN ) THEN
         IF( COLEQU ) THEN
            DO 80 J = 1, NRHS
               DO 70 I = 1, N
                  X( I, J ) = C( I )*X( I, J )
   70          CONTINUE
   80       CONTINUE
            DO 90 J = 1, NRHS
               FERR( J ) = FERR( J ) / COLCND
   90       CONTINUE
         END IF
      ELSE IF( ROWEQU ) THEN
         DO 110 J = 1, NRHS
            DO 100 I = 1, N
               X( I, J ) = R( I )*X( I, J )
  100       CONTINUE
  110    CONTINUE
         DO 120 J = 1, NRHS
            FERR( J ) = FERR( J ) / ROWCND
  120    CONTINUE
      END IF
C
      DWORK( 1 ) = RPVGRW
      RETURN
C
C *** Last line of MB02PD ***
      END


c=======================================================================
c
c     Asset Allocation Utilities Functions
c
c-----------------------------------------------------------------------
c
c        CTIT    : constraints modelling (ALLOCIT)
c        CTITCOV : quadratic part (ALLOCMVTC)
c        CTITCST : constraints modelling (ALLOCMVTC)
c        CTMV    : constraints modelling (ALLOCMV)
c        CTSR    : constraints modelling (ALLOCSR)
c        CTVOL   : constraints modelling (ALLOCVOL)
c        CTMVRFR : constraints modelling (ALLOCMVRFR)
c
c=======================================================================
c
c     subroutine CTIT
c
c     Computing constraints for ALLOCIT - Index Tracking allocation
c
c-----------------------------------------------------------------------
      SUBROUTINE ctit ( n, rhob, rho, covb,
     &                  delta, neq, nin, ccst, bcst,
     &                  neqtot, nintot, ccstot, bcstot, plin )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : portfolio size                             integer
c            rhob   : mean return of index                        double
c            rho    : mean returns (n)                            double
c            covb   : covariance assets/index (n)                 double
c            delta  : outperformance target                       double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : constraints matrix (n*(neq + nin))          double
c            bcst   : constraints vector (neq + nin)              double
c
c     OUTPUT
c            neqtot : number of equality constraints             integer
c            nintot : number of inequality constraints           integer
c            ccstot : constraints matrix (n*(neq + nin + 1))      double
c            bcstot : constraints vector (neq + nin + 1)          double
c            plin   : linear part (n)                             double
c
c     METHOD
c                 composition of ccstot, bcstot, plin
c         - ccstot
c           | neq | nin |      1      |  size
c            _________________________
c           |           |  -rho(1)    |
c           |           |     ..      |
c           |           |             |
c           |    ccst   |             |     n
c           |           |             |  ( w(i) )
c           |           |             |
c           |           |  -rho(n)    |
c           __________________________
c
c         - bcstot
c           | neq | nin |      1      |  size
c           __________________________
c           |    bcst   | -delta-rhob |   1
c           __________________________
c
c         - plin
c           |          n            |  size
c           ________________________
c           |      -covb            |   1
c           ________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION rhob, delta
      DOUBLE PRECISION rho(*), covb(*), bcst(*), bcstot(*), plin(*),
     &                 ccst(n,*), ccstot(n,*)
c
c     local variables
      INTEGER i, j, ncst
c
c-----------------------------------------------------------------------
c
c     initializations
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + 1
c
c     linear part
      DO i = 1,n
         plin(i) = -covb(i)
      ENDDO
c
c     case ncst = 0 (neq=0, nin=0)
      IF (ncst .EQ. 0) THEN
         DO i = 1,n
           ccstot(i, 1) = -rho(i)
         ENDDO
         bcstot(1) = -delta -rhob
         RETURN
      ENDIF
c
c     constraints matrix C*w <= b
      DO i = 1,n
         DO j = 1,ncst
            ccstot(i, j) = ccst(i, j)
         ENDDO
         ccstot(i, ncst+1) = -rho(i)
      ENDDO
c
c     constraints vector
      DO j = 1,ncst
         bcstot(j) = bcst(j)
      ENDDO
      bcstot(ncst+1) = -delta - rhob
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTITCST
c
c     Computing constraints (portfolio allocation with transactions costs)
c
c-----------------------------------------------------------------------
      SUBROUTINE ctitcst ( n, cost, neq, nin, ccst, bcst, wini,
     &                     neqtot, nintot, ccstot, bcstot, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of asset(s)                         integer
c            cost   : transaction cost (n)                        double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : matrix initial of constraints (n*(neq+nin)) double
c            bcst   : vector initial of constraints (neq+nin)     double
c            wini   : initial weight(s) (n)                       double
c
c     OUTPUT
c            neqtot : number of equality constraints             integer
c            nintot : number of inequality constraints           integer
c            ccstot : matrix of constraints (2n*(neq+nin+2n))     double
c            bcstot : vector of constraints (neq+nin+2n)          double
c            info   : diagnostic argument                         double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot, info
      DOUBLE PRECISION bcst(*), bcstot(*), wini(*), ccst(n,*),
     &                 ccstot(2*n,*), cost(*)
c
c     local variables
      INTEGER p, i, j, ncst, ncstot
      DOUBLE PRECISION a, zero
      PARAMETER (zero = 0.0)
c      INTEGER unit
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
      p    = n + n
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + n + n
c
c     total nb of constraints (C + cost transaction)
      ncstot = neqtot + nintot
c
c     constraints matrix initialization
      CALL IMX ( p, ncstot, ccstot, zero )
c      DO i = 1,p
c         DO j = 1,ncstot
c            ccstot(i , j) = 0.0
c         ENDDO
c      ENDDO
c
c     constraint C*w <= b
      IF (ncst .NE. 0) THEN
        DO i = 1,n
            DO j = 1,ncst
                ccstot(i, j) = ccst(i, j)
            ENDDO
        ENDDO
        DO j = 1,ncst
            bcstot(j) = bcst(j)
        ENDDO
      ENDIF
c
c     transaction cost constraints
      DO i = 1,n
        ccstot(i, ncst + i)         =  1.0
        ccstot(i + n, ncst + i)     = -1.0
        ccstot(i, ncst + n + i)     = -1.0
        ccstot(i + n, ncst + n + i) = -1.0

        bcstot(ncst + i)            =  wini(i)
        bcstot(ncst + n + i)        = -wini(i)
      ENDDO
      a=cost(1)
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTITCOV
c
c     Computing quadratic part for ALLOCMVTC
c     Index Tracking allocation with cost transaction
c
c-----------------------------------------------------------------------
      SUBROUTINE ctitcov ( n, cov, alpha, cost, gamma, info )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : number of asset(s)                         integer
c            cov    : covariance matrix (n*n)                     double
c            alpha  : cost transaction parameter                  double
c            cost   : cost transaction (n)                        double
c
c     OUTPUT
c            gamma  : new quadratic part (2n*2n)                  double
c            info   : diagnostic argument                        integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, info
      DOUBLE PRECISION alpha
      DOUBLE PRECISION cost(*), cov(n,*), gamma(n + n,*)
c
c     local variables
      INTEGER p, i, j
      DOUBLE PRECISION zero, eps
      PARAMETER (zero = 0.0, eps = 1.E-5)
c      INTEGER ioecr
c
c-----------------------------------------------------------------------
c
c     initialisations
      info = 0
      p    = n + n
c
c     construction of the quadratic part (matrix)
c
c     gamma = [cov        0        ]
c             [ 0   (alpha*cost)^2 ]
      CALL IMX ( p, p, gamma, zero )
c      DO i = 1,p
c        DO j = 1,p
c            gamma(i, j) = 0.0
c        ENDDO
c      ENDDO
      DO i = 1,n
        DO j = 1,n
            gamma(i, j) = cov(i, j)
        ENDDO
        gamma(n+i, n+i) = max(alpha*alpha*cost(i)*cost(i), n*eps)
      ENDDO
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTMV
c
c     Computing constraints for ALLOCMV - Mean Variance (Markowitz)
c
c-----------------------------------------------------------------------
      SUBROUTINE ctmv ( n, rho, mu, neq, nin, ccst, bcst,
     &                  neqtot, nintot, ccstot, bcstot, plin )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : portfolio size                             integer
c            rho    : mean returns (n)                            double
c            mu     : performance target                          double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : constraints matrix (n*(neq + nin))          double
c            bcst   : constraints vector (neq + nin)              double
c
c     OUTPUT
c            neqtot : number of equality constraints             integer
c            nintot : number of inequality constraints           integer
c            ccstot : matrix of constraints (n*(neq+nin+1))       double
c            bcstot : vector of constraints (neq+nin+1)           double
c            plin   : linear part (n)                             double
c
c     METHOD :
c                 composition of ccstot, bcstot, plin
c         - ccstot
c           |     neq   |   nin   | 1 |  size
c            _________________________
c           |                     |   |
c           |                     |   |
c           |                     | - |
c           |          ccst       | r |     n
c           |                     | h |  ( w(i) )
c           |                     | o |
c           |                     |   |
c           __________________________
c
c         - bcstot
c           |     neq   |   nin   | 1 |  size
c           __________________________
c           |          bcst       |-mu|   1
c           __________________________
c
c         - plin
c           |          n            |  size
c           ________________________
c           |            0          |   1
c           ________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION mu
      DOUBLE PRECISION rho(*), bcst(*), bcstot(*), plin(*),
     &                 ccst(n,*), ccstot(n,*)
c
c     local variables
      INTEGER i, j, ncst
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO = 0.D0)
c
c-----------------------------------------------------------------------
c
c     initialisations
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + 1
c
c     construction of the linear part
      CALL IVX ( n, plin, ZERO )
c
c     case ncst = 0 (neq=0, nin=0)
      IF (ncst .EQ. 0) THEN
         DO i = 1,n
            ccstot(i, 1) = -rho(i)
         ENDDO
         bcstot(1) = -mu
         RETURN
      ENDIF
c
c     constraints matrix
      DO i = 1,n
         DO j = 1,ncst
            ccstot(i,j) = ccst(i,j)
         ENDDO
         ccstot(i,ncst+1) = -rho(i)
      ENDDO
c
c     constraints vector
      DO j = 1,ncst
        bcstot(j) = bcst(j)
      ENDDO
      bcstot(ncst+1) = -mu
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTSR
c
c     Utility for OPSR (Max. Sharpe Ratio)
c
c-----------------------------------------------------------------------
      SUBROUTINE ctsr ( n, rho, rfr, neq, nin, ccst, bcst, cinf, csup,
     &                  neqtot, nintot, ccstot, bcstot)
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : size of portfolio                               integer
c       rho    : mean returns (n)                                 double
c       rfr    : risk-free rate                                   double
c       neq    : number of equality constraints                  integer
c       nin    : number of inequality constraints                integer
c       ccst   : matrix of constraints (n*(neq+nin))              double
c       bcst   : vector of constraints (neq+nin)                  double
c       cinf   : lower bounds (n)                                 double
c       csup   : upper bounds (n)                                 double
c
c     OUTPUT
c       neqtot : total number of equality constraints            integer
c       nintot : total number of inequality constraints          integer
c       ccstot : matrix of constraints
c               (n+1)*(2+2*n+nin)                                 double
c       bcstot : vector of constraints (2+2*n+nin)                double
c
c     METHOD
c
c         - ccstot
c           |(1)|   (1)  | (n)  |  (n)   |(nin) |    (size)
c            ____________________________________
c           | 1 | rho(1) |      |        |      |
c           | . | .      | -Id  |   Id   |  cst |   (n + 1)
c           | 1 | rho(n) |      |        |      |
c           |------------------------------------
c           |-1 | -rfr   | Cinf | -Csup  |  -b  |     (1)
c            ____________________________________
c
c         - bcstot
c           |(1)|   (1)  | (n)  |  (n)   |(nin) |    (size)
c           _____________________________________
c           | 0 |    1   |  0   |   0    |  0   |     (1)
c           _____________________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION rfr
      DOUBLE PRECISION rho(*), bcst(*), bcstot(*), cinf(*), csup(*),
     &                 ccst(n,*), ccstot(n+1,*)
c
c     local variables
      INTEGER i, j, p, ncst
c
c-----------------------------------------------------------------------
c
c     number of variables
      p = n + 1
c
c     nb of equality and inequality constraints
      neqtot = 2
      nintot = nin + 2*n
c
c     total number of constaints
      ncst   = neqtot + nintot
c
c     construction of the constraints matrix
      DO i = 1,n
         ccstot(i, 1) = 1
         ccstot(i, 2) = rho(i)
         IF (nin .GT. 0) THEN
            DO j = 1,nin
                ccstot(i, neqtot + j) = ccst(i,neq + j)
            ENDDO
         ENDIF
         DO j = 1,n
            ccstot(i, neqtot + nin + j)     = 0.
            ccstot(i, neqtot + nin + n + j) = 0.
            IF (i .EQ. j) THEN
                ccstot(i, neqtot + nin + j)     = -1.0
                ccstot(i, neqtot + nin + n + j) =  1.0
            ENDIF
         ENDDO
      ENDDO
c
      ccstot(p, 1) = -1.0
      ccstot(p, 2) = -rfr
      IF (nin .GT. 0) THEN
        DO j = 1,nin
            ccstot(p, neqtot + j) = -bcst(neq + j)
        ENDDO
      ENDIF
      DO j = 1,n
        ccstot(p, neqtot + nin + j)     =  cinf(j)
        ccstot(p, neqtot + nin + n + j) = -csup(j)
      ENDDO
c
c     construction of the constraints vector
      bcstot(1) = 0.0
      bcstot(2) = 1.0
      IF (nin .GT. 0) THEN
        DO j = 1,nin
            bcstot(neqtot + j) = 0.
        ENDDO
      ENDIF
      DO j = 1,(2*n)
        bcstot(neqtot + nin + j) = 0.
      ENDDO
c
      RETURN
      END
c
c
c=======================================================================
c
c     subroutine CTVOL
c
c     Computing constraints for ALLOCVOL
c
c-----------------------------------------------------------------------
      SUBROUTINE ctvol ( n, rho, mu, neq, nin, ccst, bcst,
     &                   neqtot, nintot, ccstot, bcstot, plin )
c-----------------------------------------------------------------------
c
c     INPUT
c            n      : portfolio size                             integer
c            rho    : mean returns (n)                            double
c            mu     : performance target                          double
c            neq    : number of initial equality constraints     integer
c            nin    : number of initial inequality constraints   integer
c            ccst   : constraints matrix (n*(neq + nin))          double
c            bcst   : constraints vector (neq + nin)              double
c
c     OUTPUT
c            neqtot : number of equality constraints             integer
c            nintot : number of inequality constraints           integer
c            ccstot : matrix of constraints (n*(neq+nin+1))       double
c            bcstot : vector of constraints (neq+nin+1)           double
c            plin   : linear part (n)                             double
c
c     METHOD :
c                 composition of ccstot, bcstot, plin
c         - ccstot
c           | 1 |    neq   |   nin   | 1 |  size
c            __________________________
c           | 1 |                  |   |
c           |   |                  |   |
c           | . |                  | - |
c           | . |       ccst       | r |     n
c           | . |                  | h |  ( w(i) )
c           |   |                  | o |
c           | 1 |                  |   |
c           ___________________________
c
c         - bcstot
c           | 1 |    neq   |   nin   | 1 |  size
c           _____________________________
c           | 1 |         bcst       |-mu|   1
c           _____________________________
c
c         - plin
c           |          n            |  size
c           ________________________
c           |          0            |   1
c           ________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION mu
      DOUBLE PRECISION rho(*), bcst(*), bcstot(*), plin(*),
     &                 ccst(n,*), ccstot(n,*)
c
c     local variables
      INTEGER i, j, ncst, ncsttot
c
c-----------------------------------------------------------------------
c
c     initialisations
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + 1
      ncsttot = neqtot + nintot
c
c     construction of the linear part (equal zero)
      DO i = 1,n
         plin(i) = 0.0
      ENDDO
c
c     constraints: w'*rho >= mu
      IF (ncst .EQ. 0) THEN
c        case ncst = 0 (neq=0, nin=0)
         DO i = 1,n
            ccstot(i, 1) = -rho(i)
         ENDDO
         bcstot(1) = -mu
         RETURN
      ENDIF
c
c     general case ncst <> 0
      DO i = 1,n
        DO j = 1,ncst
            ccstot(i, j) = ccst(i, j)
        ENDDO
        ccstot(i,ncst+1) = -rho(i)
      ENDDO
c
c     constraints vector
      DO j = 1,ncst
        bcstot(j) = bcst(j)
      ENDDO
      bcstot(ncst+1) = -mu
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTMVRFR
c
c     Computing constraints with risk-free rate
c
c-----------------------------------------------------------------------
      SUBROUTINE ctmvrfr ( n, rho, rfr, mu, neq, nin, ccst, bcst,
     &                     cinfrfr, csuprfr,
     &                     neqtot, nintot, ccstot, bcstot, plin )
c-----------------------------------------------------------------------
c
c     INPUT
c       n      : portfolio size                                  integer
c       rho    : expected mean returns (n)                        double
c       rfr    : risk-free rate                                   double
c       mu     : performance target                               double
c       neq    : number of initial equality constraints          integer
c       nin    : number of initial inequality constraints        integer
c       ccst   : constraints matrix (n*(neq + nin))               double
c       bcst   : constraints vector (neq + nin)                   double
c       cinfrfr: risk-free rate lower bound                       double
c       csuprfr: risk-free rate upper bound                       double
c
c     OUTPUT
c       neqtot : number of equality constraints                  integer
c       nintot : number of inequality constraints                integer
c       ccstot : matrix of constraints (n*(neq+nin+3))            double
c       bcstot : vector of constraints (neq+nin+3)                double
c       plin   : linear part (n)                                  double
c
c     METHOD : composition of ccstot, bcstot, plin
c         - ccstot
c           |     neq   |   nin   | 1 | 1 |  1 | size
c            __________________________________
c           |                     |   | 1 | -1 |
c           |                     |   | . |  . |
c           |                     | - | . |  . |
c           |          ccst       | r | . |  . |  n
c           |                     | h | . |  . |
c           |                     | o | . |  . |
c           |                     |   | 1 | -1 |
c           ____________________________________
c
c         - bcstot
c           | neq | nin | 1 |     1     |     1     |   size
c           _________________________________________
c           |   bcst    |-mu| 1-Cinfrfr | Csuprfr-1 |    1
c           _________________________________________
c
c         - plin
c           |          n            |  size
c           ________________________
c           |          0            |   1
c           ________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION mu, rfr, cinfrfr, csuprfr
      DOUBLE PRECISION rho(*), bcst(*), bcstot(*), plin(*),
     &                 ccst(n,*), ccstot(n,*)
c
c     local variables
      INTEGER i, j, ncst
      DOUBLE PRECISION ZERO, EPS
      PARAMETER (ZERO = 0.D0, EPS = 1.E-8)
c
c-----------------------------------------------------------------------
c
c     initialisations
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + 3
c
c     construction of the linear part
      CALL IVX (n, plin, ZERO)

c     case ncst <> 0 (neq=0, nin=0)
c      IF (ncst .NE. 0) THEN
c        DO i = 1,n
c            DO j = 1,ncst
c                ccstot(i, j) = ccst(i, j)
c            ENDDO
c        ENDDO
c        DO j = 1,ncst
c            bcstot(j) = bcst(j)
c        ENDDO
c      ENDIF
c     matrix constraint
c      DO i = 1,n
c        ccstot(i, ncst + 1) =  rfr - rho(i)
c        ccstot(i, ncst + 2) =  1.0
c        ccstot(i, ncst + 3) = -1.0
c      ENDDO
c        bcstot(ncst + 1) = rfr - mu
c        bcstot(ncst + 2) = 1.0 - cinfrfr + EPS
c        bcstot(ncst + 3) = csuprfr - 1.0 + EPS
c
c
c     case ncst = 0 (neq=0, nin=0)
      IF (ncst .EQ. 0) THEN
         DO i = 1,n
            ccstot(i, 1) =  rfr - rho(i)
            ccstot(i, 2) =  1.0
            ccstot(i, 3) = -1.0
         ENDDO
         bcstot(1) = rfr - mu
         bcstot(2) = 1.0 - cinfrfr + EPS
         bcstot(3) = csuprfr - 1.0 + EPS
         RETURN
      ENDIF
c
c     constraints matrix
      DO i = 1,n
         DO j = 1,ncst
            ccstot(i, j) = ccst(i, j)
         ENDDO
         ccstot(i,ncst + 1) =  rfr - rho(i)
         ccstot(i,ncst + 2) =  1.0
         ccstot(i,ncst + 3) = -1.0
      ENDDO
c
c     constraints vector
      DO j = 1,ncst
        bcstot(j) = bcst(j)
      ENDDO
      bcstot(ncst+1) = rfr - mu
      bcstot(ncst+2) = 1.0 - cinfrfr + EPS
      bcstot(ncst+3) = csuprfr - 1.0 + EPS
c
      RETURN
      END
c
c=======================================================================
c
c     subroutine CTITRFR
c
c     Computing constraints for ALLOCITRFR - Index Tracking allocation
c
c-----------------------------------------------------------------------
      SUBROUTINE ctitrfr ( n, rhob, rho, covb,
     &                     delta, neq, nin, ccst, bcst,
     &                     cinfrfr, csuprfr,
     &                     neqtot, nintot, ccstot, bcstot, plin )
c-----------------------------------------------------------------------
c
c     INPUT
c       n       : portfolio size                                 integer
c       rhob    : mean return of index                            double
c       rho     : mean returns (n)                                double
c       covb    : covariance assets/index (n)                     double
c       delta   : outperformance target                           double
c       neq     : number of initial equality constraints         integer
c       nin     : number of initial inequality constraints       integer
c       ccst    : constraints matrix (n*(neq + nin))              double
c       bcst    : constraints vector (neq + nin)                  double
c       cinfrfr : risk-free rate lower bound                      double
c       csuprfr : risk-free rate upper bound                      double
c
c     OUTPUT
c       neqtot  : number of equality constraints                 integer
c       nintot  : number of inequality constraints               integer
c       ccstot  : constraints matrix (n*(neq + nin + 3))          double
c       bcstot  : constraints vector (neq + nin + 3)              double
c       plin    : linear part (n)                                 double
c
c     METHOD
c                 composition of ccstot, bcstot, plin
c         - ccstot
c           | neq | nin |      1      |  size
c            _________________________
c           |           |  -rho(1)    |
c           |           |     ..      |
c           |           |             |
c           |    ccst   |             |     n
c           |           |             |  ( w(i) )
c           |           |             |
c           |           |  -rho(n)    |
c           __________________________
c
c         - bcstot
c           | neq | nin |      1      |  size
c           __________________________
c           |    bcst   | -delta-rhob |   1
c           __________________________
c
c         - plin
c           |          n            |  size
c           ________________________
c           |      -covb            |   1
c           ________________________
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER n, neq, nin, neqtot, nintot
      DOUBLE PRECISION rhob, delta, cinfrfr, csuprfr
      DOUBLE PRECISION rho(*), covb(*), bcst(*), bcstot(*), plin(*),
     &                 ccst(n,*), ccstot(n,*)
c
c     local variables
      INTEGER i, j, ncst
      DOUBLE PRECISION ZERO, EPS
      PARAMETER (ZERO = 0.D0, EPS = 1.E-8)
c
c-----------------------------------------------------------------------
c
c     initializations
      ncst = neq + nin
c
c     nb of equality and inequality constraints
      neqtot = neq
      nintot = nin + 3
c
c     linear part
      DO i = 1,n
         plin(i) = -covb(i)
      ENDDO
c
c     case ncst <> 0 (neq=0, nin=0)
      IF (ncst .NE. 0) THEN
        DO i = 1,n
            DO j = 1,ncst
                ccstot(i, j) = ccst(i, j)
            ENDDO
        ENDDO
        DO j = 1,ncst
            bcstot(j) = bcst(j)
        ENDDO
c        CALL YM ( n, ncst, ccst, ccstot ) ! constraint matrix
c        CALL YV ( ncst, bcst, bcstot )    ! constraint vector
      ENDIF
c     matrix constraint
      DO i = 1,n
        ccstot(i, ncst + 1)=  -rho(i)
        ccstot(i, ncst + 2) =  1.0
        ccstot(i, ncst + 3) = -1.0
      ENDDO
      bcstot(ncst + 1) = -delta - rhob
      bcstot(ncst + 2) = 1.0 - cinfrfr + EPS
      bcstot(ncst + 3) = csuprfr - 1.0 + EPS
c
      RETURN
      END


! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

!> @brief compute time steps table delta_time
!> @param[in] ismpl local sample index
!> @details
!> Compute the time steps table delta time. \n\n
!>
!> Linear: dt(j) = (tend-tstart)/n \n\n
!>
!> Logarithmic: dt(j) = tunit * (10**(j/n*((tstart-tend)/tunit + 1)) -
!> 1) \n\n
!>
!> Varied logarithmic (tstart needs to be non-zero): dt(j) = tstart *
!> (10**(j/n * tend/tstart) - 10**((j-1)/n * tend/tstart)) \n\n
!>
!> Logarithmic decreasing: dt(j) = tunit *
!> (10**((n-j)/n*((tstart-tend)/tunit + 1)) - 1) \n\n
subroutine calc_deltatime(ismpl)

  use arrays, only: delta_time
  use mod_genrl, only: memory
  use mod_time, only: nperiod, ntimestep, tunit, iperiod, dperiod

  implicit none

  ! local sample index
  integer :: ismpl

  ! Counter: overall time step
  integer :: it

  ! Number of time steps in current time periods
  integer :: nstep

  ! Counters: Period, time step of current period
  integer :: iper, istep

  ! Logarithmic factor, used in logarithmic time stepping
  double precision :: facl

  ! End (t1) and start (t0) time of time step
  double precision :: t1, t0

  ! Re-allocate delta_time to total number of time periods
  deallocate(delta_time)
  memory = memory - 1
  allocate(delta_time(ntimestep))
  memory = memory + ntimestep

  ! Set intitial time period counter
  it = 0

  ! Loop over time periods
  do iper = 1, nperiod

    ! Number of time steps in current time periods
    nstep = iperiod(iper,1)

    ! Compute time steps according to type
    if (iperiod(iper,2) == 1) then
      ! type: linear

      do istep = 1, nstep
        it = it + 1
        delta_time(it) = (dperiod(iper,2) - dperiod(iper,1)) / dble(nstep)
      end do

    else if (iperiod(iper,2) == 2) then
      ! type: logarithmically increasing

      facl = log10((dperiod(iper,2) - dperiod(iper,1))/tunit + 1.D0) / dble(nstep)

      t0 = dperiod(iper,1)
      do istep = 1, nstep
        it = it + 1
        t1 = dperiod(iper,1) + tunit * 10.0d0**(dble(istep) * facl) - tunit
        delta_time(it) = t1 - t0
        t0 = t1
      end do

    else if (iperiod(iper,2)==3) then
      ! type: varied logarithmically increasing

      if (dperiod(iper,1) <= 0.0d0) then
        write(unit = *, fmt = *) 'error (read_time.f90): ',&
            'No varied Log with starting time 0.0d0'
        stop 1
      end if

      facl = log10(dperiod(iper,2) / dperiod(iper,1)) / dble(nstep)

      t0 = dperiod(iper,1)
      do istep = 1, nstep
        it = it + 1
        t1 = dperiod(iper,1) * 10.0d0**(dble(istep) * facl)
        delta_time(it) = t1 - t0
        t0 = t1
      end do

    else if (iperiod(iper,2)==-2) then
      ! type: logarithmically decreasing

      facl = log10((dperiod(iper,2) - dperiod(iper,1))/tunit + 1.0d0) / dble(nstep)

      t0 = dperiod(iper,2)
      do istep = nstep - 1, 0, -1
        it = it + 1
        t1 = dperiod(iper,1) + tunit * 10.0d0**(dble(istep) * facl) - tunit
        delta_time(it) = t0 - t1
        t0 = t1
      end do

    else
      write(*,'(1A,1I2,1A,1I2,1A)') &
          'error: wrong time step type ', iperiod(iper,2), ' at ', iper, &
          ' in "read_time.f" !'
      stop

    end if

  end do

  ! Sanity check: Total number of time steps
  if (it /= ntimestep) then
    write(*,'(1A)') 'error: lost some time steps in "read_time.f" !'
    stop
  end if

  return

end subroutine calc_deltatime


!> \file depth2press.f90
!! \BRIEF
!> Module with depth2press subroutine - converts depth to pressure
!! with Saunders (1981) formula
MODULE mdepth2press
CONTAINS
!>     Compute pressure [db] from depth [m] & latitude [degrees north].
!!     This subroutine is needed because p80 is a function (using scalars not arrays)
SUBROUTINE depth2press(depth, lat, pdbar, N)

  !     Purpose:
  !     Compute pressure [db] from depth [m] & latitude [degrees north].
  !     Needed because p80 is a function

  USE msingledouble
  USE mp80
  IMPLICIT NONE

  !> number of records
!f2py intent(hide) n
  INTEGER, intent(in) :: N

! INPUT variables
  !> depth [m]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: depth
  !> latitude [degrees]
  REAL(kind=rx), INTENT(in), DIMENSION(N) :: lat

! OUTPUT variables:
  !> pressure [db]
  REAL(kind=rx), INTENT(out), DIMENSION(N) :: pdbar

  !     Local variables
  INTEGER :: i

! REAL(kind=rx) ::  p80
! EXTERNAL p80

  DO i = 1,N
     pdbar(i) = p80(depth(i), lat(i))
  END DO

  RETURN
END SUBROUTINE depth2press
END MODULE mdepth2press


c======================================================================
c
c     subroutine  CHECKSDLSINEQ
c
c     Test SDLS inequalities constraints
c
c----------------------------------------------------------------------
      SUBROUTINE checksdlsineq ( nmat, cmat, mcti, acti, lcti, ucti,
     &                           dwork, info)
c----------------------------------------------------------------------
c
c     INPUT
c            nmat   : dimension of the matrix                    integer
c            cmat   : symmetric matrix(nmat*nmat) to optimize     double
c            mcti   : number of inequal constraints              integer
c            acti   : mcti Bi symmetric matrices(nmat*nmat) of
c                     inequal constraints  vector(mcti*nmat*nmat) double
c            lcti   : lower bounds of inequal constraints
c                     vector(mcti)                                double
c            ucti   : upper bounds of inequal constraints
c                     vector(mcti)                                double
c
c     WORKSPACE:
c            dwork  : double workspace (nmat*nmat)                double
c
c     OUTPUT
c            info   : diagnostic argument                         integer
c
c     CALL
c        PMC : squared matrix product
c        TM  : matrix trace
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nmat, mcti, info
      DOUBLE PRECISION cmat(nmat,*), acti(*), lcti(*), ucti(*)
c
c     local variables
      INTEGER i, sm, ksai
      DOUBLE PRECISION EPS, trace
c
c     Workspace
      DOUBLE PRECISION dwork(*)
      INTEGER pdmac
c
      PARAMETER(EPS = 1.E-5 )
c
c-----------------------------------------------------------------------
c
      pdmac = 1
c     pointer on a matrix needs nmat * nmat
c     double workspace nmat * nmat
c
      sm = nmat*nmat
      ksai = 1
      DO i=1,mcti
        CALL PMC (nmat, acti(ksai), cmat, dwork(pdmac))
        CALL TM (nmat, dwork(pdmac), trace)
        IF ((trace .lt. lcti(i)-EPS) .or.
     &    (trace .gt. ucti(i)+EPS)) THEN
            info = -1110
            RETURN
        ENDIF
        ksai = ksai + sm
      ENDDO
c
      RETURN
      END


module fcn_convecting_vortex
#include <messenger.h>
    use mod_kinds,      only: rk,ik
    use mod_constants,  only: ZERO, HALF, ONE, TWO, THREE, FIVE, EIGHT, PI
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use type_function,  only: function_t
    use DNAD_D
    implicit none
    private

    !>  This function defines an analytical solution to the 2D Euler equations.
    !!  It may be used to provide initial conditions for an unsteady simulation,
    !!  as well as to compute numerical errors.
    !!
    !!  This solution is implemented as in Fidkowski 2016
    !!
    !!  @author Eric Wolf
    !!  @date   2/15/2017
    !!
    !!
    !-------------------------------------------------------------------------------
    type, extends(function_t), public :: convecting_vortex_f
        private

        real(rk)    :: rho = ONE
        real(rk)    :: p   = ONE

        real(rk)    :: gam  = 1.4_rk
        real(rk)    :: vortex_strength = 0.3_rk !vortex strength
        real(rk)    :: rc = 1.5_rk !vortex size

        real(rk)    :: x0 = 5.0_rk
        real(rk)    :: y0 = 5.0_rk
        real(rk)    :: z0 = 0.0_rk

        real(rk)    :: uinf = TWO/sqrt(FIVE)
        real(rk)    :: vinf = ONE/sqrt(FIVE)
        real(rk)    :: winf = ZERO

        real(rk)    :: rhoinf = ONE
        real(rk)    :: pinf = 20.0_rk/7.0_rk

        integer(ik) :: ivar

    contains

        procedure   :: init
        procedure   :: compute

    end type convecting_vortex_f
    !********************************************************************************

contains

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !-------------------------------------------------------------------------
    subroutine init(self)
        class(convecting_vortex_f),  intent(inout)  :: self

        !
        ! Set function name
        !
        !self%name = "isentropic vortex  ::  weeeee!"
        call self%set_name("convecting_vortex")

        call self%add_option('ivar', 1._rk)

        !
        ! Set function options to default settings
        !
!        call self%dict%set('uinf',2._rk/sqrt(5._rk))
!        call self%dict%set('vinf',1._rk/sqrt(5._rk))
!        call self%dict%set('winf',0._rk)
!        call self%dict%set('Minf',1._rk*sqrt(
!        call self%dict%set('beta',0._rk)
!        call self%dict%set('xo',1._rk)
!        call self%dict%set('yo',1._rk)
!        call self%dict%set('zo',1._rk)
!

    end subroutine init
    !*************************************************************************

    !>
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/2/2016
    !!
    !!
    !-----------------------------------------------------------------------------------------
    impure elemental function compute(self,time,coord) result(val)
        class(convecting_vortex_f),     intent(inout)  :: self
        real(rk),                       intent(in)  :: time
        type(point_ad_t),               intent(in)  :: coord

        type(AD_D)                                  :: val
        integer(ik)                                 :: ivar

        type(AD_D)  :: x, y , z, dx, dy, r, f0, f1, f2, u, v, rho, &
                       p
        real(rk)    :: du, dv, w , gam, Minf, speedinf

        x = coord%c1_
        y = coord%c2_
        z = coord%c3_

        gam = self%gam
        speedinf = sqrt(self%uinf**TWO + self%vinf**TWO)
        Minf = speedinf*sqrt(self%rhoinf/(gam*self%pinf))

        dx = x - self%x0 - self%uinf*time
        dy = y - self%y0 - self%vinf*time
        r = sqrt(dx**TWO + dy**TWO)

        f0 = ONE - r**TWO/self%rc**TWO
        f1 = ONE - self%vortex_strength**TWO*(gam-ONE)*Minf**TWO*exp(f0)/(8._rk*PI**TWO)
        f2 = speedinf*self%vortex_strength*exp(f0/TWO)/(TWO*PI*self%rc)

        u = self%uinf - f2*dy
        v = self%vinf + f2*dx
        w  = ZERO

        rho = self%rhoinf*f1**(ONE/(gam-ONE))
        p = self%pinf*f1**(gam/(gam-ONE))

        ivar = nint(self%get_option_value('ivar'))
        select case (ivar)
            ! RHO
            case (1)
                val = rho

            ! RHO-U
            case (2)
                val = rho*u

            ! RHO-V
            case (3)
                val = rho*v

            ! RHO-W
            case (4)
                val = rho*w

            ! RHO-E
            case (5)
                val = p/(gam-ONE)  +  HALF*rho*(u*u + v*v + w*w)

        end select

    end function compute
    !**********************************************************************************

end module fcn_convecting_vortex


!*==dlasdq.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b DLASDQ computes the SVD of a real bidiagonal matrix with diagonal d and off-diagonal e. Used by sbdsdc.
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLASDQ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
!                          U, LDU, C, LDC, WORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          UPLO
!       INTEGER            INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   C( LDC, * ), D( * ), E( * ), U( LDU, * ),
!      $                   VT( LDVT, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> DLASDQ computes the singular value decomposition (SVD) of a real
!> (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
!> E, accumulating the transformations if desired. Letting B denote
!> the input bidiagonal matrix, the algorithm computes orthogonal
!> matrices Q and P such that B = Q * S * P**T (P**T denotes the transpose
!> of P). The singular values S are overwritten on D.
!>
!> The input matrix U  is changed to U  * Q  if desired.
!> The input matrix VT is changed to P**T * VT if desired.
!> The input matrix C  is changed to Q**T * C  if desired.
!>
!> See "Computing  Small Singular Values of Bidiagonal Matrices With
!> Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
!> LAPACK Working Note #3, for a detailed description of the algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>        On entry, UPLO specifies whether the input bidiagonal matrix
!>        is upper or lower bidiagonal, and whether it is square are
!>        not.
!>           UPLO = 'U' or 'u'   B is upper bidiagonal.
!>           UPLO = 'L' or 'l'   B is lower bidiagonal.
!> \endverbatim
!>
!> \param[in] SQRE
!> \verbatim
!>          SQRE is INTEGER
!>        = 0: then the input matrix is N-by-N.
!>        = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
!>             (N+1)-by-N if UPLU = 'L'.
!>
!>        The bidiagonal matrix has
!>        N = NL + NR + 1 rows and
!>        M = N + SQRE >= N columns.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>        On entry, N specifies the number of rows and columns
!>        in the matrix. N must be at least 0.
!> \endverbatim
!>
!> \param[in] NCVT
!> \verbatim
!>          NCVT is INTEGER
!>        On entry, NCVT specifies the number of columns of
!>        the matrix VT. NCVT must be at least 0.
!> \endverbatim
!>
!> \param[in] NRU
!> \verbatim
!>          NRU is INTEGER
!>        On entry, NRU specifies the number of rows of
!>        the matrix U. NRU must be at least 0.
!> \endverbatim
!>
!> \param[in] NCC
!> \verbatim
!>          NCC is INTEGER
!>        On entry, NCC specifies the number of columns of
!>        the matrix C. NCC must be at least 0.
!> \endverbatim
!>
!> \param[in,out] D
!> \verbatim
!>          D is DOUBLE PRECISION array, dimension (N)
!>        On entry, D contains the diagonal entries of the
!>        bidiagonal matrix whose SVD is desired. On normal exit,
!>        D contains the singular values in ascending order.
!> \endverbatim
!>
!> \param[in,out] E
!> \verbatim
!>          E is DOUBLE PRECISION array.
!>        dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
!>        On entry, the entries of E contain the offdiagonal entries
!>        of the bidiagonal matrix whose SVD is desired. On normal
!>        exit, E will contain 0. If the algorithm does not converge,
!>        D and E will contain the diagonal and superdiagonal entries
!>        of a bidiagonal matrix orthogonally equivalent to the one
!>        given as input.
!> \endverbatim
!>
!> \param[in,out] VT
!> \verbatim
!>          VT is DOUBLE PRECISION array, dimension (LDVT, NCVT)
!>        On entry, contains a matrix which on exit has been
!>        premultiplied by P**T, dimension N-by-NCVT if SQRE = 0
!>        and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
!> \endverbatim
!>
!> \param[in] LDVT
!> \verbatim
!>          LDVT is INTEGER
!>        On entry, LDVT specifies the leading dimension of VT as
!>        declared in the calling (sub) program. LDVT must be at
!>        least 1. If NCVT is nonzero LDVT must also be at least N.
!> \endverbatim
!>
!> \param[in,out] U
!> \verbatim
!>          U is DOUBLE PRECISION array, dimension (LDU, N)
!>        On entry, contains a  matrix which on exit has been
!>        postmultiplied by Q, dimension NRU-by-N if SQRE = 0
!>        and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
!> \endverbatim
!>
!> \param[in] LDU
!> \verbatim
!>          LDU is INTEGER
!>        On entry, LDU  specifies the leading dimension of U as
!>        declared in the calling (sub) program. LDU must be at
!>        least max( 1, NRU ) .
!> \endverbatim
!>
!> \param[in,out] C
!> \verbatim
!>          C is DOUBLE PRECISION array, dimension (LDC, NCC)
!>        On entry, contains an N-by-NCC matrix which on exit
!>        has been premultiplied by Q**T  dimension N-by-NCC if SQRE = 0
!>        and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
!> \endverbatim
!>
!> \param[in] LDC
!> \verbatim
!>          LDC is INTEGER
!>        On entry, LDC  specifies the leading dimension of C as
!>        declared in the calling (sub) program. LDC must be at
!>        least 1. If NCC is nonzero, LDC must also be at least N.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is DOUBLE PRECISION array, dimension (4*N)
!>        Workspace. Only referenced if one of NCVT, NRU, or NCC is
!>        nonzero, and if N is at least 2.
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>        On exit, a value of 0 indicates a successful exit.
!>        If INFO < 0, argument number -INFO is illegal.
!>        If INFO > 0, the algorithm did not converge, and INFO
!>        specifies how many superdiagonals did not converge.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup OTHERauxiliary
!
!> \par Contributors:
!  ==================
!>
!>     Ming Gu and Huan Ren, Computer Science Division, University of
!>     California at Berkeley, USA
!>
!  =====================================================================
      SUBROUTINE DLASDQ(Uplo,Sqre,N,Ncvt,Nru,Ncc,D,E,Vt,Ldvt,U,Ldu,C,   &
     &                  Ldc,Work,Info)
      IMPLICIT NONE
!*--DLASDQ215
!
!  -- LAPACK auxiliary routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      CHARACTER Uplo
      INTEGER Info , Ldc , Ldu , Ldvt , N , Ncc , Ncvt , Nru , Sqre
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION C(Ldc,*) , D(*) , E(*) , U(Ldu,*) , Vt(Ldvt,*) , &
     &                 Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO
      PARAMETER (ZERO=0.0D+0)
!     ..
!     .. Local Scalars ..
      LOGICAL rotate
      INTEGER i , isub , iuplo , j , np1 , sqre1
      DOUBLE PRECISION cs , r , smin , sn
!     ..
!     .. External Subroutines ..
      EXTERNAL DBDSQR , DLARTG , DLASR , DSWAP , XERBLA
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      EXTERNAL LSAME
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      iuplo = 0
      IF ( LSAME(Uplo,'U') ) iuplo = 1
      IF ( LSAME(Uplo,'L') ) iuplo = 2
      IF ( iuplo==0 ) THEN
         Info = -1
      ELSEIF ( (Sqre<0) .OR. (Sqre>1) ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -3
      ELSEIF ( Ncvt<0 ) THEN
         Info = -4
      ELSEIF ( Nru<0 ) THEN
         Info = -5
      ELSEIF ( Ncc<0 ) THEN
         Info = -6
      ELSEIF ( (Ncvt==0 .AND. Ldvt<1) .OR. (Ncvt>0 .AND. Ldvt<MAX(1,N)) &
     &         ) THEN
         Info = -10
      ELSEIF ( Ldu<MAX(1,Nru) ) THEN
         Info = -12
      ELSEIF ( (Ncc==0 .AND. Ldc<1) .OR. (Ncc>0 .AND. Ldc<MAX(1,N)) )   &
     &         THEN
         Info = -14
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('DLASDQ',-Info)
         RETURN
      ENDIF
      IF ( N==0 ) RETURN
!
!     ROTATE is true if any singular vectors desired, false otherwise
!
      rotate = (Ncvt>0) .OR. (Nru>0) .OR. (Ncc>0)
      np1 = N + 1
      sqre1 = Sqre
!
!     If matrix non-square upper bidiagonal, rotate to be lower
!     bidiagonal.  The rotations are on the right.
!
      IF ( (iuplo==1) .AND. (sqre1==1) ) THEN
         DO i = 1 , N - 1
            CALL DLARTG(D(i),E(i),cs,sn,r)
            D(i) = r
            E(i) = sn*D(i+1)
            D(i+1) = cs*D(i+1)
            IF ( rotate ) THEN
               Work(i) = cs
               Work(N+i) = sn
            ENDIF
         ENDDO
         CALL DLARTG(D(N),E(N),cs,sn,r)
         D(N) = r
         E(N) = ZERO
         IF ( rotate ) THEN
            Work(N) = cs
            Work(N+N) = sn
         ENDIF
         iuplo = 2
         sqre1 = 0
!
!        Update singular vectors if desired.
!
         IF ( Ncvt>0 ) CALL DLASR('L','V','F',np1,Ncvt,Work(1),Work(np1)&
     &                            ,Vt,Ldvt)
      ENDIF
!
!     If matrix lower bidiagonal, rotate to be upper bidiagonal
!     by applying Givens rotations on the left.
!
      IF ( iuplo==2 ) THEN
         DO i = 1 , N - 1
            CALL DLARTG(D(i),E(i),cs,sn,r)
            D(i) = r
            E(i) = sn*D(i+1)
            D(i+1) = cs*D(i+1)
            IF ( rotate ) THEN
               Work(i) = cs
               Work(N+i) = sn
            ENDIF
         ENDDO
!
!        If matrix (N+1)-by-N lower bidiagonal, one additional
!        rotation is needed.
!
         IF ( sqre1==1 ) THEN
            CALL DLARTG(D(N),E(N),cs,sn,r)
            D(N) = r
            IF ( rotate ) THEN
               Work(N) = cs
               Work(N+N) = sn
            ENDIF
         ENDIF
!
!        Update singular vectors if desired.
!
         IF ( Nru>0 ) THEN
            IF ( sqre1==0 ) THEN
               CALL DLASR('R','V','F',Nru,N,Work(1),Work(np1),U,Ldu)
            ELSE
               CALL DLASR('R','V','F',Nru,np1,Work(1),Work(np1),U,Ldu)
            ENDIF
         ENDIF
         IF ( Ncc>0 ) THEN
            IF ( sqre1==0 ) THEN
               CALL DLASR('L','V','F',N,Ncc,Work(1),Work(np1),C,Ldc)
            ELSE
               CALL DLASR('L','V','F',np1,Ncc,Work(1),Work(np1),C,Ldc)
            ENDIF
         ENDIF
      ENDIF
!
!     Call DBDSQR to compute the SVD of the reduced real
!     N-by-N upper bidiagonal matrix.
!
      CALL DBDSQR('U',N,Ncvt,Nru,Ncc,D,E,Vt,Ldvt,U,Ldu,C,Ldc,Work,Info)
!
!     Sort the singular values into ascending order (insertion sort on
!     singular values, but only one transposition per singular vector)
!
      DO i = 1 , N
!
!        Scan for smallest D(I).
!
         isub = i
         smin = D(i)
         DO j = i + 1 , N
            IF ( D(j)<smin ) THEN
               isub = j
               smin = D(j)
            ENDIF
         ENDDO
         IF ( isub/=i ) THEN
!
!           Swap singular values and vectors.
!
            D(isub) = D(i)
            D(i) = smin
            IF ( Ncvt>0 ) CALL DSWAP(Ncvt,Vt(isub,1),Ldvt,Vt(i,1),Ldvt)
            IF ( Nru>0 ) CALL DSWAP(Nru,U(1,isub),1,U(1,i),1)
            IF ( Ncc>0 ) CALL DSWAP(Ncc,C(isub,1),Ldc,C(i,1),Ldc)
         ENDIF
      ENDDO
!
!
!     End of DLASDQ
!
      END SUBROUTINE DLASDQ


SUBROUTINE SetupCompDomain
USE GlobalVariables
IMPLICIT NONE
! By Allan P. Engsig-Karup.
REAL(KIND=long), DIMENSION(:,:), POINTER :: x, y
REAL(KIND=long), DIMENSION(:), POINTER   :: z
INTEGER :: i, j, k, Nx, Ny, Nz

Nx = FineGrid%Nx
Ny = FineGrid%Ny
Nz = FineGrid%Nz

! Allocate space for physical grids and ghost point layers
ALLOCATE(FineGrid%x(Nx+2*GhostGridX,Ny+2*GhostGridY))
ALLOCATE(FineGrid%y(Nx+2*GhostGridX,Ny+2*GhostGridY))
ALLOCATE(FineGrid%z(Nz+GhostGridZ))

! TEMPORARY POINTERS/VARIABLES
x => FineGrid%x
y => FineGrid%y
z => FineGrid%z

! ALLOCATE BATHYMETRY DATA
ALLOCATE(FineGrid%h(Nx+2*GhostGridX,Ny+2*GhostGridY))
!IF (Nx>1) THEN
  ALLOCATE(FineGrid%hx(Nx+2*GhostGridX,Ny+2*GhostGridY))
  ALLOCATE(FineGrid%hxx(Nx+2*GhostGridX,Ny+2*GhostGridY))
!ENDIF
!IF (Ny>1) THEN
  ALLOCATE(FineGrid%hy(Nx+2*GhostGridX,Ny+2*GhostGridY))
  ALLOCATE(FineGrid%hyy(Nx+2*GhostGridX,Ny+2*GhostGridY))
!ENDIF

! Define fine grid
IF (Nx==1) THEN
	x(1,1:Ny+2*GhostGridY) = Lx;
ELSE
	SELECT CASE (GridX)
		CASE (0) ! Even Grid
			DO i = -GhostGridX,Nx-1+GhostGridX
			   x(i+1+GhostGridX,1:Ny+2*GhostGridY) = REAL(i,long)/REAL((Nx-1),long)*Lx;
			END DO
		CASE DEFAULT
			PRINT *,'Error: Specified grid for x-direction invalid.'
			STOP
	END SELECT
ENDIF
IF (Ny==1) THEN
	y(1:Nx+2*GhostGridX,1) = Ly;
ELSE
	SELECT CASE (GridY)
		CASE (0) ! Even Grid
			DO i = -GhostGridY,Ny-1+GhostGridY
 			   y(1:Nx+2*GhostGridX,i+1+GhostGridY) = REAL(i,long)/REAL((Ny-1),long)*Ly;
			END DO
		CASE DEFAULT
			PRINT *,'Error: Specified grid for y-direction invalid.'
			STOP
	END SELECT
END IF
! Define fine grid
SELECT CASE (GridZ)
	CASE (0) ! Even Grid
		DO i = 0,Nz-1
		   z(i+1+GhostGridZ) = REAL(i,long)/REAL((Nz-1),long)*Lz;
		END DO
	CASE (1) ! Uneven Grid
		DO i = 0,Nz-1
			z(i+1+GhostGridZ) = SIN(pi*REAL(i,long)/REAL(2*(Nz-1),long))
		END DO
	CASE DEFAULT
		PRINT *,'Error: Specified grid for z-direction invalid.'
		STOP
END SELECT
IF (GhostGridZ==1) THEN
	! include ghost point below bottom. Reflect point just above bottom symmetrically
	! to ghost point by reflection about z=0
	z(1)=-z(3)
ENDIF
! Allocate array for coefficients involving sigma and its derivatives
! to be used in defining the transformed laplace problem.
ALLOCATE(FineGrid%dsigmanew(Nz+GhostGridZ,Nx+2*GhostGridX,Ny+2*GhostGridY,5))
FineGrid%dsigmanew=zero
END SUBROUTINE SetupCompDomain


! Module contains various global constants

module globals
        use netcdf
        use, intrinsic :: iso_c_binding
        implicit none
        ! N must be even
        integer :: N
        integer :: n_k, num_steps
        integer :: tstep
        integer :: cont=0
        integer :: hypervis = 0 ! hyperviscosity
        real(kind=8) :: t_final=50.0_8

        real(kind=8), parameter :: pi=3.14159265358979323846264338328_8
        real(kind=8) :: Fh, Re, Sc=1.0_8
        real(kind=8) :: Rev !hyperviscosity variable
        real(kind=8) :: L
        real(kind=8) :: tpiL
!        character(len=8) :: Lstr='5.0'
!        real(kind=8), parameter :: L=5.0
!        real(kind=8), parameter :: tpiL=2.0_8*pi/L
        real(kind=8) :: dx, dy
        real(kind=8), parameter :: dt=0.0005_8
        real(kind=8) :: t=0.0_8, en, prev_en, ukz
        real(kind=8) :: dealias_coeff=2.0/3.0
        complex(kind=8), parameter :: ii=(0.0_8,1.0_8)

        real(kind=8), dimension(:), allocatable :: growth_rate(:),tote(:)
        real(kind=8), dimension(:,:), allocatable :: X,Y
        complex(kind=8), dimension(:,:), allocatable :: kx,ky,kz,k_sq,kinv_sq,cut,ifactor,t_ifactor
        complex(kind=8), dimension(:,:), allocatable :: exp_ifactor_1
        complex(kind=8), dimension(:,:), allocatable :: exp_ifactor_2
        complex(kind=8), dimension(:,:), allocatable :: p11,p12,p13,p21,p22,p23,p31,p32,p33
        complex(kind=8), dimension(:,:), allocatable :: om_i,u_0,v_0
        complex(kind=8), dimension(:,:), allocatable :: uu_hat_temp,vv_hat_temp,ww_hat_temp
        complex(kind=8), dimension(:,:), allocatable :: iuu_hat_new,ivv_hat_new,iww_hat_new,irho_hat_new
        complex(kind=8), dimension(:,:), allocatable :: rr,ur,vr,wr
        complex(kind=8), dimension(:,:), allocatable :: rr_old,ur_old,vr_old,wr_old
        complex(C_DOUBLE_COMPLEX), pointer :: uu(:,:), vv(:,:), ww(:,:), rho(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: om1(:,:),om2(:,:),om3(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: r1(:,:),r2(:,:),r3(:,:),r4(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: A_1(:,:),B_1(:,:),C_1(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: uu_hat(:,:), vv_hat(:,:), ww_hat(:,:), rho_hat(:,:)
        complex(C_DOUBLE_COMPLEX), dimension(:,:), allocatable :: iuu_hat(:,:),ivv_hat(:,:), iww_hat(:,:), irho_hat(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: om1_hat(:,:),om2_hat(:,:),om3_hat(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: r1_hat(:,:), r2_hat(:,:),r3_hat(:,:),r4_hat(:,:)
        complex(C_DOUBLE_COMPLEX), pointer :: A_1_hat(:,:), B_1_hat(:,:),C_1_hat(:,:)
        type(C_PTR) :: up,vp,wp,rhop,uq,vq,wq,rhoq,funcp,funcq,om1hp,om2hp,om3hp,om1p,om2p,om3p
        type(C_PTR) :: rp1,rp2,rp3,rp4,rp1_hat,rp2_hat,rp3_hat,rp4_hat
        type(C_PTR) :: A1p,B1p,C1p,A1p_hat,B1p_hat,C1p_hat

end module globals


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE TRNSFM (X,Y,XO,YO,NC)
C
C     ******************************************************************
C
C     SUBROUTINE TO TRANSFORM POLAR CCORDINATES TO CARTESIAN COORDINATES
C
C     ******************************************************************
C
      DIMENSION X(*), Y(*)
C
C     ******************************************************************
C
      PI=ATAN(1.0)/45.
C
      DO 10 I=1,NC
      R=X(I)
      ANG=Y(I)*PI
      IF (R.EQ.0.) GO TO 10
      X(I)=XO+R*COS(ANG)
      Y(I)=YO+R*SIN(ANG)
   10 CONTINUE
C
      RETURN
      END