module barotropic_mode
  use io
  use vorticity
  use boundaries
  use enforce_thickness

  implicit none

  contains

  ! ---------------------------------------------------------------------------
  !> Calculate the barotropic u velocity

  subroutine calc_baro_u(ub, u, h, eta, freesurfFac, xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    double precision, intent(out) :: ub(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: u(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: h(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: eta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: freesurfFac
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer i, j, k
    double precision h_temp(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)

    ub = 0d0

    h_temp = h
    ! add free surface elevation to the upper layer
    h_temp(:, :, 1) = h(:, :, 1) + eta*freesurfFac

    do k = 1, layers
      do j = ylow-OL+1, yhigh+OL-1
        do i = xlow-OL+1, xhigh+OL
          ub(i,j) = ub(i,j) + u(i,j,k)*(h_temp(i,j,k)+h_temp(i-1,j,k))/2d0
        end do
      end do
    end do

    return
  end subroutine calc_baro_u

  ! ---------------------------------------------------------------------------
  !> Calculate the barotropic v velocity

  subroutine calc_baro_v(vb, v, h, eta, freesurfFac, xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    double precision, intent(out) :: vb(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: v(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: h(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)  :: eta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: freesurfFac
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer i, j, k
    double precision h_temp(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)

    vb = 0d0

    h_temp = h
    ! add free surface elevation to the upper layer
    h_temp(:, :, 1) = h(:, :, 1) + eta*freesurfFac

    do k = 1, layers
      do j = ylow-OL+1, yhigh+OL
        do i = xlow-OL+1, xhigh+OL-1
          vb(i,j) = vb(i,j) + v(i,j,k)*(h_temp(i,j,k)+h_temp(i,j-1,k))/2d0
        end do
      end do
    end do

    return
  end subroutine calc_baro_v

  ! ---------------------------------------------------------------------------
  !> Calculate the free surface anomaly using the velocities
  !! timestepped with the tendencies excluding the free surface
  !! pressure gradient.

  subroutine calc_eta_star(ub, vb, eta, etastar, &
      freesurfFac, xlow, xhigh, ylow, yhigh, OL, dx, dy, dt)
    implicit none

    double precision, intent(in)  :: ub(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: vb(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: eta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(out) :: etastar(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)  :: freesurfFac
    integer,          intent(in)  :: xlow, xhigh, ylow, yhigh, OL
    double precision, intent(in)  :: dx, dy, dt

    integer i, j

    etastar = 0d0

    do j = ylow-OL+1, yhigh+OL-1
      do i = xlow-OL+1, xhigh+OL-1
        etastar(i,j) = freesurfFac*eta(i,j) - &
            dt*((ub(i+1,j) - ub(i,j))/dx + (vb(i,j+1) - vb(i,j))/dy)
      end do
    end do

    ! call wrap_fields_2D(etastar, nx, ny, OL)

    return
  end subroutine calc_eta_star

  ! ---------------------------------------------------------------------------
  !> Use the successive over-relaxation algorithm to solve the backwards
  !! Euler timestepping for the free surface anomaly, or for the surface
  !! pressure required to keep the barotropic flow nondivergent.

  subroutine SOR_solver(a, etanew, etastar, nx, ny, OL, dt, &
      rjac, eps, maxits, n)
    implicit none

    double precision, intent(in)  :: a(5, nx, ny)
    double precision, intent(out) :: etanew(1-OL:nx+OL, 1-OL:ny+OL)
    double precision, intent(inout)  :: etastar(1-OL:nx+OL, 1-OL:ny+OL)
    integer, intent(in) :: nx, ny, OL
    double precision, intent(in) :: dt
    double precision, intent(in) :: rjac, eps
    integer, intent(in) :: maxits, n

    integer i, j, nit
    double precision rhs(nx, ny)
    double precision res(nx, ny)
    double precision norm, norm0
    double precision relax_param

    call wrap_fields_2D(etastar, nx, ny, OL)

    rhs = -etastar(1:nx,1:ny)/dt**2
    ! first guess for etanew
    etanew = etastar

    relax_param = 1.d0 ! successive over-relaxation parameter

    ! Calculate initial residual, so that we can stop the loop when the
    ! current residual = norm0*eps
    norm0 = 0.d0
    do i = 1, nx
      do j = 1, ny
        res(i,j) = &
            a(1,i,j)*etanew(i+1,j) &
            + a(2,i,j)*etanew(i,j+1) &
            + a(3,i,j)*etanew(i-1,j) &
            + a(4,i,j)*etanew(i,j-1) &
            + a(5,i,j)*etanew(i,j)   &
            - rhs(i,j)
        norm0 = norm0 + abs(res(i,j))
        etanew(i,j) = etanew(i,j)-relax_param*res(i,j)/a(5,i,j)
      end do
    end do

    do nit = 1, maxits
      norm = 0.d0
      do i = 1, nx
        do j = 1, ny
          res(i,j) = &
              a(1,i,j)*etanew(i+1,j) &
              + a(2,i,j)*etanew(i,j+1) &
              + a(3,i,j)*etanew(i-1,j) &
              + a(4,i,j)*etanew(i,j-1) &
              + a(5,i,j)*etanew(i,j)   &
              - rhs(i,j)
          norm = norm + abs(res(i,j))
          etanew(i,j) = etanew(i,j)-relax_param*res(i,j)/(a(5,i,j))
        end do
      end do
      if (nit.eq.1) then
        relax_param = 1.d0/(1.d0-0.5d0*rjac**2)
      else
        relax_param = 1.d0/(1.d0-0.25d0*rjac**2*relax_param)
      end if

      call wrap_fields_2D(etanew, nx, ny, OL)

      if (nit.gt.1.and.norm.lt.eps*norm0) then

        return

      end if
    end do

    write(17, "(A, I0)") 'Warning: maximum SOR iterations exceeded at time step ', n

    return
  end subroutine SOR_solver

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

  subroutine create_Hypre_grid(MPI_COMM_WORLD, hypre_grid, ilower, iupper, &
            num_procs, myid, nx, ny, ierr)
    implicit none

    integer,   intent(in)  :: MPI_COMM_WORLD
    integer*8, intent(out) :: hypre_grid
    integer,   intent(in)  :: ilower(0:num_procs-1,2)
    integer,   intent(in)  :: iupper(0:num_procs-1,2)
    integer,   intent(in)  :: num_procs
    integer,   intent(in)  :: myid
    integer,   intent(in)  :: nx
    integer,   intent(in)  :: ny
    integer,   intent(out)  :: ierr

#ifdef useExtSolver
    call Hypre_StructGridCreate(MPI_COMM_WORLD, 2, hypre_grid, ierr)

    call HYPRE_StructGridSetExtents(hypre_grid, ilower(myid,:),iupper(myid,:), ierr)

    call HYPRE_StructGridSetPeriodic(hypre_grid, [nx, ny], ierr)

    call HYPRE_StructGridAssemble(hypre_grid, ierr)
#endif

    return
  end subroutine create_Hypre_grid

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

  subroutine create_Hypre_A_matrix(MPI_COMM_WORLD, hypre_grid, hypre_A, &
            a, xlow, xhigh, ylow, yhigh, ierr)
    implicit none

    integer,          intent(in)  :: MPI_COMM_WORLD
    integer*8,        intent(in)  :: hypre_grid
    integer*8,        intent(out) :: hypre_A
    double precision, intent(in)  :: a(5, xlow:xhigh, ylow:yhigh)
    integer,          intent(in)  :: xlow, xhigh, ylow, yhigh
    integer,          intent(out) :: ierr

    ! Hypre stencil for creating the A matrix
    integer*8 :: stencil

    integer :: offsets(2,5)
    integer :: indicies(2)
    integer :: i, j

#ifdef useExtSolver

    ! Define the geometry of the stencil.  Each represents a relative
    ! offset (in the index space).
    offsets(1,1) =  0
    offsets(2,1) =  0
    offsets(1,2) = -1
    offsets(2,2) =  0
    offsets(1,3) =  1
    offsets(2,3) =  0
    offsets(1,4) =  0
    offsets(2,4) = -1
    offsets(1,5) =  0
    offsets(2,5) =  1

    call HYPRE_StructStencilCreate(2, 5, stencil, ierr)
    ! this gives a 2D, 5 point stencil centred around the grid point of interest.
    do i = 0, 4
      call HYPRE_StructStencilSetElement(stencil, i, offsets(:,i+1),ierr)
    end do

    call HYPRE_StructMatrixCreate(MPI_COMM_WORLD, hypre_grid, stencil, hypre_A, ierr)

    call HYPRE_StructMatrixInitialize(hypre_A, ierr)

    do i = xlow, xhigh
      do j = ylow, yhigh
        indicies(1) = i
        indicies(2) = j

        call HYPRE_StructMatrixSetValues(hypre_A, &
            indicies, 1, 0, &
            a(5,i,j), ierr)
        call HYPRE_StructMatrixSetValues(hypre_A, &
            indicies, 1, 1, &
            a(3,i,j), ierr)
        call HYPRE_StructMatrixSetValues(hypre_A, &
            indicies, 1, 2, &
            a(1,i,j), ierr)
        call HYPRE_StructMatrixSetValues(hypre_A, &
            indicies, 1, 3, &
            a(4,i,j), ierr)
        call HYPRE_StructMatrixSetValues(hypre_A, &
            indicies, 1, 4, &
            a(2,i,j), ierr)
      end do
    end do

    call HYPRE_StructMatrixAssemble(hypre_A, ierr)

    call MPI_Barrier(MPI_COMM_WORLD, ierr)

#endif

    return
  end subroutine create_Hypre_A_matrix

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

  subroutine Ext_solver(MPI_COMM_WORLD, hypre_A, hypre_grid, myid, num_procs, &
      ilower, iupper, etastar, &
      etanew, nx, ny, xlow, xhigh, ylow, yhigh, OL, dt, maxits, eps, ierr)
    implicit none

    integer,          intent(in)  :: MPI_COMM_WORLD
    integer*8,        intent(in)  :: hypre_A
    integer*8,        intent(in)  :: hypre_grid
    integer,          intent(in)  :: myid
    integer,          intent(in)  :: num_procs
    integer,          intent(in)  :: ilower(0:num_procs-1,2)
    integer,          intent(in)  :: iupper(0:num_procs-1,2)
    double precision, intent(in)  :: etastar(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(out) :: etanew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    integer,          intent(in)  :: nx, ny, xlow, xhigh, ylow, yhigh, OL
    double precision, intent(in)  :: dt
    integer,          intent(in)  :: maxits
    double precision, intent(in)  :: eps
    integer,          intent(out) :: ierr

    integer          :: i, j ! loop variables
    integer*8        :: hypre_b
    integer*8        :: hypre_x
    integer*8        :: hypre_solver
    integer*8        :: precond
    double precision :: b_values((xhigh-xlow+1)*(yhigh-ylow+1))
    double precision :: init_values((xhigh-xlow+1)*(yhigh-ylow+1))
    double precision :: final_values((xhigh-xlow+1)*(yhigh-ylow+1))

    integer :: nx_tile, ny_tile
    integer :: i_local, j_local

        ! A currently unused variable that can be used to
    ! print information from the solver - see comments below.
   ! double precision :: hypre_out(2)

    nx_tile = xhigh-xlow + 1
    ny_tile = yhigh-ylow + 1

    ! wrap this code in preprocessing flags to allow the model to be compiled without the external library, if desired.
#ifdef useExtSolver
    ! Create the rhs vector, b
    call HYPRE_StructVectorCreate(MPI_COMM_WORLD, hypre_grid, hypre_b, ierr)
    call HYPRE_StructVectorInitialize(hypre_b, ierr)

    ! set rhs values (vector b)
    do j = ylow, yhigh ! loop over every grid point
      do i = xlow, xhigh

          i_local = i - xlow
          j_local = j - ylow

     ! the 2D array is being laid out like
     ! [x1y1, x2y1, x3y1, x1y2, x2y2, x3y2, x1y3, x2y3, x3y3]

          b_values(i_local &
                     + j_local*(xhigh - xlow + 1) &
                     + 1) = -etastar(i,j)/dt**2

          init_values(i_local &
                     + j_local*(xhigh - xlow + 1) &
                     + 1) = etastar(i,j)

    ! the 2D array is being laid out like
    ! [x1y1, x2y1, x3y1, x1y2, x2y2, x3y2, x1y3, x2y3, x3y3]
      end do
    end do

    call HYPRE_StructVectorSetBoxValues(hypre_b, &
      ilower(myid,:), iupper(myid,:), b_values, ierr)

    call HYPRE_StructVectorAssemble(hypre_b, ierr)

    ! now create the x vector
    call HYPRE_StructVectorCreate(MPI_COMM_WORLD, hypre_grid, hypre_x, ierr)
    call HYPRE_StructVectorInitialize(hypre_x, ierr)

    call HYPRE_StructVectorSetBoxValues(hypre_x, &
      ilower(myid,:), iupper(myid,:), init_values, ierr)

    call HYPRE_StructVectorAssemble(hypre_x, ierr)

    ! now create the solver and solve the equation.
    ! Choose the solver
    call HYPRE_StructPCGCreate(MPI_COMM_WORLD, hypre_solver, ierr)

    ! Set some parameters
    call HYPRE_StructPCGSetMaxIter(hypre_solver, maxits, ierr)
    call HYPRE_StructPCGSetTol(hypre_solver, eps, ierr)
    ! other options not explained by user manual but present in examples
    ! call HYPRE_StructPCGSetMaxIter(hypre_solver, 50 );
    ! call HYPRE_StructPCGSetTol(hypre_solver, 1.0e-06 );
    call HYPRE_StructPCGSetTwoNorm(hypre_solver, 1 );
    call HYPRE_StructPCGSetRelChange(hypre_solver, 0 );
    call HYPRE_StructPCGSetPrintLevel(hypre_solver, 1 ); ! 2 will print each CG iteration
    call HYPRE_StructPCGSetLogging(hypre_solver, 1);

    ! use an algebraic multigrid preconditioner
    call HYPRE_BoomerAMGCreate(precond, ierr)
    ! values taken from hypre library example number 5
    ! print less solver info since a preconditioner
    call HYPRE_BoomerAMGSetPrintLevel(precond, 1, ierr);
    ! Falgout coarsening
    call HYPRE_BoomerAMGSetCoarsenType(precond, 6, ierr)
    ! old defaults
    call HYPRE_BoomerAMGSetOldDefault(precond, ierr)
    ! SYMMETRIC G-S/Jacobi hybrid relaxation
    call HYPRE_BoomerAMGSetRelaxType(precond, 6, ierr)
    ! Sweeeps on each level
    call HYPRE_BoomerAMGSetNumSweeps(precond, 1, ierr)
    ! conv. tolerance
    call HYPRE_BoomerAMGSetTol(precond, 0.0d0, ierr)
    ! do only one iteration!
    call HYPRE_BoomerAMGSetMaxIter(precond, 1, ierr)

    ! set amg as the pcg preconditioner
    call HYPRE_StructPCGSetPrecond(hypre_solver, 2, precond, ierr)

    ! now we set the system up and do the actual solve!
    call HYPRE_StructPCGSetup(hypre_solver, hypre_A, hypre_b, &
                              hypre_x, ierr)

    call HYPRE_ParCSRPCGSolve(hypre_solver, hypre_A, hypre_b, &
                              hypre_x, ierr)

    ! code for printing out results from the external solver
    ! Not being used, but left here since the manual isn't very helpful
    ! and this may be useful in the future.
    ! call HYPRE_ParCSRPCGGetNumIterations(hypre_solver, &
    !   hypre_out(1), ierr)

    ! print *, 'num iterations = ', hypre_out(1)

    ! call HYPRE_ParCSRPCGGetFinalRelative(hypre_solver, &
    !   hypre_out(2), ierr)
    ! print *, 'final residual norm = ', hypre_out(2)

    call HYPRE_StructVectorGetBoxValues(hypre_x, &
      ilower(myid,:), iupper(myid,:), final_values, ierr)

    do j = ylow, yhigh ! loop over every grid point
      do i = xlow, xhigh
        ! etanew(i,j) = final_values( ((j-1)*nx_tile + i) )
          i_local = i - xlow
          j_local = j - ylow

     ! the 2D array is being laid out like
     ! [x1y1, x2y1, x3y1, x1y2, x2y2, x3y2, x1y3, x2y3, x3y3]

          etanew(i,j) = final_values(i_local &
                                     + j_local*(xhigh - xlow + 1) &
                                     + 1)

      end do
    end do

    ! debugging commands from hypre library - dump out a single
    ! copy of these two variables. Can be used to check that the
    ! values have been properly allocated.
    ! call HYPRE_StructVectorPrint(hypre_x, ierr)
    ! call HYPRE_StructMatrixPrint(hypre_A, ierr)

    call HYPRE_StructPCGDestroy(hypre_solver, ierr)
    call HYPRE_BoomerAMGDestroy(precond, ierr)
    call HYPRE_StructVectorDestroy(hypre_x, ierr)
    call HYPRE_StructVectorDestroy(hypre_b, ierr)

#endif

    return
  end subroutine Ext_solver

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

  !> Update velocities using the barotropic tendency due to the pressure
  !> gradient.

  subroutine update_velocities_for_barotropic_tendency(array, etanew, g_vec, &
      xstep, ystep, dspace, dt, xlow, xhigh, ylow, yhigh, layers, OL)
    implicit none

    double precision, intent(inout) :: array(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in) :: etanew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in) :: g_vec(layers)
    integer, intent(in) :: xstep, ystep
    double precision, intent(in) :: dspace, dt
    integer, intent(in) :: xlow, xhigh, ylow, yhigh, layers, OL

    integer i, j, k
    double precision baro_contrib

    ! TODO Assert that xstep and ystep are either 1, 0 or 0, 1.

    do k = 1, layers
      do j = ylow-OL+ystep, yhigh+OL-1
        do i = xlow-OL+xstep, xhigh+OL-1

          baro_contrib = &
              -g_vec(1)*(etanew(i,j) - etanew(i-xstep,j-ystep))/(dspace)
          array(i,j,k) = array(i,j,k) + dt*baro_contrib
        end do
      end do
    end do

    return
  end subroutine update_velocities_for_barotropic_tendency

  ! ---------------------------------------------------------------------------
  !> Compute derivatives of the depth field for the pressure solver

  subroutine calc_A_matrix(a, depth, g, dx, dy, OL, &
            xlow, xhigh, ylow, yhigh, freesurfFac, dt, &
            hfacW, hfacE, hfacS, hfacN)
    implicit none

    double precision, intent(out) :: a(5, xlow:xhigh, ylow:yhigh)
    double precision, intent(in)  :: depth(xlow-OL:xhigh+OL, &
                                            ylow-OL:yhigh+OL)
    double precision, intent(in)  :: g, dx, dy
    integer,          intent(in)  :: OL, xlow, xhigh, ylow, yhigh
    double precision, intent(in)  :: freesurfFac
    double precision, intent(in)  :: dt
    double precision, intent(in)  :: hfacW(xlow-OL:xhigh+OL, &
                                            ylow-OL:yhigh+OL)
    double precision, intent(in)  :: hfacE(xlow-OL:xhigh+OL, &
                                            ylow-OL:yhigh+OL)
    double precision, intent(in)  :: hfacN(xlow-OL:xhigh+OL, &
                                            ylow-OL:yhigh+OL)
    double precision, intent(in)  :: hfacS(xlow-OL:xhigh+OL, &
                                            ylow-OL:yhigh+OL)

    integer i, j

    do j = ylow, yhigh
      do i = xlow, xhigh
        a(1,i,j) = g*0.5*(depth(i+1,j)+depth(i,j))*hfacE(i,j)/dx**2
        a(2,i,j) = g*0.5*(depth(i,j+1)+depth(i,j))*hfacN(i,j)/dy**2
        a(3,i,j) = g*0.5*(depth(i,j)+depth(i-1,j))*hfacW(i,j)/dx**2
        a(4,i,j) = g*0.5*(depth(i,j)+depth(i,j-1))*hfacS(i,j)/dy**2
      end do
    end do

    do j = ylow, yhigh
      do i = xlow, xhigh
        a(5,i,j) = -a(1,i,j)-a(2,i,j)-a(3,i,j)-a(4,i,j) - freesurfFac/dt**2
      end do
    end do

    return
  end subroutine calc_A_matrix

  ! ---------------------------------------------------------------------------
  !> Do the isopycnal layer physics

  subroutine barotropic_correction(hnew, unew, vnew, eta, etanew, depth, a, &
      dx, dy, wetmask, hfacW, hfacS, dt, &
      maxits, eps, rjac, freesurfFac, thickness_error, &
      debug_level, g_vec, nx, ny, layers, OL, &
      xlow, xhigh, ylow, yhigh, &
      n, MPI_COMM_WORLD, myid, num_procs, ilower, iupper, &
      hypre_grid, hypre_A, ierr)

    implicit none

    double precision, intent(inout) :: hnew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: unew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(inout) :: vnew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL, layers)
    double precision, intent(in)    :: eta(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(out)   :: etanew(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)    :: depth(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)    :: a(5, nx, ny)
    double precision, intent(in)    :: dx, dy
    double precision, intent(in)    :: wetmask(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)    :: hfacW(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)    :: hfacS(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision, intent(in)    :: dt
    integer,          intent(in)    :: maxits
    double precision, intent(in)    :: eps, rjac, freesurfFac, thickness_error
    integer,          intent(in)    :: debug_level
    double precision, intent(in)    :: g_vec(layers)
    integer,          intent(in)    :: nx, ny, layers, OL
    integer,          intent(in)    :: xlow, xhigh, ylow, yhigh, n
    integer,          intent(in)    :: MPI_COMM_WORLD
    integer,          intent(in)    :: myid, num_procs
    integer,          intent(in)    :: ilower(0:num_procs-1,2)
    integer,          intent(in)    :: iupper(0:num_procs-1,2)
    integer*8,        intent(in)    :: hypre_grid
    integer*8,        intent(in)    :: hypre_A
    integer,          intent(out) :: ierr

    ! barotropic velocity components (for pressure solver)
    double precision :: ub(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision :: vb(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)
    double precision :: etastar(xlow-OL:xhigh+OL, ylow-OL:yhigh+OL)

    character(10)    :: num

    ! Calculate the barotropic velocities
    call calc_baro_u(ub, unew, hnew, eta, freesurfFac, xlow, xhigh, ylow, yhigh, &
                      layers, OL)
    call calc_baro_v(vb, vnew, hnew, eta, freesurfFac, xlow, xhigh, ylow, yhigh, &
                      layers, OL)

    if (debug_level .ge. 4) then
      ! Output the data to a file
      call write_output_3d(ub, nx, ny, 1, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 1, 0, &
                          n, 'output/snap.ub.', num_procs, myid)

      call write_output_3d(vb, nx, ny, 1, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 0, 1, &
                          n, 'output/snap.vb.', num_procs, myid)
    end if

    ! Calculate divergence of ub and vb, and solve for the pressure
    ! field that removes it
    call calc_eta_star(ub, vb, eta, etastar, freesurfFac, &
                    xlow, xhigh, ylow, yhigh, OL, dx, dy, dt)
    ! print *, maxval(abs(etastar))
    if (debug_level .ge. 4) then
      call write_output_3d(etastar, nx, ny, 1, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 0, 0, &
                          n, 'output/snap.eta_star.', num_procs, myid)
    end if

    ! Prevent barotropic signals from bouncing around outside the
    ! wet region of the model.
    ! etastar = etastar*wetmask
#ifndef useExtSolver
    ! this call IS NOT PARALLEL SAFE
    ! It has been left with global indicies, since it only works on one core.
    if (num_procs .ne. 1) then
      print "(A)", "SOR solver can only be used on one core."
      call clean_stop(n, .FALSE.)
    end if
    call SOR_solver(a, etanew, etastar, nx, ny, OL, &
       dt, rjac, eps, maxits, n)
    ! print *, maxval(abs(etanew))
#endif

#ifdef useExtSolver
    call Ext_solver(MPI_COMM_WORLD, hypre_A, hypre_grid, myid, num_procs, &
      ilower, iupper, etastar, &
      etanew, nx, ny, xlow, xhigh, ylow, yhigh, OL, dt, maxits, eps, ierr)
#endif

    etanew = etanew*wetmask

    if (debug_level .ge. 4) then
      call write_output_3d(etanew, nx, ny, 1, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, 0, 0, &
                          n, 'output/snap.eta_new.', num_procs, myid)
    end if

    call update_halos(etanew, nx, ny, 1, ilower, iupper, &
                          xlow, xhigh, ylow, yhigh, OL, num_procs, myid)

    ! Now update the velocities using the barotropic tendency due to
    ! the pressure gradient.
    call update_velocities_for_barotropic_tendency(unew, etanew, g_vec, &
        1, 0, dx, dt, xlow, xhigh, ylow, yhigh, layers, OL)
    call update_velocities_for_barotropic_tendency(vnew, etanew, g_vec, &
        0, 1, dy, dt, xlow, xhigh, ylow, yhigh, layers, OL)

    ! We now have correct velocities at the next time step, but the
    ! layer thicknesses were updated using the velocities without
    ! the barotropic pressure contribution. Force consistency
    ! between layer thicknesses and ocean depth by scaling
    ! thicknesses to agree with free surface.
    call enforce_depth_thickness_consistency(hnew, etanew, depth, &
        freesurfFac, thickness_error, xlow, xhigh, ylow, yhigh, layers, OL)

    ! Apply the boundary conditions
    call apply_boundary_conditions(unew, hfacW, wetmask, &
                                xlow, xhigh, ylow, yhigh, layers, OL)
    call apply_boundary_conditions(vnew, hfacS, wetmask, &
                                xlow, xhigh, ylow, yhigh, layers, OL)

    return
  end subroutine barotropic_correction

end module barotropic_mode


*dk volume_tri
      subroutine volume_tri(x1,y1,z1,
     *                      x2,y2,z2,
     *                      x3,y3,z3,
     *                      voltri)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         THIS ROUTINE FINDS THE VOLUME OF A TRI-ELEMENT DEFINDED BY
C            3 COORDINATE NODES. THE VOLUME IS FOUND BY TAKING THE
C            CROSS PRODUCT OF TWO VECTORS.
C
C
C     ******************************************************************
C
C     DEFINE THE STRUCTURE OF A GENERIC TRIANGLE.
C
C            i3  *- - - - - -*  i2
C                 \         /
C                  \       /
C                   \     /
C                    \   /
C                     \ /
C                      *
C                     i1
C
C     ******************************************************************
C
C      INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x3,y3,z3) - THE COORDINATES OF THE TRI.
C
C     OUTPUT ARGUMENTS -
C
C        voltri - THE AREA OF THE TRI.
C
C     CHANGE HISTORY -
C
C        $Log: volume_tri.f,v $
C        Revision 2.00  2007/11/09 20:04:06  spchu
C        Import to CVS
C
CPVCS
CPVCS       Rev 1.2   Tue Oct 19 13:16:10 1999   jtg
CPVCS    changed comment lines to actually correspond to a tri
CPVCS
CPVCS       Rev 1.1   Mon Apr 14 17:05:44 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.0   Mon Jul 29 15:42:52 1996   dcg
CPVCS    Initial revision.
C
C#######################################################################
C
C
      implicit real*8 (a-h,o-z)
C
C#######################################################################
C
C
C     ..................................................................
C     TAKE THE CROSS PRODUCT OF THE 21 AND 31 VECTORS TO THE AN AREA
C        VECTOR.
C
      dx= (y2-y1)*(z3-z1) - (y3-y1)*(z2-z1)
      dy= (z2-z1)*(x3-x1) - (z3-z1)*(x2-x1)
      dz= (x2-x1)*(y3-y1) - (x3-x1)*(y2-y1)
C
C     ..................................................................
C     THEN TAKE 1/2 THE MAGNITUDE OF THIS AREA VECTOR TO GET THE TRI VOLUME
C
      voltri=0.5d+00*sqrt(dx**2+dy**2+dz**2)
C
      return
      end


	subroutine sobseq(n,x,ndim)
	integer,intent(IN) :: ndim
	integer n,MAXBIT,MAXDIM
	real x(1:ndim)
	parameter (MAXBIT=30,MAXDIM=6)
! Randomly samples between 0 and 1
! IMPORTANT: n must be less than or equal to the number of inputs in x
!	When n is negative, internally initializes a set of MAXBIT
!	direction numbers for each of MAXDIM different Sobol' sequences.
!	When n is positive (but <= MAXDIM), returns as the vector x(1..n)
!	the next values from n of these sequences. (n must not be changed
!	between initializations.)
	integer i,im,in,ipp,j,k,l,ip(MAXDIM),iu(MAXDIM,MAXBIT),
     &		iv(MAXBIT*MAXDIM),ix(MAXDIM),mdeg(MAXDIM)
	real fac
	save ip,mdeg,ix,iv,in,fac
	equivalence (iv,iu)
	data ip /0,1,1,2,1,4/, mdeg /1,2,3,3,4,4/, ix /6*0/
	data iv /6*1,3,1,3,3,1,1,5,7,7,3,3,5,15,11,5,15,13,9,156*0/
	if (n.lt.0) then
	  do 11 k=1,MAXDIM
	    ix(k)=0
11	  enddo
	  in=0
	  if(iv(1).ne.1)return
	  fac=1d0/2d0**MAXBIT
	  do 15 k=1,MAXDIM
	    do 12 j=1,mdeg(k)
	      iu(k,j)=iu(k,j)*2**(MAXBIT-j)
12	    enddo
	    do 14 j=mdeg(k)+1,MAXBIT
		ipp=ip(k)
		i=iu(k,j-mdeg(k))
		i=ieor(i,i/2**mdeg(k))
		do 13 l=mdeg(k)-1,1,-1
		  if(iand(ipp,1).ne.0) i=ieor(i,iu(k,j-1))
		  ipp=ipp/2
13		enddo
		iu(k,j)=i
14	    enddo
15	  enddo
	else
	  im=in
	  do 16 j=1,MAXBIT
	    if(iand(im,1).eq.0) goto 1
	    im=im/2
16	  enddo
!	  pause 'MAXBIT too small in sobseq'
1	  im=(j-1)*MAXDIM
	  do 17 k=1,min(n,MAXDIM)
		ix(k)=ieor(ix(k),iv(im+k))
		x(k)=ix(k)*fac
17	  enddo
	  in=in+1
	endif
	return
	end
!


*     FD01AD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT, NOUT1
      PARAMETER        ( NIN = 5, NOUT = 6, NOUT1 = 7 )
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER          IMAX, LMAX
      PARAMETER        ( IMAX = 500, LMAX = 10 )
      DOUBLE PRECISION LAMBDA
      PARAMETER        ( LAMBDA = 0.99D0 )
*     .. Local Scalars ..
      CHARACTER        JP
      INTEGER          I, INFO, IWARN, L
      DOUBLE PRECISION DELTA, EFOR, EOUT, EPOS, XIN, YIN
*     .. Local Arrays ..
      DOUBLE PRECISION CTETA(LMAX), EPSBCK(LMAX+1), SALPH(LMAX),
     $                 STETA(LMAX), XF(LMAX), YQ(LMAX)
*     .. External Functions ..
      DOUBLE PRECISION XFCN, YFCN
      EXTERNAL         XFCN, YFCN
*     NOTE: XFCN() generates at each iteration the next sample of the
*           input sequence. YFCN() generates at each iteration the next
*           sample of the reference sequence. These functions are user
*           defined (obtained from data acquisition devices, for
*           example).
*     .. External Subroutines ..
      EXTERNAL         FD01AD
*
*     .. File for the output error sequence ..
      OPEN ( UNIT = NOUT1, FILE = 'ERR.OUT', STATUS = 'REPLACE' )
*     ..  Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) L, DELTA, JP
      IF ( L.LE.0 .OR. L.GT.LMAX ) THEN
         WRITE ( NOUT, FMT = 99992 ) L
      ELSE
         IF ( DELTA.LT.ZERO ) THEN
            WRITE ( NOUT, FMT = 99991 )
         ELSE
*
            DO 10 I = 1, L
               CTETA(I)  = ONE
               STETA(I)  = ZERO
               EPSBCK(I) = ZERO
               XF(I) = ZERO
               YQ(I) = ZERO
   10       CONTINUE
            EPSBCK(L+1) = ONE
            EFOR = DELTA
*           .. Run least squares filter.
            DO 20 I = 1, IMAX
               XIN = XFCN(I)
               YIN = YFCN(I)
               CALL FD01AD( JP, L, LAMBDA, XIN, YIN, EFOR, XF, EPSBCK,
     $                      CTETA, STETA, YQ, EPOS, EOUT, SALPH, IWARN,
     $                      INFO)
               WRITE(NOUT1,*) EOUT
   20       CONTINUE
            CLOSE(NOUT1)
*           NOTE:  File 'ERR.OUT' now contains the output error
*                  sequence.
*
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99998 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99997 )
               DO 30 I = 1, L
                  WRITE ( NOUT, FMT = 99996 ) I, XF(I), YQ(I), EPSBCK(I)
   30          CONTINUE
               WRITE ( NOUT, FMT = 99995 ) L+1, EPSBCK(L+1)
               WRITE ( NOUT, FMT = 99994 ) EFOR
               IF ( IWARN.NE.0 ) THEN
                  WRITE ( NOUT, FMT = 99993 ) IWARN
               END IF
            END IF
         END IF
      END IF
      STOP
*
99999 FORMAT (' FD01AD EXAMPLE PROGRAM RESULTS', /1X)
99998 FORMAT (' INFO on exit from FD01AD = ', I2)
99997 FORMAT ('  i', 7X, 'XF(i)', 7X, 'YQ(i)', 6X, 'EPSBCK(i)', /1X)
99996 FORMAT ( I3, 2X, 3(2X, F10.6))
99995 FORMAT ( I3, 28X, F10.6, /1X)
99994 FORMAT (' EFOR = ', D10.3)
99993 FORMAT (' IWARN on exit from FD01AD = ', I2)
99992 FORMAT (/' L is out of range.',/' L = ',I5)
99991 FORMAT (/' The exponentially weighted forward prediction error',
     $         '  energy must be non-negative.' )
*
      END
*
*     .. Example functions ..
*
      DOUBLE PRECISION FUNCTION XFCN( I )
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE, SIN
*     .. Local Scalar ..
      INTEGER          I
*     .. Executable Statements ..
      XFCN = SIN( 0.3D0*DBLE( I ) )
* *** Last line of XFCN ***
      END
*
      DOUBLE PRECISION FUNCTION YFCN( I )
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE, SIN
*     .. Local Scalar ..
      INTEGER          I
*     .. Executable Statements ..
      YFCN = 0.5D0 * SIN( 0.3D0*DBLE( I ) ) +
     $       2.0D0 * SIN( 0.3D0*DBLE( I-1 ) )
* *** Last line of YFCN ***
      END


module global_module

! This module contains data needed throughout the program.
! Most data is specified as a parameter, as to make the execution faster.
! This module is loaded by most other modules.

  implicit none

  ! Time integration

  real(kind=8), parameter :: dt    = 1.0d-3 ! [s] time step for the simulation
  real(kind=8), parameter :: t_end = 500.0d0 ! [s] total simulated time (from 0 to t_end)

  ! Specify domain and discretization

  real(kind=8), parameter :: x_min = 0.0d0 ! [m]
  real(kind=8), parameter :: x_max = 3.0d0  ! [m]
  real(kind=8), parameter :: y_min = 0.0d0  ! [m] MUST BE POSITIVE FOR AXISYMMETRIC SIMULATION
  real(kind=8), parameter :: y_max = 1.0d0  ! [m]

  ! Total number of cells (including 2 ghost cells for each side)
  ! (using 2 ghost cells makes it easy to reach second order accuracy)

  integer, parameter :: Nx = 300
  integer, parameter :: Ny = 150

  real(kind=8), parameter :: dx = (x_max-x_min)/(Nx-4)
  real(kind=8), parameter :: dy = (y_max-y_min)/(Ny-4)

  ! Spatial accuracy
  logical, parameter :: bool_MUSCL = .TRUE.

end module


program map_test

  use healpix_types
  use fourier, only: p_lm_gen, direct_fourier, inverse_fourier
  use map_coef, only: a_lm_gasdev
  use minkowski, only: area, length
  use distance, only: s2

  implicit none
  integer(kind=i8b) :: legendre_num = 5 !!! legendre_num = n_pix / 2
  integer(kind=i4b) :: n_pix = 512_i8b
  real(kind=dp), dimension(:, :), allocatable :: map
  complex(kind=dpc), dimension(:, :), allocatable :: a_lms
  integer(kind=i8b) :: i, j
  integer(kind=i8b) :: err_map, err_alms

  allocate(map(1:n_pix+1, 1:n_pix/2+1), stat=err_map)
  if (err_map /= 0) print *, "map: Allocation request denied"

  allocate(a_lms(0:legendre_num, 0:legendre_num), stat=err_alms)
  if (err_alms /= 0) print *, "a_lms: Allocation request denied"

  open(1, file="../../out.dat")

  call a_lm_gasdev(legendre_num, a_lms, 151514512, 0.d0, 1.d0)

  call direct_fourier(n_pix, map, legendre_num, a_lms)

  write(*, *) '0, 0', a_lms(0, 0)
  write(*, *) '0, 1', a_lms(0, 0)
  write(*, *) '1, 1', a_lms(1, 1)
  write(*, *) '0, 2', a_lms(0, 2)
  write(*, *) '1, 2', a_lms(1, 2)
  write(*, *) '2, 2', a_lms(2, 2)

  ! write(*, *) 'map(:, 2)', map(:, 2)
  ! write(*, *) 'map(:, 3)', map(:, 3)
  ! write(*, *) 'map(:, 4)', map(:, 4)

  call inverse_fourier(n_pix, map, legendre_num, a_lms)

  write(*, *) '0, 0', a_lms(0, 0)
  write(*, *) '0, 1', a_lms(0, 1)
  write(*, *) '1, 1', a_lms(1, 1)
  write(*, *) '0, 2', a_lms(0, 2)
  write(*, *) '1, 2', a_lms(1, 2)
  write(*, *) '2, 2', a_lms(2, 2)

  do i = 1, n_pix+1, 1
    do j = 1, n_pix/2+1, 1
      write(1, *) map(i, j), i, j
    end do
  end do

  write(*, *) 'area', area(n_pix, map, 0.d0)
  write(*, *) 'length', length(n_pix, map, 0.d0)

  if (allocated(a_lms)) deallocate(a_lms, stat=err_alms)
  if (err_alms /= 0) print *, "a_lms: Deallocation request denied"

  if (allocated(map)) deallocate(map, stat=err_map)
  if (err_map /= 0) print *, "map: Deallocation request denied"

end program map_test


program main
  use photochem_clima

  implicit none
  real(8) :: T_trop, P_surf, P_trop, mubar, grav, eta, Ptop
  integer, parameter :: nz = 200
  real(8) :: zout(nz), Tout(nz), ztrop, edd(nz), Pout(nz)

  integer :: i
  character(len=1000) :: err
  err = ""

  T_trop = 180.d0
  P_surf = 1.00d0
  P_trop = 0.1d0
  mubar = 7.d0
  grav = 981.d0
  eta = 0.14d0
  Ptop = 2.1427d-08

  call eta_clima(T_trop, P_surf, P_trop, eta, mubar, grav, Ptop, nz, &
                zout, Tout, ztrop)

  call pahlevan_H2_clima(P_surf, mubar, grav, Ptop, nz, &
                         zout, Pout, Tout, ztrop, err)
  if (len_trim(err) /= 0) return

  call zahnle_eddy(nz, zout, 0.21d0, 235.d0, ztrop, mubar, grav, edd)

  do i = 1,nz
    print*,zout(i)/1.d5, Tout(i), Pout(i)
  enddo
  print*,ztrop/1.d5

end program


      SUBROUTINE DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)                    00000010
      INTEGER LDA,N,ML,MU,IPVT(1)                                       00000020
      DOUBLE PRECISION ABD(LDA,1),Z(1)                                  00000030
      DOUBLE PRECISION RCOND                                            00000040
C                                                                       00000050
C     DGBCO FACTORS A DOUBLE PRECISION BAND MATRIX BY GAUSSIAN          00000060
C     ELIMINATION AND ESTIMATES THE CONDITION OF THE MATRIX.            00000070
C                                                                       00000080
C     IF  RCOND  IS NOT NEEDED, DGBFA IS SLIGHTLY FASTER.               00000090
C     TO SOLVE  A*X = B , FOLLOW DGBCO BY DGBSL.                        00000100
C     TO COMPUTE  INVERSE(A)*C , FOLLOW DGBCO BY DGBSL.                 00000110
C     TO COMPUTE  DETERMINANT(A) , FOLLOW DGBCO BY DGBDI.               00000120
C                                                                       00000130
C     ON ENTRY                                                          00000140
C                                                                       00000150
C        ABD     DOUBLE PRECISION(LDA, N)                               00000160
C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS      00000170
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND   00000180
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS         00000190
C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .                       00000200
C                SEE THE COMMENTS BELOW FOR DETAILS.                    00000210
C                                                                       00000220
C        LDA     INTEGER                                                00000230
C                THE LEADING DIMENSION OF THE ARRAY  ABD .              00000240
C                LDA MUST BE .GE. 2*ML + MU + 1 .                       00000250
C                                                                       00000260
C        N       INTEGER                                                00000270
C                THE ORDER OF THE ORIGINAL MATRIX.                      00000280
C                                                                       00000290
C        ML      INTEGER                                                00000300
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.           00000310
C                0 .LE. ML .LT. N .                                     00000320
C                                                                       00000330
C        MU      INTEGER                                                00000340
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.           00000350
C                0 .LE. MU .LT. N .                                     00000360
C                MORE EFFICIENT IF  ML .LE. MU .                        00000370
C                                                                       00000380
C     ON RETURN                                                         00000390
C                                                                       00000400
C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND         00000410
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.          00000420
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE       00000430
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER          00000440
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.       00000450
C                                                                       00000460
C        IPVT    INTEGER(N)                                             00000470
C                AN INTEGER VECTOR OF PIVOT INDICES.                    00000480
C                                                                       00000490
C        RCOND   DOUBLE PRECISION                                       00000500
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .        00000510
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS       00000520
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE             00000530
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND . 00000540
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION     00000550
C                           1.0 + RCOND .EQ. 1.0                        00000560
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING           00000570
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF         00000580
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE          00000590
C                UNDERFLOWS.                                            00000600
C                                                                       00000610
C        Z       DOUBLE PRECISION(N)                                    00000620
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.  00000630
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS      00000640
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT           00000650
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .                    00000660
C                                                                       00000670
C     BAND STORAGE                                                      00000680
C                                                                       00000690
C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT      00000700
C           WILL SET UP THE INPUT.                                      00000710
C                                                                       00000720
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)                00000730
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)                00000740
C                   M = ML + MU + 1                                     00000750
C                   DO 20 J = 1, N                                      00000760
C                      I1 = MAX0(1, J-MU)                               00000770
C                      I2 = MIN0(N, J+ML)                               00000780
C                      DO 10 I = I1, I2                                 00000790
C                         K = I - J + M                                 00000800
C                         ABD(K,J) = A(I,J)                             00000810
C                10    CONTINUE                                         00000820
C                20 CONTINUE                                            00000830
C                                                                       00000840
C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .         00000850
C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR      00000860
C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.            00000870
C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .    00000880
C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE            00000890
C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.          00000900
C                                                                       00000910
C     EXAMPLE..  IF THE ORIGINAL MATRIX IS                              00000920
C                                                                       00000930
C           11 12 13  0  0  0                                           00000940
C           21 22 23 24  0  0                                           00000950
C            0 32 33 34 35  0                                           00000960
C            0  0 43 44 45 46                                           00000970
C            0  0  0 54 55 56                                           00000980
C            0  0  0  0 65 66                                           00000990
C                                                                       00001000
C      THEN  N = 6, ML = 1, MU = 2, LDA .GE. 5  AND ABD SHOULD CONTAIN  00001010
C                                                                       00001020
C            *  *  *  +  +  +  , * = NOT USED                           00001030
C            *  * 13 24 35 46  , + = USED FOR PIVOTING                  00001040
C            * 12 23 34 45 56                                           00001050
C           11 22 33 44 55 66                                           00001060
C           21 32 43 54 65  *                                           00001070
C                                                                       00001080
C     LINPACK. THIS VERSION DATED 08/14/78 .                            00001090
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.      00001100
C                                                                       00001110
C     SUBROUTINES AND FUNCTIONS                                         00001120
C                                                                       00001130
C     LINPACK DGBFA                                                     00001140
C     BLAS DAXPY,DDOT,DSCAL,DASUM                                       00001150
C     FORTRAN DABS,DMAX1,MAX0,MIN0,DSIGN                                00001160
C                                                                       00001170
C     INTERNAL VARIABLES                                                00001180
C                                                                       00001190
      DOUBLE PRECISION DDOT,EK,T,WK,WKM                                 00001200
      DOUBLE PRECISION ANORM,S,DASUM,SM,YNORM                           00001210
      INTEGER IS,INFO,J,JU,K,KB,KP1,L,LA,LM,LZ,M,MM                     00001220
C                                                                       00001230
C                                                                       00001240
C     COMPUTE 1-NORM OF A                                               00001250
C                                                                       00001260
      ANORM = 0.0D0                                                     00001270
      L = ML + 1                                                        00001280
      IS = L + MU                                                       00001290
      DO 10 J = 1, N                                                    00001300
         ANORM = DMAX1(ANORM,DASUM(L,ABD(IS,J),1))                      00001310
         IF (IS .GT. ML + 1) IS = IS - 1                                00001320
         IF (J .LE. MU) L = L + 1                                       00001330
         IF (J .GE. N - ML) L = L - 1                                   00001340
   10 CONTINUE                                                          00001350
C                                                                       00001360
C     FACTOR                                                            00001370
C                                                                       00001380
      CALL DGBFA(ABD,LDA,N,ML,MU,IPVT,INFO)                             00001390
C                                                                       00001400
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .              00001410
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .  00001420
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE      00001430
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE  00001440
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID    00001450
C     OVERFLOW.                                                         00001460
C                                                                       00001470
C     SOLVE TRANS(U)*W = E                                              00001480
C                                                                       00001490
      EK = 1.0D0                                                        00001500
      DO 20 J = 1, N                                                    00001510
         Z(J) = 0.0D0                                                   00001520
   20 CONTINUE                                                          00001530
      M = ML + MU + 1                                                   00001540
      JU = 0                                                            00001550
      DO 100 K = 1, N                                                   00001560
         IF (Z(K) .NE. 0.0D0) EK = DSIGN(EK,-Z(K))                      00001570
         IF (DABS(EK-Z(K)) .LE. DABS(ABD(M,K))) GO TO 30                00001580
            S = DABS(ABD(M,K))/DABS(EK-Z(K))                            00001590
            CALL DSCAL(N,S,Z,1)                                         00001600
            EK = S*EK                                                   00001610
   30    CONTINUE                                                       00001620
         WK = EK - Z(K)                                                 00001630
         WKM = -EK - Z(K)                                               00001640
         S = DABS(WK)                                                   00001650
         SM = DABS(WKM)                                                 00001660
         IF (ABD(M,K) .EQ. 0.0D0) GO TO 40                              00001670
            WK = WK/ABD(M,K)                                            00001680
            WKM = WKM/ABD(M,K)                                          00001690
         GO TO 50                                                       00001700
   40    CONTINUE                                                       00001710
            WK = 1.0D0                                                  00001720
            WKM = 1.0D0                                                 00001730
   50    CONTINUE                                                       00001740
         KP1 = K + 1                                                    00001750
         JU = MIN0(MAX0(JU,MU+IPVT(K)),N)                               00001760
         MM = M                                                         00001770
         IF (KP1 .GT. JU) GO TO 90                                      00001780
            DO 60 J = KP1, JU                                           00001790
               MM = MM - 1                                              00001800
               SM = SM + DABS(Z(J)+WKM*ABD(MM,J))                       00001810
               Z(J) = Z(J) + WK*ABD(MM,J)                               00001820
               S = S + DABS(Z(J))                                       00001830
   60       CONTINUE                                                    00001840
            IF (S .GE. SM) GO TO 80                                     00001850
               T = WKM - WK                                             00001860
               WK = WKM                                                 00001870
               MM = M                                                   00001880
               DO 70 J = KP1, JU                                        00001890
                  MM = MM - 1                                           00001900
                  Z(J) = Z(J) + T*ABD(MM,J)                             00001910
   70          CONTINUE                                                 00001920
   80       CONTINUE                                                    00001930
   90    CONTINUE                                                       00001940
         Z(K) = WK                                                      00001950
  100 CONTINUE                                                          00001960
      S = 1.0D0/DASUM(N,Z,1)                                            00001970
      CALL DSCAL(N,S,Z,1)                                               00001980
C                                                                       00001990
C     SOLVE TRANS(L)*Y = W                                              00002000
C                                                                       00002010
      DO 120 KB = 1, N                                                  00002020
         K = N + 1 - KB                                                 00002030
         LM = MIN0(ML,N-K)                                              00002040
         IF (K .LT. N) Z(K) = Z(K) + DDOT(LM,ABD(M+1,K),1,Z(K+1),1)     00002050
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 110                           00002060
            S = 1.0D0/DABS(Z(K))                                        00002070
            CALL DSCAL(N,S,Z,1)                                         00002080
  110    CONTINUE                                                       00002090
         L = IPVT(K)                                                    00002100
         T = Z(L)                                                       00002110
         Z(L) = Z(K)                                                    00002120
         Z(K) = T                                                       00002130
  120 CONTINUE                                                          00002140
      S = 1.0D0/DASUM(N,Z,1)                                            00002150
      CALL DSCAL(N,S,Z,1)                                               00002160
C                                                                       00002170
      YNORM = 1.0D0                                                     00002180
C                                                                       00002190
C     SOLVE L*V = Y                                                     00002200
C                                                                       00002210
      DO 140 K = 1, N                                                   00002220
         L = IPVT(K)                                                    00002230
         T = Z(L)                                                       00002240
         Z(L) = Z(K)                                                    00002250
         Z(K) = T                                                       00002260
         LM = MIN0(ML,N-K)                                              00002270
         IF (K .LT. N) CALL DAXPY(LM,T,ABD(M+1,K),1,Z(K+1),1)           00002280
         IF (DABS(Z(K)) .LE. 1.0D0) GO TO 130                           00002290
            S = 1.0D0/DABS(Z(K))                                        00002300
            CALL DSCAL(N,S,Z,1)                                         00002310
            YNORM = S*YNORM                                             00002320
  130    CONTINUE                                                       00002330
  140 CONTINUE                                                          00002340
      S = 1.0D0/DASUM(N,Z,1)                                            00002350
      CALL DSCAL(N,S,Z,1)                                               00002360
      YNORM = S*YNORM                                                   00002370
C                                                                       00002380
C     SOLVE  U*Z = W                                                    00002390
C                                                                       00002400
      DO 160 KB = 1, N                                                  00002410
         K = N + 1 - KB                                                 00002420
         IF (DABS(Z(K)) .LE. DABS(ABD(M,K))) GO TO 150                  00002430
            S = DABS(ABD(M,K))/DABS(Z(K))                               00002440
            CALL DSCAL(N,S,Z,1)                                         00002450
            YNORM = S*YNORM                                             00002460
  150    CONTINUE                                                       00002470
         IF (ABD(M,K) .NE. 0.0D0) Z(K) = Z(K)/ABD(M,K)                  00002480
         IF (ABD(M,K) .EQ. 0.0D0) Z(K) = 1.0D0                          00002490
         LM = MIN0(K,M) - 1                                             00002500
         LA = M - LM                                                    00002510
         LZ = K - LM                                                    00002520
         T = -Z(K)                                                      00002530
         CALL DAXPY(LM,T,ABD(LA,K),1,Z(LZ),1)                           00002540
  160 CONTINUE                                                          00002550
C     MAKE ZNORM = 1.0                                                  00002560
      S = 1.0D0/DASUM(N,Z,1)                                            00002570
      CALL DSCAL(N,S,Z,1)                                               00002580
      YNORM = S*YNORM                                                   00002590
C                                                                       00002600
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM                         00002610
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0                               00002620
      RETURN                                                            00002630
      END                                                               00002640


      SUBROUTINE DPSE2
C
C     THIS ROUTINE COMPUTES THE TWO 6 X 6 MATRICES K(NPVT,NPVT) AND
C     K(NPVT,J), PRESSURE STIFFNESS MATRICES FOR A CPSE2 PRESSURE
C     STIFFNESS ELEMENT (ROD, 2 GRID POINTS)
C
C     DOUBLE PRECISION VERSION
C
C     WRITTEN BY E. R. CHRISTENSEN/SVERDRUP  7/91, VERSION 1.0
C     INSTALLED IN NASTRAN AS ELEMENT DPSE2 BY G.CHAN/UNISYS, 2/92
C
C     REFERENCE - E. CHRISTENEN: 'ADVACED SOLID ROCKET MOTOR (ASRM)
C                 MATH MODELS - PRESSURE STIFFNESS EFFECTS ANALYSIS',
C                 NASA TD 612-001-02, AUGUST 1991
C
C     LIMITATION -
C     (1) ALL GRID POINTS USED BY ANY OF THE CPSE2/3/4 ELEMENTS MUST BE
C         IN BASIC COORDINATE SYSTEM!!!
C     (2) CONSTANT PRESSURE APPLIED OVER AN ENCLOSED VOLUMN ENCOMPASSED
C         BY THE CPSE2/3/4 ELEMENTRS
C     (3) PRESSURE ACTS NORMALLY TO THE CPSE2/3/4 SURFACES
C
C     SEE NASTRAN DEMONSTRATION PROBLEM -  T13021A
C
C     ECPT FOR THE PRESSURE STIFFNESS
C     CPSE2 ELEMENT                                CARD
C                                                  TYPE  TYPE   TABLE
C                                                 ------ ----- ------
C     ECPT( 1) ELEMENT ID.                         CPSE2   I     ECT
C     ECPT( 2) SCALAR INDEX NUMBER FOR GRD.PT. A   CPSE2   I     ECT
C     ECPT( 3) SCALAR INDEX NUMBER FOR GRD.PT. B   CPSE2   I     ECT
C     ECPT( 4) PRESSURE P                          PPSE    R     EPT
C     ECPT( 5) NOT USED                            PPSE    R     EPT
C     ECPT( 6) NOT USED                            PPSE    R     EPT
C     ECPT( 7) NOT USED                            PPSE    R     EPT
C     ECPT( 8) COOR. SYS. ID. NO. FOR GRD.PT. A    GRID    I    BGPDT
C     ECPT( 9) X-COORDINATE OF GRD.PT. A (IN BASIC COOR)   R    BGPDT
C     ECPT(10) Y-COORDINATE OF GRD.PT. A (IN BASIC COOR)   R    BGPDT
C     ECPT(11) Z-COORDINATE OF GRD.PT. A (IN BASIC COOR)   R    BGPDT
C     ECPT(12) COOR. SYS. ID. NO. FOR GRD.PT. B            I    BGPDT
C     ECPT(13) X-COORDINATE OF GRD.PT. B (IN BASIC COOR)   R    BGPDT
C     ECPT(14) Y-COORDINATE OF GRD.PT. B (IN BASIC COOR)   R    BGPDT
C     ECPT(15) Z-COORDINATE OF GRD.PT. B (IN BASIC COOR)   R    BGPDT
C     ECPT(16) ELEMENT TEMPERATURE
C     ECPT(17) THRU ECPT(24) = DUM2 AND DUM6, NOT USED IN THIS ROUTINE
C
      DOUBLE PRECISION KE,TA,TB,D,X,Y,Z,XL,ALPHA
      DIMENSION        IECPT(3)
C     COMMON /SYSTEM/  IBUF,NOUT
      COMMON /DS1AAA/  NPVT,ICSTM,NCSTM
      COMMON /DS1AET/  ECPT(16),DUM2(2),DUM6(6)
      COMMON /DS1ADP/  KE(36),TA(9),TB(9),D(18),X,Y,Z,XL,ALPHA
      EQUIVALENCE      (ECPT(1),IECPT(1))
C
      IELEM = IECPT(1)
      IF (IECPT(2) .EQ. NPVT) GO TO 10
      IF (IECPT(3) .NE. NPVT) CALL MESAGE (-30,34,IECPT(1))
      ITEMP = IECPT(2)
      IECPT(2) = IECPT(3)
      IECPT(3) = ITEMP
      KA  = 12
      KB  =  8
      ALPHA = -1.0D0
      GO TO 20
   10 KA  =  8
      KB  =  12
      ALPHA = 1.0D0
C
C     AT THIS POINT KA POINTS TO THE COOR. SYS. ID. OF THE PIVOT GRID
C     POINT. SIMILARLY FOR KB AND THE NON-PIVOT GRID POINT.
C
C     NOW COMPUTE THE LENGTH OF THE CPSE2 ELEMENT.
C
C
C     WE STORE THE COORDINATES IN THE D ARRAY SO THAT ALL ARITHMETIC
C     WILL BE DOUBLE PRECISION
C
C     CHECK TO SEE THAT THE CPSE2 HAS A NONZERO LENGTH
C
   20 D(1) = ECPT(KA+1)
      D(2) = ECPT(KA+2)
      D(3) = ECPT(KA+3)
      D(4) = ECPT(KB+1)
      D(5) = ECPT(KB+2)
      D(6) = ECPT(KB+3)
      X    = D(1) - D(4)
      Y    = D(2) - D(5)
      Z    = D(3) - D(6)
      XL = DSQRT(X**2 + Y**2 + Z**2)
      IF (XL .EQ. 0.0D0) GO TO 70
C
C     COMPUTE THE 3 X 3 NON-ZERO SUBMATRIX OF KDGG(NPVT,NONPVT)
C
      D(1) = 0.0D0
      D(2) = ALPHA*ECPT(4)/2.0D0
      D(3) = D(2)
      D(4) =-D(2)
      D(5) = 0.0D0
      D(6) = D(2)
      D(7) = D(4)
      D(8) = D(4)
      D(9) = 0.0D0
C
C     ZERO OUT KE MATRIX
C
      DO 30 I = 1,36
   30 KE(I) = 0.0D0
C
C     FILL UP THE 6 X 6 KE
C
C     IF PIVOT GRID POINT IS IN BASIC COORDINATES, GO TO 40
C
      K1 = 1
      IF (IECPT(KA) .EQ. 0) GO TO 40
      CALL TRANSD (ECPT(KA),TA)
      CALL GMMATD (TA,3,3,1, D(1),3,3,0, D(10))
      K1  = 10
      KB1 = 10
      KB2 = 1
      GO TO 50
C
C     IF NON-PIVOT GRID POINT IS IN BASIC COORDINATES, GO TO 60
C
   40 KB1 = 1
      KB2 = 10
   50 IF (IECPT(KB) .EQ. 0) GO TO 60
      CALL TRANSD (ECPT(KB),TB)
      CALL GMMATD (D(KB1),3,3,0, TB,3,3,0, D(KB2))
      K1 = KB2
C
   60 KE( 1) = D(K1  )
      KE( 2) = D(K1+1)
      KE( 3) = D(K1+2)
      KE( 7) = D(K1+3)
      KE( 8) = D(K1+4)
      KE( 9) = D(K1+5)
      KE(13) = D(K1+6)
      KE(14) = D(K1+7)
      KE(15) = D(K1+8)
      CALL DS1B (KE,IECPT(3))
      RETURN
C
C     ERROR
C
   70 CALL MESAGE (30,26,IECPT(1))
      NOGO = 1
      RETURN
      END


      subroutine possol (month,jday,tu,xlon,xlat,
     a                   asol,phi0)

      real    tu,xlon,xlat,asol,phi0
      integer month,jday,ia,nojour

c     solar position (zenithal angle asol,azimuthal angle phi0
c                     in degrees)
c     jday is the number of the day in the month

      ia = 0
      call day_number(jday,month,ia,nojour)

      call  pos_fft (nojour, tu, xlon, xlat, asol, phi0)

      if(asol.gt.90) call print_error(
     s 'The sun is not raised')
      return
      end

      subroutine day_number(jday,month,ia,j)
      integer jday, month, ia, j

      if (month.le.2) then
                      j=31*(month-1)+jday
		      return
		      endif
      if (month.gt.8) then
                      j=31*(month-1)-((month-2)/2)-2+jday
		      else
                      j=31*(month-1)-((month-1)/2)-2+jday
		      endif
      if(ia.ne.0 .and. mod(ia,4).eq.0) j=j+1
      return
      end

      subroutine pos_fft (j,tu,xlon,xlat,asol,phi0)
      real    tu, xlat, asol,phi0, tsm, xlon,xla, xj, tet,
     a	      a1, a2, a3, a4, a5, et, tsv, ah, b1, b2, b3, b4,
     a	      b5, b6, b7, delta, amuzero, elev, az, caz, azim, pi2
      integer j
      parameter (pi=3.14159265,fac=pi/180.)
c     solar position (zenithal angle asol,azimuthal angle phi0
c                     in degrees)
c     j is the day number in the year
c
c    mean solar time (heure decimale)

      tsm=tu+xlon/15.
      xla=xlat*fac
      xj=float(j)
      tet=2.*pi*xj/365.

c    time equation (in mn.dec)
      a1=.000075
      a2=.001868
      a3=.032077
      a4=.014615
      a5=.040849
      et=a1+a2*cos(tet)-a3*sin(tet)-a4*cos(2.*tet)-a5*sin(2.*tet)
      et=et*12.*60./pi

c     true solar time

      tsv=tsm+et/60.
      tsv=(tsv-12.)

c     hour angle

      ah=tsv*15.*fac

c     solar declination   (in radian)

      b1=.006918
      b2=.399912
      b3=.070257
      b4=.006758
      b5=.000907
      b6=.002697
      b7=.001480
      delta=b1-b2*cos(tet)+b3*sin(tet)-b4*cos(2.*tet)+b5*sin(2.*tet)-
     &b6*cos(3.*tet)+b7*sin(3.*tet)

c     elevation,azimuth

      amuzero=sin(xla)*sin(delta)+cos(xla)*cos(delta)*cos(ah)
      elev=asin(amuzero)
      az=cos(delta)*sin(ah)/cos(elev)
      if ( (abs(az)-1.000).gt.0.00000) az = sign(1.,az)
      caz=(-cos(xla)*sin(delta)+sin(xla)*cos(delta)*cos(ah))/cos(elev)
      azim=asin(az)
      if(caz.le.0.) azim=pi-azim
      if(caz.gt.0.and.az.le.0) azim=2*pi+azim
      azim=azim+pi
      pi2=2*pi
      if(azim.gt.pi2) azim=azim-pi2
      elev=elev*180./pi

c     conversion in degrees

      asol=90.-elev
      phi0=azim/fac
      return
      end