program test_mo_random_field

  use mo_kind,         only: i4, i8, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_random_field, only: random_velocity_field_gauss

  implicit none

  real(dp), dimension(:,:), allocatable  :: coord
  real(dp), dimension(2)                 :: corr_length
  real(dp), dimension(:,:), allocatable  :: velocity
  real(dp), dimension(:),   allocatable  :: potential
  real(dp), dimension(:,:), allocatable  :: cosine_mode

  integer(i4) :: i,n
  logical     :: isgood

  isgood = .true.

  n = 16
  allocate(coord(n,2))
  allocate(velocity(size(coord,1),size(coord,2)))
  allocate(potential(size(coord,1)))
  coord(:,1)  = (/ 0.0_dp, 0.0_dp, 0.0_dp, 0.0_dp, &
       0.1_dp, 0.1_dp, 0.1_dp, 0.1_dp, &
       0.2_dp, 0.2_dp, 0.2_dp, 0.2_dp, &
       0.3_dp, 0.3_dp, 0.3_dp, 0.3_dp /)
  coord(:,2)  = (/ 0.0_dp, 0.1_dp, 0.2_dp, 0.3_dp, &
       0.0_dp, 0.1_dp, 0.2_dp, 0.3_dp, &
       0.0_dp, 0.1_dp, 0.2_dp, 0.3_dp, &
       0.0_dp, 0.1_dp, 0.2_dp, 0.3_dp /)
  velocity  = -9999.0_dp
  potential = -9999.0_dp

  corr_length = (/ 0.05_dp, 0.01_dp /)

  ! random field, i.e. cosine_modes, is determined and
  ! velocity (all dimensions) and potential (scalar) are calculated for 3 points
  velocity(1:3,:) = random_velocity_field_gauss(coord(1:3,:), corr_length, &
       sigma2=0.001_dp, seed=13546_i8, &
       cosine_modes_out=cosine_mode, &
       potential=potential(1:3) )

  ! previously determined modes are used to calculate velocity and potential
  ! for additional points 4 to 10
  velocity(4:16,:) = random_velocity_field_gauss(coord(4:16,:), corr_length, &
       sigma2=0.001_dp, &
       cosine_modes_in=cosine_mode, &
       potential=potential(4:16) )

  write(*,*) ''
  write(*,*) ' x      y             velocity_x    velocity_y    potential'
  write(*,*) '--------------------------------------------------------------'
  do i=1, size(coord,1)
     write(*, '(F7.3,2X,F7.3,2X,F12.5,2X,F12.5,2X,F12.5)') coord(i,:), velocity(i,:), potential(i)
  end do
  write(*,*) ''

  ! write(*,*) 'velocity ', int(velocity(:,1)*100000.0_dp)
  if ( any(int(velocity(:,1)*100000.0_dp) .ne. (/-1286, 1541, -709,  173, 1188, -497, 1077, &
       2775, -2006, 2563, -369, -499, -1108,  992,  262,  235/)) ) isgood = .false.
  ! write(*,*) 'velocity ', int(velocity(:,2)*100000.0_dp)
  if ( any(int(velocity(:,2)*100000.0_dp) .ne. (/-13247, 2117, 2852, -2973, -6919, -3199, &
       -10483, 13322, -24272, 15308, -9172, -264, -2682, -6343, -13550, -9434/)) ) isgood = .false.
  ! write(*,*) 'potential ', int(potential(:)*100000.0_dp)
  if ( any(int(potential(:)*100000.0_dp) .ne. (/0, 71, -126, -215, -40, 58, 26, 127, 11, &
       -37, 70, 69, 103, 68, -57, -21/)) ) isgood = .false.
  write(*,*) ''

  if (isgood) then
     write(*,*) 'mo_random_field ', color('o.k.', c_green)
  else
     write(*,*) 'mo_random_field ', color('failed!', c_red)
  endif

end program test_mo_random_field


! =============================================================================
!                           2D TAYLOR-GREEN FLOW
!
!                   u(x, y) = A * cos(ax + d) * sin(by + e)
!                   v(x, y) = B * sin(ax + d) * cos(by + e)
!
!                   The code uses following variable names:
!                       tg_flow%freq  = (/a, b/)
!                       tg_flow%amp   = (/A, B/)
!                       tg_flow%phase = (/d, e/)
! =============================================================================
module taylor_green_2d
    use netcdf_writer
    use constants, only : pi, f12, zero, one, two
    implicit none

    private
        type flow_type
            double precision :: amp(2) = (/f12, -one/)      ! amplitudes
            double precision :: freq(2) = (/two, one/)      ! frequencies
            double precision :: phase(2) = (/zero, zero/)   ! phase shift
        end type flow_type

        type(flow_type) :: tg_flow

        integer :: vor_id

        double precision, parameter :: hpi = f12 * pi

    public :: get_flow_velocity,    &
              get_flow_gradient,    &
              get_flow_vorticity,   &
              taylor_green_init,    &
              tg_flow

    contains
        subroutine taylor_green_init(ncid, dimids, nx, nz, origin, dx)
            integer,          intent(inout) :: ncid
            integer,          intent(in)    :: dimids(:)
            integer,          intent(in)    :: nx, nz
            double precision, intent(in)    :: origin(2)
            double precision, intent(in)    :: dx(2)
            double precision                :: pos(2)
            double precision                :: vortg(0:nz, 0:nx-1)
            integer                         :: i, j

            call define_netcdf_dataset(ncid=ncid,                           &
                                       name='vorticity',                    &
                                       long_name='',                        &
                                       std_name='',                         &
                                       unit='1/s',                          &
                                       dtype=NF90_DOUBLE,                   &
                                       dimids=dimids,                       &
                                       varid=vor_id)

            call close_definition(ncid)

            do i = 0, nx - 1
                do j = 0, nz
                    pos = origin + dx * dble((/i, j/))
                    vortg(j, i) = get_flow_vorticity(pos)
                enddo
            enddo

            call write_netcdf_dataset(ncid, vor_id, vortg)

        end subroutine taylor_green_init

        function get_flow_velocity(pos) result(vel)
            double precision, intent(in) :: pos(2)
            double precision             :: xx, zz
            double precision             :: vel(2)

            call get_flow_pos(pos, xx, zz)

            vel(1) = tg_flow%amp(1) * dcos(xx) * dsin(zz)
            vel(2) = tg_flow%amp(2) * dsin(xx) * dcos(zz)
        end function get_flow_velocity

        ! grad ordering : dudx, dudy, dvdx, dvdy
        function get_flow_gradient(pos) result(grad)
            double precision, intent(in) :: pos(2)
            double precision             :: xx, zz
            double precision             :: grad(4)

            call get_flow_pos(pos, xx, zz)

            ! du/dx = - a * A * sin(xx) * sin(zz)
            grad(1) = - tg_flow%freq(1) * tg_flow%amp(1) * dsin(xx) * dsin(zz)

            ! du/dy = b * A * cos(xx) * cos(zz)
            grad(2) = tg_flow%freq(2) * tg_flow%amp(1) * dcos(xx) * dcos(zz)

            ! dv/dx = a * B * cos(xx) * np.cos(zz)
            grad(3) = tg_flow%freq(1) * tg_flow%amp(2) * dcos(xx) * dcos(zz)

            ! dv/dy = - b * B * sin(xx) * sin(zz)
            grad(4) = - tg_flow%freq(2) * tg_flow%amp(2) * dsin(xx) * dsin(zz)

        end function get_flow_gradient

        function get_flow_vorticity(pos) result(omega)
            double precision, intent(in) :: pos(2)
            double precision             :: xx, zz
            double precision             :: omega

            call get_flow_pos(pos, xx, zz)

            omega = (tg_flow%amp(2) * tg_flow%freq(1)     &
                   - tg_flow%amp(1) * tg_flow%freq(2))    &
                   * dcos(xx) * dcos(zz)
        end function get_flow_vorticity

        subroutine get_flow_pos(pos, xx, zz)
            double precision, intent(in) :: pos(2)
            double precision, intent(out) :: xx, zz

            xx = tg_flow%freq(1) * pos(1) + tg_flow%phase(1) + hpi
            zz = tg_flow%freq(2) * pos(2) + tg_flow%phase(2)

        end subroutine get_flow_pos

end module taylor_green_2d


!===============================================================================
subroutine nabla_hvel(VEL,TTT_VEL,dz,DXT,DYT,DXU,DYU,DZT,DZU,&
                            TAREA,DVELDX,DVELDY,DVELDZ)
!
!     calculates 3D gradients of a horizontal velocity field
!
implicit none

! input/output variables
integer                                     :: i,j,k
integer, parameter                          :: imt=3600, jmt=2400, km=42
real,    dimension(km),         intent(in)  :: dz
real,    dimension(imt,jmt),    intent(in)  :: DXT, DYT, DXU, DYU, TAREA
real,    dimension(imt,jmt,km), intent(in)  :: DZT, DZU, VEL, TTT_VEL
real,    dimension(imt,jmt,km), intent(out) :: DVELDX, DVELDY, DVELDZ ! TTT gradients
real,    parameter                          :: p5=0.5, c0=0.0

! horizontal gradients, central difference,
! eq. 3.6 page 16 in 2010 POP Reference Manual
do k = 1,km
! southernmost gridpoints (j=1) on TTT-grid must be 0,
! as there would not be UU gridpoints south of it otherwise
  do j = 2,jmt
    ! westernmost gridpoints (i=1)
    if ( DZT(1,j,k).ne.c0 ) then
      DVELDX(1,j,k) = p5*( ( DYU(1  ,j  )*DZU(1  ,j  ,k)*VEL(1  ,j  ,k)        &
                           + DYU(1  ,j-1)*DZU(1  ,j-1,k)*VEL(1  ,j-1,k) )      &
                         - ( DYU(imt,j  )*DZU(imt,j  ,k)*VEL(imt,j  ,k)        &
                           + DYU(imt,j-1)*DZU(imt,j-1,k)*VEL(imt,j-1,k) ) )    &
                         / TAREA(1,j) / DZT(1,j,k)
      DVELDY(1,j,k) = p5*( ( DXU(imt,j  )*DZU(imt,j  ,k)*VEL(imt,j  ,k)        &
                           + DXU(1  ,j  )*DZU(1  ,j  ,k)*VEL(1  ,j  ,k) )      &
                         - ( DXU(imt,j-1)*DZU(imt,j-1,k)*VEL(imt,j-1,k)        &
                           + DXU(1  ,j-1)*DZU(1  ,j-1,k)*VEL(1  ,j-1,k) ) )    &
                         / TAREA(1,j) / DZT(1,j,k)
    endif
    ! all gridpoints except western- and southernmost (i=1, j=1)
    do i = 2,imt
      if ( DZT(i,j,k).ne.c0 ) then
        DVELDX(i,j,k) = p5*( ( DYU(i  ,j  )*DZU(i  ,j  ,k)*VEL(i  ,j  ,k)      &
                             + DYU(i  ,j-1)*DZU(i  ,j-1,k)*VEL(i  ,j-1,k) )    &
                           - ( DYU(i-1,j  )*DZU(i-1,j  ,k)*VEL(i-1,j  ,k)      &
                             + DYU(i-1,j-1)*DZU(i-1,j-1,k)*VEL(i-1,j-1,k) ))   &
                           / TAREA(i,j) / DZT(i,j,k)
        DVELDY(i,j,k) = p5*( ( DXU(i-1,j  )*DZU(i-1,j  ,k)*VEL(i-1,j  ,k)      &
                             + DXU(i  ,j  )*DZU(i  ,j  ,k)*VEL(i  ,j  ,k) )    &
                           - ( DXU(i-1,j-1)*DZU(i-1,j-1,k)*VEL(i-1,j-1,k)      &
                             + DXU(i  ,j-1)*DZU(i  ,j-1,k)*VEL(i  ,j-1,k) ))   &
                           / TAREA(i,j) / DZT(i,j,k)
      endif
    enddo !i
  enddo !j
enddo !k

! vertical gradient
! top/bottom layer
do j = 1,jmt
  do i = 1,imt
    if ( DZT(i,j, 1).ne.c0 .and. DZT(i,j,2).ne.c0 ) then
      DVELDZ(i,j, 1) = 2*( TTT_VEL(i,j,1) - TTT_VEL(i,j,2) )                   &
                        / ( DZT(i,j,1) + DZT(i,j,2) )
    endif
    if ( DZT(i,j,km).ne.c0 ) then
      DVELDZ(i,j,km) = 2*( TTT_VEL(i,j,km-1) - TTT_VEL(i,j,km) )               &
                        / ( DZT(i,j,km-1) + DZT(i,j,km) )
    endif
  enddo !i
enddo !j

do k = 2,km-1
  do j = 1,jmt
    do i = 1,imt
      if ( DZT(i,j,k).ne.c0 .and. DZT(i,j,k+1).ne.c0 ) then
        DVELDZ(i,j,k) = ( ( TTT_VEL(i,j,k-1) - TTT_VEL(i,j,k) )                &
                          / ( DZT(i,j,k-1) + DZT(i,j,k) )                      &
                        + ( TTT_VEL(i,j,k) - TTT_VEL(i,j,k+1) )                &
                          / (DZT(i,j,k) + DZT(i,j,k+1) ) )
      elseif ( DZT(i,j,k).ne.c0 .and. DZT(i,j,k+1).eq.c0 ) then
        DVELDZ(i,j,k) = 2*( TTT_VEL(i,j,k-1) - TTT_VEL(i,j,k) )                &
                          / ( DZT(i,j,k-1) + DZT(i,j,k) )
      endif
    enddo !i
  enddo !j
enddo !k

end subroutine nabla_hvel
!===============================================================================

!===============================================================================
subroutine grad_rho(DZT,DZU,DXU,DYU,TAREA,UAREA,RHO,DRHODX,DRHODY)
!
!     calculates gradient components of RHO/PD
!     as described in POP reference manual
!     RHO/PD on 3111 grid, output on 3221 grid
!     units [g/cm^3/m]
!
implicit none

integer                                     :: i,j,k
integer, parameter                          :: imt=3600, jmt=2400, km=42
real,    dimension(imt,jmt),    intent(in)  :: DXU, DYU, TAREA, UAREA ![m]/[m2]
real,    dimension(imt,jmt,km), intent(in)  :: DZT, DZU, RHO ! [m], [g/cm^3]
!real,    dimension(imt,jmt,km)              :: DRHODX, DRHODY
!real,    dimension(imt,jmt,km), intent(out) :: TT_DRHODX, TT_DRHODY
real,    dimension(imt,jmt,km), intent(out) :: DRHODX, DRHODY
real,    parameter                          :: p5=0.5, c0=0.0

!write (*,*) 'grad rho started'

!DRHODX = c0
!DRHODY = c0

do k = 1,km

  ! northermost line between poles of tripolar grid
  do i = 1,imt-1
    if ( DZU(i,jmt,k).ne.c0 ) then
      if ( i.lt.imt/2 ) then      ! first half of array, before wrapping around
        DRHODX(i,jmt,k) = ( ( RHO(i+1    ,jmt,k) + RHO(imt-i  ,jmt,k) )        &
                          - ( RHO(i      ,jmt,k) + RHO(imt-i+1,jmt,k) ) )      &
                          / 2 / DXU(i,jmt)
        DRHODY(i,jmt,k) = ( ( RHO(imt-i+1,jmt,k) + RHO(imt-i  ,jmt,k) )        &
                          - ( RHO(i      ,jmt,k) + RHO(i+1    ,jmt,k) ) )      &
                          / 2 / DYU(i,jmt)
      elseif ( i.gt.imt/2 ) then  ! second half, after wrap
        DRHODX(i,jmt,k) = DRHODX(imt-i,jmt,k)
        DRHODY(i,jmt,k) = DRHODY(imt-i,jmt,k)
      endif
    endif
  enddo !i

  do j = 1,jmt-1

  ! eastern boundary
    if ( DZU(imt,j,k).ne.c0 ) then
      DRHODX(imt,j,k) = ( ( RHO(1  ,j  ,k) + RHO(1  ,j+1,k) )                  &
                        - ( RHO(imt,j  ,k) + RHO(imt,j+1,k) ) )                &
                        / 2 / DXU(imt,j)
      DRHODY(imt,j,k) = ( ( RHO(imt,j+1,k) + RHO(1  ,j+1,k) )                  &
                        - ( RHO(imt,j  ,k) + RHO(1  ,j  ,k) ) )                &
                        / 2 / DYU(imt,j)
    endif
  ! rest of arrays
    do i = 1,imt-1
      if ( DZU(i,j,k).ne.c0 ) then
        DRHODX(i,j,k) = ( ( RHO(i+1,j  ,k) + RHO(i+1,j+1,k) )                  &
                        - ( RHO(i  ,j  ,k) + RHO(i  ,j+1,k) ) )                &
                        / 2 / DXU(i,j)
        DRHODY(i,j,k) = ( ( RHO(i  ,j+1,k) + RHO(i+1,j+1,k) )                  &
                        - ( RHO(i  ,j  ,k) + RHO(i+1,j  ,k) ) )                &
                        / 2 / DYU(i,j)
      endif
    enddo !i
  enddo !j

!  ! Testing
!  do i = 1,imt
!    do j = 1,jmt
!      if ( ISNAN(DRHODX(i,j,k)) ) then
!        write (*,*) i,j,k, 'DRHODX is NaN'
!      endif
!      if ( ISNAN(DRHODY(i,j,k)) ) then
!        write (*,*) i,j,k, 'DRHODY is NaN'
!        if ( i.gt.3595 ) then
!          !write (*,*) DRHODX(i,j,k), DRHODY(i,j,k), kmT(i,j)
!          write (*,*) DZT(i,j,k), DZU(i,j,k), DYU(i,j)
!          write (*,*) RHO(i,j+1,k), RHO(i+1,j+1,k)
!          write (*,*) RHO(i,j,k), RHO(i+1,j,k)
!          write (*,*) ' '
!          !DRHODY(i,j,k) = c0
!        endif
!      endif
!      if ( DRHODY(i,j,k) == 1.0/0 .or. DRHODY(i,j,k) == -1/0.0 ) then
!        write (*,*) i,j,k, 'DRHODY is +/- Infinity'
!        DRHODY(i,j,k) = c0
!      endif
!    enddo !j
!  enddo !i

!  call uu2tt_scalar(DZT(:,:,k),DZU(:,:,k),TAREA,UAREA,               &
!                     DRHODX(:,:,k),TT_DRHODX(:,:,k))
!  call uu2tt_scalar(DZT(:,:,k),DZU(:,:,k),TAREA,UAREA,               &
!                     DRHODY(:,:,k),TT_DRHODY(:,:,k))

!  ! Testing
!  do j = 1,jmt
!    do i = 1,imt
!      if ( ISNAN(TT_DRHODX(i,j,k)) ) then
!        write (*,*) i,j,k, 'TTT_DRHODX is NaN'
!        !write (*,*)  DZT(i,j,k), DZU(i,j,k), kmT(i,j), DXU(i,j)
!        write (*,*)  DRHODX(i-1,j,k), DRHODX(i,j,k)
!        write (*,*)  DRHODX(i-1,j-1,k), DRHODX(i,j-1,k)
!        TT_DRHODX(i,j,k) = c0
!      endif
!      if ( ISNAN(TT_DRHODY(i,j,k)) ) then
!        write (*,*) i,j,k, 'TTT_DRHODY is NaN'
!        !write (*,*)  DZT(i,j,k), DZU(i,j,k), kmT(i,j), DYU(i,j)
!        write (*,*)  DRHODY(i-1,j,k), DRHODY(i,j,k)
!        write (*,*)  DRHODY(i-1,j-1,k), DRHODY(i,j-1,k)
!        TT_DRHODY(i,j,k) = c0
!      endif
!    enddo !i
!  enddo !j

enddo !k

end subroutine grad_rho
!===============================================================================

!===============================================================================
subroutine vert_der(avg,dz,ddz)
! vertical derivative
integer                             :: i,j,k
integer, parameter                  :: imt=3600, jmt=2400, km=42
real,    dimension(km), intent(in)  :: avg, dz
real,    dimension(km), intent(out) :: ddz

do k = 1, km
  if ( k==1 ) then
    ddz(k) = ( avg(k  ) - avg(k+1) ) / dz(k)
  else if ( k==km ) then
    ddz(k) = ( avg(k-1) - avg(k  ) ) / dz(k)
  else
    ddz(k) = ( avg(k-1) - avg(k+1) ) / 2.0 / dz(k)
  endif
enddo !k

end subroutine vert_der
!===============================================================================

!===============================================================================
subroutine gradient(DXU,DYU,F,GRADX,GRADY)
implicit none
!
!  calculate hydrostatic pressure with in-situ density
!
integer                                     :: i,j,k
integer, parameter                          :: imt=3600, jmt=2400, km=42
real,    dimension(imt,jmt)   , intent(in)  :: DXU,DYU
real,    dimension(imt,jmt,km), intent(in)  :: F ! field at T-points
real,    dimension(imt,jmt,km), intent(out) :: GRADX,GRADY ! at U-points
real,    parameter                          :: p5 = 0.5
do k=1,km
do j=1,jmt
do i=1,imt
  GRADX(i,j,k) = p5*(F(i+1,j+1,k) - F(i,j,k) - F(i,j+1,k) + F(i+1,j,k))/DXU(i,j)
  GRADY(i,j,k) = p5*(F(i+1,j+1,k) - F(i,j,k) + F(i,j+1,k) - F(i+1,j,k))/DYU(i,j)
enddo !i
enddo !j
enddo !k
end subroutine gradient
!===============================================================================


    SUBROUTINE DGEGV_F95( A, B, ALPHAR, ALPHAI, BETA, VL, VR, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO
   USE F77_LAPACK, ONLY: GEGV_F77 => LA_GEGV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   REAL(WP), INTENT(INOUT) :: A(:,:), B(:,:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: ALPHAR(:), ALPHAI(:), BETA(:)
   REAL(WP), INTENT(OUT), OPTIONAL, TARGET :: VL(:,:), VR(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
!  LA_GEGV computes for a pair of N-by-N complex nonsymmetric
!  matrices A and B, the generalized eigenvalues (alpha, beta),
!  and optionally, the left and/or right generalized eigenvectors
!  (VL and VR).
!  A generalized eigenvalue for a pair of matrices (A,B) is, roughly
!  speaking, a scalar w or a ratio  alpha/beta = w, such that  A - w*B
!  is singular.  It is usually represented as the pair (alpha,beta),
!  as there is a reasonable interpretation for beta=0, and even for
!  both being zero.  A good beginning reference is the book, "Matrix
!  Computations", by G. Golub & C. van Loan (Johns Hopkins U. Press)
!  A right generalized eigenvector corresponding to a generalized
!  eigenvalue  w  for a pair of matrices (A,B) is a vector  r  such
!  that  (A - w B) r = 0 .  A left generalized eigenvector is a vector
!  l such that l**H * (A - w B) = 0, where l**H is the
!  conjugate-transpose of l.
!  Note: this routine performs "full balancing" on A and B -- see
!  "Further Details", below.
!
! =========
!
!   SUBROUTINE LA_GEGV( A, B, <alpha>, BETA, VL, VR, INFO )
!      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!      <type>(<wp>), INTENT(INOUT) :: A(:,:), B(:,:)
!      <type>(<wp>), INTENT(OUT), OPTIONAL :: <alpha'>, BETA(:)
!      <type>(<wp>), INTENT(OUT), OPTIONAL :: VL(:,:), VR(:,:)
!   where
!      <type>   ::= REAL | COMPLEX
!      <wp>     ::= KIND(1.0) | KIND(1.0D0)
!      <alpha>  ::= ALPHAR, ALPHAI | ALPHA
!      <alpha'> ::= ALPHAR(:), ALPHAI(:) | ALPHA(:)
!
! Arguments
! =========
!
! A    (input/output) REAL / COMPLEX array, shape (:,:),
!      SIZE(A,1) == SIZE(A,2) == n.
!      On entry, the first of the pair of matrices whose
!      generalized eigenvalues and (optionally) generalized
!      eigenvectors are to be computed.
!      On exit, the contents will have been destroyed.  (For a
!      description of the contents of A on exit, see "Further
!      Details", below.)
!
! B    (input/output) REAL / COMPLEX array, shape (:,:),
!      SIZE(rBA,1) == SIZE(rBA,2) == n.
!      On entry, the second of the pair of matrices whose
!      generalized eigenvalues and (optionally) generalized
!      eigenvectors are to be computed.
!      On exit, the contents will have been destroyed.  (For a
!      description of the contents of B on exit, see "Further
!      Details", below.)
!
! ALPHAR  Only for the real case. Optional (output) REAL array,
! ALPHAI  shape (:), SIZE(ALPHA') == n. ALPHA ::= ALPHAR | ALPHAI
! ALPHA   Only for the complex case. Optional (output) COMPLEX
!         array, shape (:), SIZE(ALPHAI) == n.
! BETA Optional (output) REAL / COMPLEX array, shape (:),
!      SIZE(BETA) == n.
!      On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,n, will
!      be the generalized eigenvalues.  If ALPHAI(j) is zero, then
!      the j-th eigenvalue is real; if positive, then the j-th and
!      (j+1)-st eigenvalues are a complex conjugate pair, with
!      ALPHAI(j+1) negative.
!      Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
!      may easily over- or underflow, and BETA(j) may even be zero.
!      Thus, the user should avoid naively computing the ratio
!      alpha/beta.  However, ALPHAR and ALPHAI will be always less
!      than and usually comparable with norm(A) in magnitude, and
!      BETA always less than and usually comparable with norm(B).
!
! VL   Optional (output) REAL / COMPLEX array, shape (:,:),
!      SIZE(VL,1) == SIZE(VL,2) == n.
!      The left generalized eigenvectors.  (See "Purpose", above.)
!      Real eigenvectors take one column,
!      complex take two columns, the first for the real part and
!      the second for the imaginary part.  Complex eigenvectors
!      correspond to an eigenvalue with positive imaginary part.
!      Each eigenvector will be scaled so the largest component
!      will have abs(real part) + abs(imag. part) = 1, *except*
!      that for eigenvalues with alpha=beta=0, a zero vector will
!      be returned as the corresponding eigenvector.
!
! VR   Optional (output) REAL / COMPLEX array, shape (:,:),
!      SIZE(VR,1) == SIZE(VR,2) == n.
!      The right generalized eigenvectors.  (See "Purpose", above.)
!      Real eigenvectors take one column,
!      complex take two columns, the first for the real part and
!      the second for the imaginary part.  Complex eigenvectors
!      correspond to an eigenvalue with positive imaginary part.
!      Each eigenvector will be scaled so the largest component
!      will have abs(real part) + abs(imag. part) = 1, *except*
!      that for eigenvalues with alpha=beta=0, a zero vector will
!      be returned as the corresponding eigenvector.
!
! INFO (output) INTEGER
!      = 0:  successful exit
!      < 0:  if INFO = -i, the i-th argument had an illegal value.
!      = 1,...,n:
!            The QZ iteration failed.  No eigenvectors have been
!            calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
!            should be correct for j=INFO+1,...,n.
!      > n:  errors that usually indicate LAPACK problems:
!            =n+1: error return from LA_GGBAL
!            =n+2: error return from LA_GEQRF
!            =n+3: error return from LA_ORMQR
!            =n+4: error return from LA_ORGQR
!            =n+5: error return from LA_GGHRD
!            =n+6: error return from LA_HGEQZ (other than failed
!                                            iteration)
!            =n+7: error return from LA_TGEVC
!            =n+8: error return from LA_GGBAK (computing VL)
!            =n+9: error return from LA_GGBAK (computing VR)
!            =n+10: error return from LA_LASCL (various calls)
!      If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!
! Further Details
! ===============
!
! Balancing
! ---------
!
! This driver calls SGGBAL to both permute and scale rows and columns
! of A and B.  The permutations PL and PR are chosen so that PL*A*PR
! and PL*B*R will be upper triangular except for the diagonal blocks
! A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
! possible.  The diagonal scaling matrices DL and DR are chosen so
! that the pair  DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
! one (except for the elements that start out zero.)
!
! After the eigenvalues and eigenvectors of the balanced matrices
! have been computed, SGGBAK transforms the eigenvectors back to what
! they would have been (in perfect arithmetic) if they had not been
! balanced.
!
! Contents of A and B on Exit
! -------- -- - --- - -- ----
!
! If any eigenvectors are computed (either VL or VR or both), then on
! exit the arrays A and B will contain the real Schur form[*] of the
! "balanced" versions of A and B. If no eigenvectors are computed,
! then only the diagonal blocks will be correct.
!
! [*] See LA_HGEQZ, LA_GEGS, or read the book "Matrix Computations",
!     by Golub & van Loan, pub. by Johns Hopkins U. Press.
!--------------------------------------------------------------
!  .. LOCAL PARAMETERS ..
   CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GEGV'
!  .. LOCAL SCALARS ..
   CHARACTER(LEN=1) :: LJOBVL, LJOBVR
   INTEGER, SAVE :: LWORK = 0
   INTEGER :: N, LINFO, LD, ISTAT, ISTAT1, S1VL, S2VL, S1VR, S2VR, &
              SALPHAR, SALPHAI, SBETA
!  .. LOCAL ARRAYS ..
   REAL(WP), TARGET :: LLVL(1,1), LLVR(1,1)
   REAL(WP), POINTER :: WORK(:), LALPHAR(:), &
                        LALPHAI(:), LBETA(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC MAX, PRESENT, SIZE
!  .. EXECUTABLE STATEMENTS ..
   LINFO = 0; ISTAT = 0; N = SIZE(A,1); LD = MAX(1,N)
   IF( PRESENT(ALPHAR) )THEN; SALPHAR = SIZE(ALPHAR); ELSE; SALPHAR = N; ENDIF
   IF( PRESENT(ALPHAI) )THEN; SALPHAI = SIZE(ALPHAI); ELSE; SALPHAI = N; ENDIF
   IF( PRESENT(BETA) )THEN; SBETA = SIZE(BETA); ELSE; SBETA = N; ENDIF
   IF( PRESENT(VL) )THEN; S1VL = SIZE(VL,1); S2VL = SIZE(VL,2); LJOBVL = 'V'
   ELSE; S1VL = 1; S2VL = 1; LJOBVL = 'N'; END IF
   IF( PRESENT(VR) )THEN; S1VR = SIZE(VR,1); S2VR = SIZE(VR,2); LJOBVR = 'V'
   ELSE; S1VR = 1; S2VR = 1; LJOBVR = 'N'; END IF
!  .. TEST THE ARGUMENTS
   IF( N < 0 .OR. SIZE(A,2) /= N )THEN; LINFO = -1
   ELSE IF( SIZE(B,1) /= N .OR. SIZE(B,2) /= N )THEN; LINFO = -2
   ELSE IF( SALPHAR /= N )THEN; LINFO = -3
   ELSE IF( SALPHAI /= N )THEN; LINFO = -4
   ELSE IF( SBETA /= N )THEN; LINFO = -5
   ELSE IF( PRESENT(VL) .AND. ( S1VL /= N .OR. S2VL /= N ) )THEN; LINFO = -6
   ELSE IF( PRESENT(VR) .AND. ( S1VR /= N .OR. S2VR /= N ) )THEN; LINFO = -7
   ELSE IF( N > 0 )THEN
      IF( PRESENT(ALPHAR) )THEN; LALPHAR => ALPHAR
      ELSE; ALLOCATE(LALPHAR(N),STAT=ISTAT); ENDIF
      IF( ISTAT == 0 )THEN
         IF( PRESENT(ALPHAI) )THEN; LALPHAI => ALPHAI
         ELSE; ALLOCATE(LALPHAI(N),STAT=ISTAT); ENDIF
      END IF
      IF( ISTAT == 0 )THEN
         IF( PRESENT(BETA) )THEN; LBETA => BETA
         ELSE; ALLOCATE(LBETA(N),STAT=ISTAT); ENDIF
      END IF
      IF( ISTAT == 0 )THEN
         LWORK = MAX( 1, 8*N, LWORK); ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT /= 0 )THEN; DEALLOCATE(WORK,STAT=ISTAT1)
            LWORK = MAX( 1, 8*N ); ALLOCATE(WORK(LWORK), STAT=ISTAT)
            IF( ISTAT == 0) CALL ERINFO( -200, SRNAME, LINFO )
         END IF
      END IF
      IF( ISTAT == 0 ) THEN
         IF( PRESENT(VL) )THEN
          IF( PRESENT(VR) )THEN
            CALL GEGV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, VL, S1VL, VR, S1VR, WORK, LWORK, LINFO )
	   ELSE
	     CALL GEGV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, VL, S1VL, LLVR, S1VR, WORK, LWORK, LINFO )
	   ENDIF
	  ELSE
	   IF( PRESENT(VR) )THEN
	     CALL GEGV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, LLVL, S1VL, VR, S1VR, WORK, LWORK, LINFO )
	   ELSE
	      CALL GEGV_F77( LJOBVL, LJOBVR, N, A, LD, B, LD, LALPHAR, LALPHAI, &
                        LBETA, LLVL, S1VL, LLVR, S1VR, WORK, LWORK, LINFO )
	  ENDIF
	 ENDIF
         IF( LINFO == 0 ) LWORK = INT(WORK(1)+1)
      ELSE; LINFO = -100; ENDIF
      DEALLOCATE(WORK, STAT=ISTAT1)
   ENDIF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DGEGV_F95


      PROGRAM TSCURVE
      IMPLICIT NONE
C
C  hycom_ts - Usage:  hycom_ts density
C
C                 generates a text file table of T and S at density
C                 for HYCOM's equation of state (sigma0 version).
C
C  this version for "serial" Unix systems.
C
C  Alan J. Wallcraft,  Naval Research Laboratory,  August 2001.
C
      INTEGER      IARGC
      INTEGER      NARG
      CHARACTER*240 CARG
C
      INTEGER      ITT
      REAL*8       RR,TT,SS
c
c --- coefficients for sigma-0 (based on Brydon & Sun fit)
      real*8     c1,c2,c3,c4,c5,c6,c7
      parameter (c1=-1.36471E-01, c2= 4.68181E-02, c3= 8.07004E-01,
     .           c4=-7.45353E-03, c5=-2.94418E-03,
     .           c6= 3.43570E-05, c7= 3.48658E-05)
c
c --- coefficients for sigma-2 (based on Brydon & Sun fit)
csig2 real       c1,c2,c3,c4,c5,c6,c7
csig2 parameter (c1= 9.77093E+00, c2=-2.26493E-02, c3= 7.89879E-01,
csig2.           c4=-6.43205E-03, c5=-2.62983E-03,
csig2.           c6= 2.75835E-05, c7= 3.15235E-05)
c
c --- salinity (mil) as a function of sigma and temperature (deg c)
      real*8 sofsig,r,t
      sofsig(r,t)=(r-c1-t*(c2+t*(c4+c6*t)))/(c3+t*(c5+c7*t))
C
C     READ ARGUMENTS.
C
      NARG = IARGC()
C
      IF     (NARG.EQ.1) THEN
        CALL GETARG(1,CARG)
        READ(CARG,*) RR
      ELSE
        WRITE(6,*) 'Usage: hycom_ts density'
        CALL EXIT(1)
      ENDIF
C
      WRITE(6,'(a,f7.3 / a)')
     &  '#   HYCOM equation of state, potential density =',RR,
     &  '#      T          S        RHO'
C
      DO ITT= -50,350
        TT = ITT*0.1
        SS = SOFSIG(RR,TT)
        WRITE(6,'(3f11.6)') TT,SS,RR
      ENDDO
      END


      DOUBLE PRECISION FUNCTION D1MACH (I)
      IMPLICIT NONE
      INTEGER :: I
      DOUBLE PRECISION :: B, X
      X = 1.0D0

      B = RADIX(X)
      SELECT CASE (I)
      CASE (1)
         D1MACH = B**(MINEXPONENT(X)-1) ! the smallest positive magnitude.
      CASE (2)
         D1MACH = HUGE(X)       ! the largest magnitude.
      CASE (3)
         D1MACH = B**(-DIGITS(X)) ! the smallest relative spacing.
      CASE (4)
         D1MACH = B**(1-DIGITS(X)) ! the largest relative spacing.
      CASE (5)
         D1MACH = log10(B)
      CASE DEFAULT
         WRITE (*, FMT = 9000)
 9000    FORMAT ('1ERROR    1 IN D1MACH - I OUT OF BOUNDS')
         STOP
      END SELECT

!!      write(*,*)I,  D1MACH

      RETURN

      end function d1mach


      subroutine newnot ( break, coef, l, k, brknew, lnew, coefg )
c  from  * a practical guide to splines *  by c. de boor
c  returns  lnew+1  knots in  brknew  which are equidistributed on (a,b)
c  = (break(1),break(l+1)) wrto a certain monotone fctn  g  related to
c  the k-th root of the k-th derivative of the pp function  f  whose pp-
c  representation is contained in  break, coef, l, k .
c
c******  i n p u t ******
c  break, coef, l, k.....contains the pp-representation of a certain
c	 function  f  of order	k . specifically,
c	 d**(k-1)f(x) = coef(k,i)  for	break(i).le. x .lt.break(i+1)
c  lnew.....number of intervals into which the interval (a,b) is to be
c	 sectioned by the new breakpoint sequence  brknew .
c
c******  o u t p u t  ******
c  brknew.....array of length  lnew+1  containing the new breakpoint se-
c	 quence
c  coefg.....the coefficient part of the pp-repr.  break, coefg, l, 2
c	 for the monotone p.linear function  g	wrto which  brknew  will
c	 be equidistributed.
c
c******  optional  p r i n t e d  o u t p u t  ******
c  coefg.....the pp coeffs of  g  are printed out if  iprint  is set
c	 .gt. 0  in data statement below.
c
c******  m e t h o d  ******
c     the k-th derivative of the given pp function  f  does not exist
c  (except perhaps as a linear combination of delta functions). never-
c  theless, we construct a p.constant function	h  with breakpoint se-
c  quence  break  which is approximately proportional to abs(d**k(f)).
c  specifically, on  (break(i), break(i+1)),
c
c     abs(jump at break(i) of pc)    abs(jump at break(i+1) of pc)
c h = --------------------------  +  ----------------------------
c	break(i+1) - break(i-1) 	break(i+2) - break(i)
c
c  with  pc  the p.constant (k-1)st derivative of  f .
c      then, the p.linear function  g  is constructed as
c
c    g(x)  =  integral of  h(y)**(1/k)	for  y	from  a  to  x
c
c  and its pp coeffs. stored in  coefg .
c     then  brknew  is determined by
c
c	 brknew(i)  =  a + g**(-1)((i-1)*step) , i=1,...,lnew+1
c
c  where  step = g(b)/lnew  and  (a,b) = (break(1),break(l+1)) .
c     in the event that  pc = d**(k-1)(f) is constant in  (a,b)  and
c  therefore  h = 0 identically,  brknew  is chosen uniformly spaced.
c
      integer k,l,lnew,   i,iprint,j
      real break(1),brknew(1),coef(k,l),coefg(2,l),   dif,difprv,oneovk
     *						     ,step,stepi
c     dimension break(l+1), brknew(lnew+1)
current fortran standard makes it impossible to specify the dimension
c  of  break   and  brknew  without the introduction of additional
c  otherwise superfluous arguments.
      data iprint /0/
c
      brknew(1) = break(1)
      brknew(lnew+1) = break(l+1)
c				if  g  is constant,  brknew  is uniform.
      if (l .le. 1)			go to 90
c			 construct the continuous p.linear function  g .
      oneovk = 1./float(k)
      coefg(1,1) = 0.
      difprv = abs(coef(k,2) - coef(k,1))/(break(3)-break(1))
      do 10 i=2,l
	 dif = abs(coef(k,i) - coef(k,i-1))/(break(i+1) - break(i-1))
	 coefg(2,i-1) = (dif + difprv)**oneovk
	 coefg(1,i) = coefg(1,i-1)+coefg(2,i-1)*(break(i)-break(i-1))
   10	 difprv = dif
      coefg(2,l) = (2.*difprv)**oneovk
c						      step  =  g(b)/lnew
      step = (coefg(1,l)+coefg(2,l)*(break(l+1)-break(l)))/float(lnew)
c
      if (iprint .gt. 0) print 600, step,(i,coefg(1,i),coefg(2,i),i=1,l)
  600 format(7h step =,e16.7/(i5,2e16.5))
c			       if  g  is constant,  brknew  is uniform .
      if (step .le. 0.) 		go to 90
c
c      for i=2,...,lnew, construct  brknew(i) = a + g**(-1)(stepi),
c      with  stepi = (i-1)*step .  this requires inversion of the p.lin-
c      ear function  g .  for this,  j	is found so that
c	  g(break(j)) .le. stepi .le. g(break(j+1))
c      and then
c	  brknew(i)  =	break(j) + (stepi-g(break(j)))/dg(break(j)) .
c      the midpoint is chosen if  dg(break(j)) = 0 .
      j = 1
      do 30 i=2,lnew
	 stepi = float(i-1)*step
   21	    if (j .eq. l)		go to 27
	    if (stepi .le. coefg(1,j+1))go to 27
	    j = j + 1
					go to 21
   27	 if (coefg(2,j) .eq. 0.)	go to 29
	    brknew(i) = break(j) + (stepi - coefg(1,j))/coefg(2,j)
					go to 30
   29	    brknew(i) = (break(j) + break(j+1))/2.
   30	 continue
					return
c
c			       if  g  is constant,  brknew  is uniform .
   90 step = (break(l+1) - break(1))/float(lnew)
      do 93 i=2,lnew
   93	 brknew(i) = break(1) + float(i-1)*step
					return
      end


      SUBROUTINE AWI (IDL,IL,ALON,JL,ALAT,A,MASK,
     1                IDLO,ILO,ALONO,JLO,ALATO,AO,MASKO,IER)

      IMPLICIT NONE
C
C          This subroutine does an area weighted average from one grid,
C          on a spherical earth, to another.  Logical masks may be assigned
C          for each grid, and only those grid boxes which are masked true
C          on both grids will be used.  A value of AMM   will be assigned
C          to all nodes of the new grid which are initially false or have
C          no data from the old grid.  The new mask will also be changed to
C          false where no data is available.
C
C          Restrictions:  Longitude must be the first dimension and it
C                         be monotonically increasing (West to East).
C
C                         Latitude must be the second dimension and it
C                         must be monotonic.
C
C                         Values for longitude and latitude must be in
C                         degrees.
C
C                         Arrays that wrap around must repeat longitudes
C                         with a 360 degree increment.  It will be assumed
C                         that values in the wrapped input and mask arrays
C                         will also repeat (wrapped values in these arrays
C                         will not be used).
C
C        INPUT
C
C   integer   IDL    First dimension of input A and MASK.
C   integer   IL     Number of grid boxes in longitude for A and MASK.
C   real      ALON   Longitude (deg) limits of grid boxes for A and MASK.
C   integer   JL     Number of grid boxes in latitude for A and MASK.
C   real      ALAT   Latitude (deg) limits of grid boxes for A and MASK.
C   real      A      Array of input data.
C   logical   MASK   Mask for input data (.FALSE. to mask out data).
C
C        OUTPUT
C
C   integer   IDLO   First dimension of output AO and MASKO.
C   integer   ILO    Number of grid boxes in longitude for AO and MASKO.
C   real      ALONO  Longitude (deg) limits of grid boxes for AO and MASKO.
C   integer   JLO    Number of grid boxes in latitude for AO and MASKO.
C   real      ALATO  Latitude (deg) limits of grid boxes for AO and MASKO.
C   real      AO     Array of output data.
C   logical   MASKO  Mask for output data (.FALSE. to mask out data).
C   integer   IER    Error indication:
C                    (values may be summed for multiple errors)
C                    0  no errors
C                    1  input longitude dimension and/or length <=0.
C                    2  output dimension and/or length <=0.
C                    4  input latititude dimension <=0.
C                    8  output latitude dimension <=0.
C                   16  wrap-around on input longitude grid doesn't
C                       repeat (+360).
C                   32  wrap-around on output longitude grid doesn't
C                       repeat (+360).
C                   64  longitude of input is not monotonic increasing.
C                  128  longitude of output is not monotonic increasing.
C                  256  latitude of input is not monotonic.
C                  512  latitude of output is not monotonic.
C                 1024  input longitude wraps but doesn't repeat identically.
C                 2048  output longitude wraps but doesn't repeat identically.
C                   -1  output mask is changed.
C                   -2  output mask contains all false values.
C
      INTEGER IL,JL,ILO,JLO,IDL,IDLO,IER,I,J,IIL,IILO
      INTEGER J1,J2,JJ,I1,I2,K,II,III,IIP
      REAL    API,AMM,ALON,ALONO,SGN,ALAT,ALATO,ALMX
      REAL    ALMN,AL,DLN,ALMXO,ALMNO,DLNO,AMNLTO
      REAL    AMXLTO,AMNLT,AMXLT,AO,AMNLNO,AMXLNO
      REAL    AMNLN,AMXLN,WT,AVG,SLATMX,SLATMN,WLAT
      REAL    SLON,SLONP,SLONMX,SLONMN,DELON,A
      DIMENSION ALON(IL+1),ALAT(JL+1),ALONO(ILO+1),ALATO(JLO+1)
      LOGICAL MASK(IDL,JL),MASKO(IDLO,JLO)
      DIMENSION A(IDL,JL),AO(IDLO,JLO)
C
      DATA API /3.1415926536/
C                       Check dimensions and lengths.
C  PJV MODIFICATION 11 2 92
C
      AMM=50.
C
      IER=0
      IF (IDL.LT.IL.OR.IL.LE.0) IER=1
      IF (IDLO.LT.ILO.OR.ILO.LE.0) IER=IER+2
      IF (JL.LE.0) IER=IER+4
      IF (JLO.LE.0) IER=IER+8
C
      IF (IER.GT.0) RETURN
C                        Check monotonic increasing input longitudes.
      DO 1 I=2,IL
      IF (ALON(I).LE.ALON(I-1)) THEN
        IER=IER+64
        GO TO 2
      ENDIF
  1   CONTINUE
  2   CONTINUE
C                       Check monotonic increasing output longitudes.
      DO 3 I=2,ILO
      IF (ALONO(I).LE.ALONO(I-1)) THEN
        IER=IER+128
        GO TO 4
      ENDIF
  3   CONTINUE
  4   CONTINUE
C                     Check monotonicity of input latitudes.
      SGN=(ALAT(2)-ALAT(1))
      DO 5 J=2,JL
      IF (SGN.LT.0.0) THEN
        IF (ALAT(J)-ALAT(J-1).GE.0) THEN
          IER=IER+256
          GO TO 6
        ENDIF
      ELSE IF (SGN.GT.0.0) THEN
        IF (ALAT(J)-ALAT(J-1).LE.0.0) THEN
          IER=IER+256
          GO TO 6
        ENDIF
      ELSE
        IER=IER+256
        GO TO 6
      ENDIF
  5   CONTINUE
  6   CONTINUE
C                    Check monotonicity of output latitudes.
      SGN=(ALATO(2)-ALATO(1))
      DO 7 J=2,JLO
      IF (SGN.LT.0.0) THEN
        IF (ALATO(J)-ALATO(J-1).GE.0.0) THEN
          IER=IER+512
          GO TO 8
        ENDIF
      ELSE IF (SGN.GT.0.0) THEN
        IF (ALATO(J)-ALATO(J-1).LE.0.0) THEN
          IER=IER+512
          GO TO 8
        ENDIF
      ELSE
        IER=IER+512
        GO TO 8
      ENDIF
  7   CONTINUE
  8   CONTINUE
C                       Find wrap around of input grid, if it exists.
      IIL=IL
      ALMX=ALON(1)
      ALMN=ALON(1)
      DO 10 I=2,IL+1
      ALMX=MAX(ALMX,ALON(I))
      ALMN=MIN(ALMN,ALON(I))
      AL=ABS(ALON(I)-ALON(1))-360.0
      IF (ABS(AL).LE.1.E-4) THEN
        IIL=I-1
        GO TO 11
      ELSE IF (AL.GT.0.0) THEN
        IER=IER+1024
        GO TO 12
      ENDIF
  10  CONTINUE
  11  CONTINUE
      DLN=0.0
      IF (ALMN.LT.0.0) THEN
        DLN=INT(-ALMN/360.0+.001)*360.0
      ELSE IF (ALMN.GT.360.0) THEN
        DLN=-INT(ALMN/360.0+.001)*360.0
      ENDIF
  12  CONTINUE
C                       Find wrap around of output grid, if it exists.
      IILO=ILO
      ALMXO=ALONO(1)
      ALMNO=ALONO(1)
      DO 13 I=2,ILO+1
      ALMXO=MAX(ALMXO,ALONO(I))
      ALMNO=MIN(ALMNO,ALONO(I))
      AL=ABS(ALONO(I)-ALONO(1))-360.0
      IF (ABS(AL).LE.1.E-4) THEN
        IILO=I-1
        GO TO 14
      ELSE IF (AL.GT.0.0) THEN
        IER=IER+2048
        GO TO 15
      ENDIF
  13  CONTINUE
  14  CONTINUE
      DLNO=0.0
      IF (ALMNO.LT.0.0) THEN
        DLNO=INT(-ALMNO/360.0+.001)*360.0
      ELSE IF (ALMNO.GT.360.0) THEN
        DLNO=-INT(ALMNO/360.0+.001)*360.0
      ENDIF
  15  CONTINUE
C                     Test for errors.  Return if any.
      IF (IER.NE.0) RETURN
C                     The output grid needs to begin with or after the
C                     input grid.
      IF (ALMNO+DLNO.LT.ALMN+DLN) DLNO=DLNO+360.0
C
      DO 200 J=1,JLO
C              Find index limits In latitude to cover the new grid.
      J1=JL+1
      J2=0
      AMNLTO=MIN(ALATO(J),ALATO(J+1))
      AMXLTO=MAX(ALATO(J),ALATO(J+1))
C
C                     Search for index limits in J.
C
      DO 17 JJ=1,JL
      AMNLT=MIN(ALAT(JJ),ALAT(JJ+1))
      AMXLT=MAX(ALAT(JJ),ALAT(JJ+1))
C                     FIND JJ LIMITS
      IF (AMXLT.GT.AMNLTO.AND.AMNLT.LT.AMXLTO) THEN
        J1=MIN(JJ,J1)
        J2=MAX(JJ,J2)
      ENDIF
C
  17  CONTINUE
C                     If input grid doesn't at least partially cover the
C                     output grid box, no values will be assigned.  Mask out
C                     all values for the latitude.
C
      IF (J2.LT.J1) THEN
        DO 20 I=1,IILO
        AO(I,J)=amm
        IF (MASKO(I,J)) IER=-1
        MASKO(I,J)=.FALSE.
  20    CONTINUE
        GO TO 200
      ENDIF
C  TEMPORARY *******************************************************
C      AMNLT=MIN(MIN(ALAT(J1),ALAT(J1+1)),MIN(ALAT(J2),ALAT(J2+1)))
C      AMXLT=MAX(MAX(ALAT(J1),ALAT(J1+1)),MAX(ALAT(J2),ALAT(J2+1)))
C
C      WRITE (NOUT,90) J1,J2,AMNLT,AMXLT
C  90  FORMAT ('J',2I6,2F9.3)
C
      DO 100 I=1,IILO
C              No need to compute if it is masked out.
      IF (.NOT.MASKO(I,J)) GO TO 100
C              Find index limits in longitude to cover the new grid.
      I1=3*IL+1
      I2=0
      AMNLNO=MIN(ALONO(I),ALONO(I+1))+DLNO
      AMXLNO=MAX(ALONO(I),ALONO(I+1))+DLNO
C
C                     Search for index limits in I.
C                     Because of wrap around it is necessary to
C                     look through the data twice.
C                     The output grid longitudes have been adjusted
C                     (using DLNO) such that the first longitude in
C                     the output grid is greater than the first
C                     longitude on the input grid.
C
      DO 35 K=0,1
      DO 30 II=1,IIL
      AMNLN=MIN(ALON(II),ALON(II+1))+DLN+K*360.0
      AMXLN=MAX(ALON(II),ALON(II+1))+DLN+K*360.0
C                     FIND II LIMITS
      IF (AMXLN.GT.AMNLNO.AND.AMNLN.LT.AMXLNO) THEN
        I1=MIN(II+K*IL,I1)
        I2=MAX(II+K*IL,I2)
      ENDIF
C
  30  CONTINUE
  35  CONTINUE
C                     If input grid doesn't partially cover the output
C                     grid box, no values will be assigned.  Mask out
C                     the grid box.
      IF (I2.LT.I1) THEN
        AO(I,J)=amm
        IF (MASKO(I,J)) IER=-1
        MASKO(I,J)=.FALSE.
        GO TO 100
      ENDIF
C  TEMPORARY
C      WRITE (NOUT,91) I1,I2,AMNLNO,AMXLNO
C  91  FORMAT ('I',2I6,2F9.3)
C
      WT=0.0
      AVG=0.0
      DO 50 JJ=J1,J2
      SLATMX=MAX(ALAT(JJ),ALAT(JJ+1))
      SLATMN=MIN(ALAT(JJ),ALAT(JJ+1))
      WLAT=MAX(SIN(MIN(AMXLTO,SLATMX)*API/180.)-
     1         SIN(MAX(AMNLTO,SLATMN)*API/180.),0.0)
      IF (WLAT.NE.0.0) THEN
        DO 40 III=I1,I2
        SLON=DLN
        SLONP=DLN
        IF (III.GT.IIL) THEN
          SLON=SLON+360.
          SLONP=SLONP+360.
        ENDIF
        II=MOD(III-1,IIL)+1
        IIP=II+1
        IF (MASK(II,JJ)) THEN
          SLON=SLON+ALON(II)
          SLONP=SLONP+ALON(IIP)
          SLONMX=MAX(SLON,SLONP)
          SLONMN=MIN(SLON,SLONP)
          DELON=MAX(MIN(AMXLNO,SLONMX)-
     1            MAX(AMNLNO,SLONMN),0.0)
C          WRITE (NOUT,92) MAX(SLATMN,AMNLTO),MIN(SLATMX,AMXLTO),
C     1                 MAX(SLONMN,AMNLNO),MIN(SLONMX,AMXLNO),DELON
C  92      FORMAT (' LAT ',2F9.3,' LON ',2F9.3,' DLON ',F9.3)
C          WRITE (NOUT,93) SLONMN,SLONMX,AMNLNO,AMXLNO
C  93      FORMAT (' IN ',2F9.3,' OUT ',2F9.3)
          WT=WT+WLAT*DELON
          AVG=AVG+A(II,JJ)*WLAT*DELON
        ENDIF
  40    CONTINUE
      ENDIF
  50  CONTINUE
      IF (WT.GT.0.0) THEN
        AO(I,J)=AVG/WT
      ELSE
        AO(I,J)=amm
        IF (MASKO(I,J)) IER=-1
        MASKO(I,J)=.FALSE.
      ENDIF
 100  CONTINUE
 200  CONTINUE
C                     Finish filling the output array from wrap-around.
      IF (IILO.LT.ILO) THEN
        DO 300 J=1,JLO
        DO 300 I=IILO+1,ILO
        AO(I,J)=AO(I-IILO,J)
        MASKO(I,J)=MASKO(I-IILO,J)
 300    CONTINUE
      ENDIF
C                     Check if output MASKO is all false.
      DO 400 J=1,JLO
      DO 400 I=1,ILO
      IF (MASKO(I,J)) GO TO 500
 400  CONTINUE
      IER=-2
 500  CONTINUE
      RETURN
      END


      subroutine pres2z(ps, pm,  rair, gravit, tv, z, nlev)
C-----------------------------------------------------------------------
C
C Compute the geopotential height *ABOVE THE SURFACE* at layer
C midpoints from the virtual temperatures and pressures.
c The code is a modified version of the subroutine zmid in the NCAR
c Community Climate Model v3.6.
C
C------------------------------Arguments--------------------------------
C
C Input arguments
C
      implicit none

      integer nlev	  ! number of levels
      real ps             ! Surface pressures, mb
      real pm(nlev)       ! Midpoint pressures, mb
      real rair           ! Gas constant for dry air
      real gravit         ! Acceleration of gravity
      real tv(nlev)       ! Virtual temperature
C
C Output arguments
C
      real z(nlev)        ! Height above surface at midpoints
C
C---------------------------Local variables-----------------------------
C
      integer i,k,l              ! Lon, level, level indices
      real rog                   ! Rair / gravit
      real pmln(nlev)            ! Log of midpoint pressures
      real psln                  ! Log surface pressures
C
C-----------------------------------------------------------------------
      do k=1,nlev
          pmln(k) = log(pm(k)*100.)
      end do
      psln=log(ps*100.)
C
C Diagonal term of hydrostatic equation
C
      rog = rair/gravit
      do k=2,nlev
          z(k) = rog*tv(k)*0.5*(pmln(k-1) - pmln(k))
      end do
      z(1) = rog*tv(1)*(psln - pmln(1))
C
C Bottom level term of hydrostatic equation
C
      do  k=2,nlev
          z(k) = z(k) + rog*tv(1)*(psln - 0.5*(pmln(2) + pmln(1)))
      end do
C
C Interior terms of hydrostatic equation
C
      do k=3,nlev
        do l=2, k-1
            z(k) = z(k) + rog*tv(l) * 0.5*(pmln(l-1) - pmln(l+1))
        end do
      end do

      return
      end


! PR fortran/69128
! { dg-do compile }

program test
  implicit none
  interface
    subroutine use(b, c)
      real, allocatable :: b(:), c(:)
    end subroutine
  end interface
  real, allocatable :: a(:,:), b(:), c(:)
  integer :: dim1, dim2, i,j
  dim1=10000
  dim2=500
  allocate(a(dim1,dim2),b(dim1),c(dim1))
  call random_number(a)

!$omp parallel workshare
  b(:) = maxval(a(:,:), dim=2)
  c(:) = sum(a(:,:), dim=2)
!$omp end parallel workshare
  call use(b, c)
end program


module types
  integer, parameter:: dp=kind(0.d0), sp=kind(0.0)  ! double, simple precision
  integer, parameter:: MISSING_VALUE_INT = -99999
  real(dp), parameter:: MISSING_VALUE = -99999.d0, MISSING_VALUE_DP = -99999.d0
  integer, parameter :: clen = 256
end module types

module interp_mod

  use types, only: dp !, MISSING_VALUE
  implicit none
  private
  public :: get_interp_weights, get_interp_weights_stretched, locate

contains

  integer function locate(xx,x)
    ! Locate a value in a sorted array
    ! ==> adapted from lib_array but returns 0 or size+1
    ! integer if an out-of-bound array is present

    implicit none
    real(dp), dimension(:), intent(in) :: xx
    real(dp), intent(in) :: x
    integer :: n,jl,jm,ju
    logical :: ascnd
    n=size(xx)
    ascnd = (xx(n) >= xx(1))

    ! border cases
    if (x == xx(1)) then
       locate = 1
       return
    else if (x == xx(n)) then
       locate = n
       return
    else if(ascnd.and. x > xx(n)) then
       locate = n+1
       return
    else if(ascnd.and. x < xx(1)) then
       locate = -1
       return
    else if(.not.ascnd.and. x > xx(n)) then
       locate = -1
       return
    else if(.not.ascnd.and. x < xx(1)) then
       locate = n+1
       return
    endif

    ! binary search in sorted array
    jl=0
    ju=n+1
    do
       if (ju-jl <= 1) exit
       jm=(ju+jl)/2
       if (ascnd .eqv. (x >= xx(jm))) then
          jl=jm
       else
          ju=jm
       end if
    end do

    ! matches element or is located left of it
    locate = jl

  end function locate

  ! ! regrid one array on another when the two axes only differ by a scaling factor
  ! subroutine regrid_stretched(x1, y1, x2, scal)
  !   real(dp), intent(in) :: x1(:), y1(:), x2(:)
  !   integer :: n1 = size(y1), n2 = size(y2)  ! ...and their sizes
  !
  ! end subroutine regrid_stretched

  ! compute weights of linear interp from one grid on another, general case
  subroutine get_interp_weights(x1, x2, l, w, bounds_error, linear_extrapolation, debug)
    real(dp), intent(in) :: x1(:), x2(:)
    integer, intent(out) :: l(size(x2))
    real(dp), intent(out) :: w(size(x2))       ! weight
    logical, optional :: linear_extrapolation, bounds_error, debug
    logical :: linear_extrapolation_tmp = .false., bounds_error_tmp = .true., debug_tmp = .false.

    integer :: i, j, n1, n2, jl
    double precision :: dx1(size(x1)-1)

    if (present(bounds_error)) bounds_error_tmp = bounds_error
    if (present(linear_extrapolation)) linear_extrapolation_tmp = linear_extrapolation
    if (present(debug)) debug_tmp = debug

    n1=size(x1)
    n2=size(x2)

    if (.not. x1(n1)  > x1(1)) stop("get_interp_weight: assumes ascending array x1")
    if (.not. x2(n2)  > x2(1)) stop("get_interp_weight: assumes ascending array x2")

    do i = 1,n2
      jl = locate(x1, x2(i))
      if (jl == n1) then
        jl = n1 - 1
      else if (jl > n1) then
        if (bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x2(i),x1(1),x1(n1)
          stop
        else if (linear_extrapolation_tmp) then
          jl = n1 - 1  ! do nothing
        else
          ! simply signal out-of-bound by setting w > 1
          l(i:) = n1 - 1
          w(i:) = 1 + 0.01d0
          exit
        endif
      else if (jl < 1) then
        if (bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x2(i),x1(1),x1(n1)
          stop
        end if
        jl = 1
      endif
      l(i) = jl
      w(i) = (x2(i)-x1(jl)) / (x1(jl+1) - x1(jl))
    enddo

    ! check
    if (debug_tmp) then
    ! if (.not.present(debug) .or. debug) then
      call check_interp_weights(x1, x2, l, l+1, w)
    endif

  end subroutine get_interp_weights

  ! compute interp weights between two grids when they differ from a scaling factor
  subroutine get_interp_weights_stretched(x1, x2, l, w, bounds_error, linear_extrapolation, debug)
    real(dp), intent(in) :: x1(:), x2(:)
    integer, intent(out) :: l(size(x2))  ! left and right indices
    real(dp), intent(out) :: w(size(x2))       ! weight

    real(dp) :: scal
    integer :: i, j, n1, n2, jl, last_i2, i1,i2
    real(dp):: dx1(size(x1)-1)

    logical, optional :: bounds_error, linear_extrapolation, debug
    logical :: bounds_error_tmp = .true., linear_extrapolation_tmp = .false., debug_tmp = .false.

    if (present(bounds_error)) bounds_error_tmp = bounds_error
    if (present(linear_extrapolation)) linear_extrapolation_tmp = linear_extrapolation
    if (present(debug)) debug_tmp = debug

    n1=size(x1)
    n2=size(x2)

    ! if (n1 /= n2) then
    !   write(*,*) n1, n2
    !   stop("grid sizes differ")
    ! endif
    scal = (x2(2)-x2(1))/(x1(2)-x1(1))
    do i=1,n2
      if (x2(i) > x1(n1)) then
        if (bounds_error_tmp) then
          write(0,'("ERROR: Interpolation out of bounds : ",ES11.4," in [",ES11.4,":",ES11.4,"]")') x2(i),x1(1),x1(n1)
          stop
        else if (linear_extrapolation_tmp) then
          jl = n1 - 1  ! do nothing
        else
          ! simply signal out-of-bound by setting w > 1
          l(i:) = n1 - 1
          w(i:) = 1 + 0.01d0
          exit
        end if
      endif
      jl = 1 + int((i-1)*scal)
      if (jl == n1) then
        jl = n1 - 1
      endif
      if (debug_tmp) then
        if (.not.(x1(jl)<=x2(i).and.x1(jl+1)>x2(i))) then
          print *, 'i,jl,scal, x1(jl-1:jl+1),x2(i)',i,jl,scal,x1(jl-1:jl+1), x2(i)
          stop("stretched grid jl determination failed")
        endif
      endif
      l(i) = jl
      w(i) = (x2(i)-x1(jl)) / (x1(jl+1) - x1(jl))
      if (w(i) > 1) then
        print *, 'jl',jl
        print *, 'scal',scal
        print *, 'i',i
        stop("check that out")
      endif
    enddo

    ! check
    if (debug_tmp) then
    ! if (.not.present(debug) .or. debug) then
      call check_interp_weights(x1, x2, l, l+1, w)
    endif

  end subroutine get_interp_weights_stretched

  subroutine check_interp_weights(x1, x2, l, r, w)
    real(dp), intent(in) :: x1(:), x2(:)
    integer, intent(in) :: l(size(x2)), r(size(x2))   ! left and right indices
    real(dp), intent(in) :: w(size(x2))
    real(dp) :: scal    ! weight

    integer :: i, j, n1, n2, jl

    integer i1, i2 ! debug
    logical :: check

    n1 = size(x1)
    n2 = size(x2)

    if (maxval(abs(x1(l)+w*(x1(r)-x1(l)) - x2), mask=(w>0.and.w<1)) > 0.1) then
      i = maxloc(abs(x1(l)+w*(x1(r)-x1(l)) - x2), mask=(w>0.and.w<1), dim=1)
      i1 = maxval([i-2,1])
      i2 = minval([i+2,size(w)])
      print *, 'first 5 x1',x1(:5)
      print *, 'first 5 x2',x2(:5)
      print *, ""
      print *, 'max mismatch:', i, 'x2=',x2(i)
      print *, ""
      print *, 'corresponds on x1, using locate:', locate(x1, x2(i))
      print *, '[l, r]', l(i),r(i)
      print *, '[x1(l), x1(r)]', x1(l(i)),x1(r(i))
      print *, 'w:', w(i)
      print *, 'x1(r)-x1(l):', x1(r(i))-x1(l(i))
      print *, 'x1(l)+w*(x1(r)-x1(l)):',x1(l(i))+w(i)*(x1(r(i))-x1(l(i)))
      print *, ""
      stop("problem when calculating the weights (stretched)")
    endif

    scal = (x2(2)-x2(1))/(x1(2)-x1(1))

    i = 1
    check = .false.
    do while (l(i) < size(x1).and.i<size(l))
      if (w(i) == 1) then
        check = .true.
        exit
      endif
      i = i + 1
    enddo
    if (check) then
      ! i = minloc(abs(w-1), dim=1)
      print *, 'scal', scal
      i1= max(1, i-1)
      i2 =min(size(w), i+1)
      print *, i1,':',i2
      print *, "x2",x1(i1:i2)
      print *, "x1",x1(l(i1):l(i1)+2)
      print *, "l",l(i1:i2)
      print *, "w",w(i1:i2)
      print *, x1(i1:i2) == x2(i1:i2)
      print *, x1(i1:i2) > x2(i1:i2)
      ! print *, "x1",x1(l(i1:i2))
      stop("check that out")
    endif

  end subroutine check_interp_weights

end module interp_mod


    !-------------------------------------------------------------------------------------------------------------
    !
    ! DISCLAIMER
    ! ==========
    !
    ! All of the programming herein is original unless otherwise specified.
    !
    !
    ! Revisions:
    ! ==========
    !
    !    Date          Programmer        Description of change
    !    ----          ----------        ---------------------
    !    07/21/2019    M.H.A. Piro       Moved to a new file to clean up code.
    !
    !
    ! Purpose:
    ! ========
    !
    ! The purpose of this program is to compute the functional norm of the objective function, which is
    ! an indicator as to the nearness of convergence and whether the iterative routine is converging or
    ! diverging.
    !
    !
    !
    ! Pertinent variables:
    ! ====================
    !
    !   Variable                    Brief Description
    !   --------                    -----------------
    !
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine optimaFunctionalNorm(m, f, dFuncNorm, dFuncNormLast)

    implicit none

    integer              :: i, m
    real(8)              :: dFuncNorm, dFuncNormLast
    real(8),dimension(m) :: f

    ! Initialize variables:
    dFuncNormLast = dFuncNorm
    dFuncNorm     = 0D0

    ! Compute the functional norm:
    do i = 1, m
        dFuncNorm = dFuncNorm + f(i)
    end do

    ! Normalize the functional norm:
    dFuncNorm = (dFuncNorm)**(0.5)

    print *, 'The functional norm is: ', dFuncNorm
    print *

    ! Check if the system is diverging:
    if (dFuncNorm > dFuncNormLast) then
        print *, '********************************************************************************'
        print *
        print *, 'WARNING: The system is diverging.  Be careful when selecting a steplength in the following'
        print *, 'iteration.'
        print *
        print *, '********************************************************************************'
        print *
    end if

    return

end subroutine optimaFunctionalNorm


program data_types

      implicit none
      integer           :: i
      integer(kind=2)   :: i2
      integer(kind=4)   :: i4
      integer(kind=8)   :: i8
      integer(kind=16)  :: i16
      integer(kind=16)  :: i_result1
      integer(kind=16)  :: i_result2

      real          :: r
      real(kind=4)  :: r4
      real(kind=8)  :: r8
      real(kind=16) :: r16
      real(kind=16) :: r_result1
      real(kind=16) :: r_result2

      character(len=40) :: str
      logical           :: bool
      complex           :: compl

      ! Executions
      print *, "maximum integer     = ", huge(i)
      print *, "maximum integer 2   = ", huge(i2)
      print *, "maximum integer 4   = ", huge(i4)
      print *, "maximum integer 8   = ", huge(i8)
      print *, "maximum integer 16  = ", huge(i16)

      print *, "maximum real    = ", huge(r)
      print *, "maximum real 4  = ", huge(r4)
      print *, "maximum real 8  = ", huge(r8)
      print *, "maximum real 16 = ", huge(r16)

      print *, "bool default = ", bool
      bool = .false.; print *, "bool defined = ", bool

      print *, "character default = ", str
      str = "Ciao"; print *, "character str(1:2) = ", str(1:2)

      print *, "complex default = ", compl
      compl = (1, 5);           print *, "complex defined 1 = ", compl
      compl = cmplx(0.1, -7.0); print *, "complex defined 2 = ", compl

      ! Calculations for integers
      i   = 101
      i2  = 2
      i4  = 3
      i8  = 30
      i16 = 300
      i_result1 = i / i2
      i_result2 = i2 / i4

      print *, "i_result1 = ", i_result1, "i_result2 = ", i_result2

      ! Calculations for reals
      r = 1.0
      r4 = 2.0
      r8 = 3.0
      r16 = 300.0
      r_result1 = r / r4
      r_result2 = r4 / r8

      print *, "r_result1 = ", r_result1, "r_result2 = ", r_result2

end program data_types


C Work performed under the auspices of the U.S. Department of Energy
C by Lawrence Livermore National Laboratory under contract number
C W-7405-Eng-48.
C
C Copyright 1998 the Regents of the University of California.
C All rights reserved.
C
C***BEGIN PROLOGUE  DWEBS
C***REFER TO  DDASPK
C***DATE WRITTEN   950914   (YYMMDD)
C***MODIFIED TO INCLUDE SENSITIVITY ANALYSIS 990115
C
C***AUTHORS  A. C. Hindmarsh, P. N. Brown
C            Lawrence Livermore National Laboratory
C            Livermore, CA 94551, USA
C
C            L. R. Petzold
C            University of California
C            Santa Barbara, CA  93106, USA
C
C            Shengtai Li
C            University of California
C            Santa Barbara, CA  93106, USA
C
C***DESCRIPTION
C
C-----------------------------------------------------------------------
C Example program for DDASPK.
C DAE system derived from ns-species interaction PDE in 2 dimensions.
C Sensitivity analysis with respect to parameters alpha and beta.
C
C This is the double precision version.
C-----------------------------------------------------------------------
C
C This program solves a DAE system that arises from a system
C of partial differential equations.  The PDE system is a food web
C population model, with predator-prey interaction and diffusion on
C the unit square in two dimensions.  The dependent variable vector is
C
C         1   2        ns
C   c = (c , c , ..., c  )
C
C and the PDEs are as follows..
C
C     i               i      i
C   dc /dt  =  d(i)*(c    + c   )  +  R (x,y,c)  (i=1,...,ns/2)
C                     xx     yy        i
C
C                     i      i
C   0       =  d(i)*(c    + c   )  +  R (x,y,c)  (i=(ns/2)+1,...,ns)
C                     xx     yy        i
C
C where
C                  i          ns         j
C   R (x,y,c)  =  c *(b(i) + sum a(i,j)*c )
C    i                       j=1
C
C The number of species is ns = 2*np, with the first np being prey and
C the last np being predators.  The coefficients a(i,j), b(i), d(i) are
C
C   a(i,i) = -a  (all i)
C   a(i,j) = -g  (i .le. np, j .gt. np)
C   a(i,j) =  e  (i .gt. np, j .le. np)
C   b(i) =  b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .le. np)
C   b(i) = -b*(1 + alpha*x*y + beta*sin(4*pi*x)*sin(4*pi*y))  (i .gt. np)
C   d(i) = dprey  (i .le. np)
C   d(i) = dpred  (i .gt. np)
C
C The various scalar parameters are set in subroutine setpar.
C
C The boundary conditions are.. normal derivative = 0.
C A polynomial in x and y is used to set the initial conditions.
C
C The PDEs are discretized by central differencing on a MX by MY mesh.
C
C The DAE system is solved by DDASPK with three different method options:
C (1) direct band method for the linear systems (internal Jacobian),
C (2) preconditioned Krylov method for the linear systems, without
C     block-grouping in the reaction-based factor, and
C (3) preconditioned Krylov method for the linear systems, with
C     block-grouping in the reaction-based factor.
C
C In the Krylov cases, the preconditioner is the product of two factors:
C (a) The spatial factor uses a fixed number of Gauss-Seidel iterations
C based on the diffusion terms only.
C (b) The reaction-based factor is a block-diagonal matrix based on
C the partial derivatives of the interaction terms R only.
C With block-grouping, only a subset of the ns by ns blocks are computed.
C An integer flag, JPRE, is set in the main program to specify whether
C the preconditioner is to use only one of the two factors or both,
C and in which order.
C
C The reaction-based preconditioner factor is set up and solved in
C seven subroutines --
C   DMSET2, DRBDJA, DRBDPS  in the case of no block-grouping, and
C   DGSET2, GSET1, DRBGJA, DRBGPS  in the case of block-grouping.
C These routines are provided separately for general use on problems
C arising from reaction-transport systems.
C
C Two output files are written.. one with the problem description and
C performance statistics on unit LOUT = 9, and one with solution
C profiles at selected output times on unit LCOUT = 10.
C The solution file is written only in the case of the direct method.
C-----------------------------------------------------------------------
C Note.. in addition to the main program and subroutines given below,
C this program requires the BLAS routine DAXPY.
C-----------------------------------------------------------------------
C References
C [1] Peter N. Brown and Alan C. Hindmarsh,
C     Reduced Storage Matrix Methods in Stiff ODE Systems,
C     J. Appl. Math. & Comp., 31 (1989), pp. 40-91.
C [2] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Using Krylov Methods in the Solution of Large-Scale Differential-
C     Algebraic Systems, SIAM J. Sci. Comput., 15 (1994), pp. 1467-1488.
C [3] Peter N. Brown, Alan C. Hindmarsh, and Linda R. Petzold,
C     Consistent Initial Condition Calculation for Differential-
C     Algebraic Systems, LLNL Report UCRL-JC-122175, August 1995;
C     submitted to SIAM J. Sci. Comp.
C-----------------------------------------------------------------------
C***ROUTINES CALLED
C   SETPAR, DGSET2, CINIT, DDASPK, OUTWEB
C
C***END PROLOGUE  DWEB
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      EXTERNAL RESWEB, DJACILU, DPSOLILU
C
C Set output unit numbers for main output and tabulated solution.
      DATA LOUT/6/, LCOUT/10/
C Load parameters for sparse preconditioner.
      PARAMETER (LENPFAC = 10)
      PARAMETER (LENPLUFAC = 2)
      PARAMETER (IPREMETH = 2)  ! =1 means ILUT preconditioner used
                                ! =2 means ILUTP preconditioner used
      PARAMETER (LFILILUT = 10)
      PARAMETER (IREORDER = 1)
      PARAMETER (ISRNORM = 1)
      PARAMETER (NORMTYPE = 2)
      PARAMETER (JACOUT = 0)
      PARAMETER (JSCALCOL = 1)
      PARAMETER (TOLILUT = 0.001)
      PARAMETER (PERMTOL = 0.01)
      PARAMETER (NPARA = 2)
      PARAMETER (MAXS = 2, MAXNY = 800, MAXN = (NPARA+1)*MAXNY)
      PARAMETER (NRPD = 2+MAXNY)
      PARAMETER (LENWP = 3*LENPFAC*MAXNY + LENPLUFAC*MAXNY
     1                   + ISRNORM*MAXNY + 2*(MAXNY+1) )
      PARAMETER (LENIWP = 5*(MAXNY+1) + 4*LENPFAC*MAXNY
     1                    + 2*LENPLUFAC*MAXNY + IREORDER*2*MAXNY
     2                    + (IPREMETH-1)*2*MAXNY + 3*MAXNY +NRPD)
      PARAMETER (LRW = 67301, LIW = 46447)
C
      DIMENSION CC(MAXN), CCPRIME(MAXN), RWORK(LRW), IWORK(LIW),
     1     INFO(30), RPAR(NRPD), IPAR(31), senpar(2)
C
C The COMMON blocks /PPAR1/ and /PPAR2/ contain problem parameters.
C
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY,  FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
      real t1, t2, t3, tt(2)
C

C Open output files.
c      OPEN(unit=lout,file='wdout',status='unknown')
c      OPEN(unit=lcout,file='wccout',status='unknown')
C
C Call SETPAR to set basic problem parameters.
      CALL SETPAR(senpar)
C
      ALPH = senpar(1)
      BETA = senpar(2)
C Set remaining problem parameters.
      NPARM = 2
      NEQ = NS*MX*MY
      MXNS = MX*NS
      DX = AX/REAL(MX-1)
      DY = AY/REAL(MY-1)
      DO 10 I = 1,NS
        COX(I) = DIFF(I)/DX**2
 10     COY(I) = DIFF(I)/DY**2
C
      WRITE(LOUT,20)NS
 20   FORMAT(//' Example program for DDASPK package'//
     1   ' Food web problem with NS species, NS =',I4/
     2   ' Predator-prey interaction and diffusion on a 2-D square'/)
      WRITE(LOUT,30) AA,EE,GG,BB,DPREY,DPRED, ALPH,BETA
 30   FORMAT(' Matrix parameters..  a =',E12.4,'   e =',E12.4,
     1   '   g =',E12.4/21x,' b parameter =',E12.4//
     2   ' Diffusion coefficients.. dprey =',E12.4,'   dpred =',E12.4//
     3   ' Rate parameters alpha =',E12.4,' and beta =',E12.4/)
      WRITE(LOUT,40) MX,MY,NEQ
 40   FORMAT(' Mesh dimensions (MX,MY) =',2I4,
     1   5x,' Total system size is NEQ =',I7/)
C
C Here set the flat initial guess for the predators.
	PREDIC = 1.0D5
C
C Load values into IPAR and RPAR for sparse preconditioner.
      ML = NS*MX + 1
      MU = ML
      IPAR(1) = ML
      IPAR(2) = MU
      IPAR(3) = LENPFAC
      IPAR(4) = LENPLUFAC
      IPAR(5) = IPREMETH
      IPAR(6) = LFILILUT
      IPAR(7) = IREORDER
      IPAR(8) = ISRNORM
      IPAR(9) = NORMTYPE
      IPAR(10) = JACOUT
      IPAR(11) = JSCALCOL
      IPAR(30) = 0
      RPAR(1) = TOLILUT
      RPAR(2) = PERMTOL
C Check IPAR, RPAR, LENWP and LENIWP for illegal entries and long
C enough work array lengths.
      CALL DSPSETUP (NEQ, LENWP, LENIWP, RPAR, IPAR, IERR,
     .               LWPMIN, LIWPMIN)
      IF (IERR .NE. 0) THEN
         WRITE(LOUT,45) IERR
 45      FORMAT(' Error return from DSPSETUP: IERR = ',i5)
         IF (LWPMIN .GT. LENWP) THEN
            WRITE(LOUT,*) ' More WP work array length needed'
         ENDIF
         IF (LIWPMIN .GT. LENIWP) THEN
            WRITE(LOUT,*) ' More IWP work array length needed'
         ENDIF
         STOP
      ENDIF
C
C Set remaining method parameters for DDASPK.
C These include the INFO array and tolerances.
C
      DO 50 I = 1,30
 50   INFO(I) = 0
C
C Here set INFO(11) = 1, indicating I.C. calculation requested.
      INFO(11) = 1
C
C Here set INFO(18) = 2, indicating full print for initial condition
C      calculation
      INFO(18) = 0
C
C Here set INFO(14) = 1 to get the computed initial values.
      INFO(14) = 1
C
C Here set INFO(15) = 1 to signal that a preconditioner setup routine
C is to be called in the Krylov case.
      INFO(15) = 1
C
C Here set INFO(16) = 1 to get alternative error test (on the
C differential variables only).
      INFO(16) = 1
C
C
C Here set INFO(19) = 2 to indicate that a sensitivity analysis
C is to be done with two parameters
      inso = 18
      info(inso+1) = 2
      print *, ' number of sensitivities? (0,1,2) '
      read(*,*) info(inso+1)
      Ny = neq
      neq = neq*(info(inso+1) + 1)
      if (info(inso+1) .eq. 0) go to 60
      print *, ' method for computing sensitivity residues:(0,1)'
      print *, '    0: central differencing '
      print *, '    1: one-side forward differencing '
      read (*,*) info(inso+2)
      if (info(inso+2) .eq. 2) info(inso+2) = 3
      iwork(38) = nrpd
      info(inso+3) = 0          ! default perturbed factor
      info(inso+4) = 2          ! number of sensitivity parameters in RES
      info(inso+5) = 0          ! 0, full control 1. partial control
      print *, ' Error control: (0,1)'
      print *, '    0: full error control with sensitivity '
      print *, '    1: partial error control on state variables only '
      read(*, *) info(inso+5)
      info(inso+6) = 0          ! no derived information
      info(inso+7) = 1          ! simultaneous corrector(0), staggered(1)
      print *, ' Corrector method: (0, 1)'
      print *, '    0:  simultaneous corrector method '
      print *, '    1:  staggered corrector method'
      read(*,*) info(inso+7)
      RWORK(16) = 1.d-5
 60   continue
C
C
C Here set the tolerances.
      RTOL = 1.0D-5
      ATOL = RTOL
      WRITE(LOUT,70)RTOL,ATOL,INFO(11),PREDIC,INFO(16)
 70   FORMAT(' Tolerance parameters.. RTOL =',E10.2,'   ATOL =',E10.2//
     1   ' Internal I.C. calculation flag INFO(11) =',I2,
     2   '   (0 = off, 1 = on)'/
     3   ' Predator I.C. guess =',E10.2//
     4   ' Alternate error test flag INFO(16) =',I2,
     5        '  (0 = off, 1 = on)')
C
C Set NOUT = number of output times.
      NOUT = 18
C
C Loop over method options:
C METH = 0 means use INFO(12) = 0 (direct)
C METH = 1 means use INFO(12) = 1 (Krylov) without block-grouping in
C          the reaction-based factor in the preconditioner.
C METH = 2 means use INFO(12) = 1 (Krylov) with block-grouping in
C          the reaction-based factor in the preconditioner.
C A block-grouping flag JBG, communicated through IPAR, is set to
C 0 (no block-grouping) or 1 (use block-grouping) with METH = 1 or 2.
C Reset INFO(1) = 0 and INFO(11) = 1.
C
C
C Set and print various preconditioner parameters.
      INFO(12) = 1
      IWORK(27) = LENWP
      IWORK(28) = LENIWP
      WRITE(LOUT,100) IPREMETH
 100  FORMAT(' Preconditioner flag is IPREMETH =',I3,
     1       '  (1 = ILUT, 2 = ILUTP)')
C Here call SETID to set the IWORK segment ID  indicating the
C differential and algebraic components.
      CALL SETID (MX, MY, NS, NP, 40, IWORK)
C
C Set the initial T and TOUT, and call CINIT to set initial values.
      T = 0.0D0
      TOUT = 1.0D-8
      CALL CINIT (CC, CCPRIME, PREDIC, rpar, senpar)
C
      NLI = 0
      NNI = 0
C
      WRITE(LOUT,140)
 140  FORMAT(//'   t',7X,'NSTEP  NRE  NNI  NLI  NPE  NQ',4X,
     1   'H',10X,'AVLIN',4X, 'TIME')
C
C Loop over output times, call DDASPK, and print performance data.
C The first call, with IOUT = 0, is to calculate initial values only.
C After the first call, reset INFO(11) = 0 and the initial TOUT.
C
      t1 = secnds(0.0e0)
      t2 = dtime(tt)
      DO 200 IOUT = 0,NOUT
C
         CALL DDASPK (
     1        RESWEB, NEQ, T, CC, CCPRIME, TOUT, INFO, RTOL, ATOL,
     1        IDID, RWORK,LRW, IWORK,LIW, RPAR, IPAR,
     1        DJACILU, DPSOLILU, senpar, h_res)
C
c        write(12,*) cc(ny/2+NY), cc(ny/2+1+NY)
        NST = IWORK(11)
        NRE = IWORK(12)
        NPE = IWORK(13)
        NNIDIF = IWORK(19) - NNI
        NNI = IWORK(19)
        NLIDIF = IWORK(20) - NLI
        NLI = IWORK(20)
        NQU = IWORK(8)
        HU = RWORK(7)
        AVLIN = 0.0D0
        IF (NNIDIF .GT. 0) AVLIN = REAL(NLIDIF)/REAL(NNIDIF)
C
        IF (METH .EQ. 0) THEN
          IMOD3 = IOUT - 3*(IOUT/3)
c          IF (IMOD3 .EQ. 0) CALL OUTWEB (T, CC, NS, MX, MY, LCOUT)
          ENDIF
C
        WRITE(LOUT,150)T,NST,NRE,NNI,NLI,NPE,NQU,HU,
     *         AVLIN,secnds(t1)
 150    FORMAT(E10.2,I5,I6,3I5,I4,E11.2,F9.4, f8.2)
C
        IF (IDID .LT. 0) THEN
          WRITE(LOUT,160)T
 160      FORMAT(//' Final time reached =',E12.4//)
          GO TO 210
          ENDIF
C
        IF (TOUT .GT. 0.9D0) TOUT = TOUT + 1.0D0
        IF (TOUT .LT. 0.9D0) TOUT = TOUT*10.0D0
        IF (IOUT .EQ. 0) THEN
c           write(10, *) (cc(j), j=ny+1, 2*ny)
          INFO(11) = 0
          TOUT = 1.0D-8
          NLI = 0
          NNI = 0
          ENDIF
 200    CONTINUE
C
 210  CONTINUE
      LENRW = IWORK(18)
      LENIW = IWORK(17)
      NST = IWORK(11)
      NRE = IWORK(12)
      NPE = IWORK(13)
      NNI = IWORK(19)
      NLI = IWORK(20)
      NPS = IWORK(21)
      NSE = IWORK(22)
      IF (NNI .GT. 0) AVLIN = REAL(NLI)/REAL(NNI)
      NETF = IWORK(14)
      NCFN = IWORK(15)
      NCFL = IWORK(16)
      WRITE(LOUT,220) LENRW,LENIW,NST,NRE+IPAR(30),NSE,NPE,NPS,NNI,
     1               NLI,AVLIN,NETF,NCFN,NCFL
 220   FORMAT(//' Final statistics for this run..'/
     1   ' RWORK size =',I8,'   IWORK size   =',I6/
     2   ' Number of time steps              =',I5/
     3   ' Number of residual evaluations    =',I5/
     3   ' Number of sensitivity evaluations =',I5/
     4   ' Number of Jac. or prec. evals.    =',I5/
     5   ' Number of preconditioner solves   =',I5/
     6   ' Number of nonlinear iterations    =',I5/
     7   ' Number of linear iterations       =',I5/
     8   ' Average Krylov subspace dimension =',F8.4/
     1   ' error test failure .............. =',I5/
     9   I3,' nonlinear conv. failures,',i5,' linear conv. failures')
C
       t3 = dtime(tt)
       print *, ' Time used: ', secnds(t1), tt(1)+tt(2)
 300   CONTINUE

      STOP
C------  End of main program for DWEB example program ------------------
      END

      SUBROUTINE SETPAR(senpar)
C-----------------------------------------------------------------------
C This routine sets the basic problem parameters, namely
C AX, AY, NS, MX, MY,  problem coefficients ACOEF, BCOEF, DIFF,
C ALPH, BETA, using parameters NP, AA, EE, GG, BB, DPREY, DPRED.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      double precision senpar(2)
      PARAMETER (MAXS = 2)
      COMMON /PPAR1/ AA, EE, GG, BB, DPREY, DPRED
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY,  FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      AX = 1.0D0
      AY = 1.0D0
      NP = 1
      MX = 20
      MY = 20
      AA = 1.0D0
      EE = 1.0D4
      GG = 0.5D-6
      BB = 1.0D0
      DPREY = 1.0D0
      DPRED = 0.05D0
      ALPH = 50.0D0
      BETA = 100.0D0
      senpar(1) = alph
      senpar(2) = beta
      NS = 2*NP
      DO 20 J = 1,NP
        DO 10 I = 1,NP
          ACOEF(NP+I,J) = EE
          ACOEF(I,NP+J) = -GG
 10       CONTINUE
        ACOEF(J,J) = -AA
        ACOEF(NP+J,NP+J) = -AA
        BCOEF(J) = BB
        BCOEF(NP+J) = -BB
        DIFF(J) = DPREY
        DIFF(NP+J) = DPRED
 20     CONTINUE
      PI = 3.141592653589793D0
      FPI = 4.0D0*PI
C
      RETURN
C------------  End of Subroutine SETPAR  -------------------------------
      END

      SUBROUTINE SETID (MX, MY, NS, NSD, LID, IWORK)
C-----------------------------------------------------------------------
C This routine sets the ID array in IWORK, indicating which components
C are differential and which are algebraic.
C-----------------------------------------------------------------------
      DIMENSION IWORK(*)
C
      NSDP1 = NSD + 1
      DO 40 JY = 1,MY
        I00 = MX*NS*(JY-1) + LID
        DO 30 JX = 1,MX
          I0 = I00 + NS*(JX-1)
          DO 10 I = 1,NSD
 10         IWORK(I0+I) = 1
          DO 20 I = NSDP1,NS
 20         IWORK(I0+I) = -1
 30       CONTINUE
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine SETID  --------------------------------
      END

      SUBROUTINE CINIT (CC, CCPRIME, PREDIC, RPAR, senpar)
C-----------------------------------------------------------------------
C This routine computes and loads the vectors of initial values.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CCPRIME(*), RPAR(*), senpar(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY,  FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
C Load CC.
      alph = senpar(1)
      beta = senpar(2)
      NPP1 = NP + 1
      DO 30 JY = 1,MY
        Y = REAL(JY-1)*DY
        ARGY = 16.0D0*Y*Y*(AY-Y)*(AY-Y)
        IYOFF = MXNS*(JY-1)
        DO 20 JX = 1,MX
          X = REAL(JX-1)*DX
          ARGX = 16.0D0*X*X*(AX-X)*(AX-X)
          IOFF = IYOFF + NS*(JX-1)
          FAC = 1.0D0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
          DO 10 I = 1,NP
 10         CC(IOFF + I) = 10.0D0 + REAL(I)*ARGX*ARGY
          DO 15 I = NPP1,NS
 15         CC(IOFF + I) = PREDIC
 20       CONTINUE
 30     CONTINUE
C
C Load CCPRIME.
      T = 0.0D0
      CALL FWEB (T, CC, CCPRIME, RPAR, senpar)
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        DO 50 JX = 1,MX
          IOFF = IYOFF + NS*(JX-1)
          DO 40 I = NPP1,NS
 40         CCPRIME(IOFF+I) = 0.0D0
 50     CONTINUE
 60   CONTINUE
C
      RETURN
C------------  End of Subroutine CINIT  --------------------------------
      END

      SUBROUTINE OUTWEB (T, C, NS, MX, MY, LUN)
C-----------------------------------------------------------------------
C This routine prints the values of the individual species densities
C at the current time T, to logical unit LUN.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(NS,MX,MY)
C
      WRITE(LUN,10) T
 10   FORMAT(/1X,79('-')/30X,'At time t = ',E16.8/1X,79('-') )
C
      DO 40 I = 1,NS
        WRITE(LUN,20) I
 20     FORMAT(' the species c(',i2,') values are ')
        DO 30 JY = MY,1,-1
          WRITE(LUN,25) (C(I,JX,JY),JX=1,MX)
 25       FORMAT(6(1X,G12.6))
 30       CONTINUE
        WRITE(LUN,35)
 35     FORMAT(1X,79('-'),/)
 40     CONTINUE
C
      RETURN
C------------  End of Subroutine OUTWEB  -------------------------------
      END

      SUBROUTINE RESWEB (
     *     T, U, UPRIME, CJ, DELTA, IRES, RPAR, IPAR, senpar)
C-----------------------------------------------------------------------
C This routine computes the residual vector, using Subroutine FWEB
C for the right-hand sides.
C-----------------------------------------------------------------------
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION U(*),UPRIME(*),DELTA(*),RPAR(*),IPAR(*), senpar(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY, FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      ALPH = senpar(1)
      BETA = senpar(2)
      CALL FWEB (T, U, DELTA, RPAR, senpar)
C
      DO 30 JY = 1,MY
         IYOFF = MXNS*(JY-1)
         DO 20 JX = 1,MX
            IC0 = IYOFF + NS*(JX-1)
            DO 10 I = 1,NS
               ICI = IC0 + I
               IF (I .GT. NP) THEN
                  DELTA(ICI) = -DELTA(ICI)
               ELSE
                  DELTA(ICI) = UPRIME(ICI) - DELTA(ICI)
               ENDIF
 10         CONTINUE
 20      CONTINUE
 30   CONTINUE
C
      RETURN
C------------  End of Subroutine RESWEB  -------------------------------
      END

      SUBROUTINE FWEB (T, CC, CRATE, RPAR, senpar)
C-----------------------------------------------------------------------
C This routine computes the right-hand sides of all the equations
C and returns them in the array CRATE.
C The interaction rates are computed by calls to WEBR, and these are
C saved in RPAR(1),...,RPAR(NEQ) for use later in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION CC(*), CRATE(*), RPAR(*), senpar(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY,  FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      DO 60 JY = 1,MY
        IYOFF = MXNS*(JY-1)
        IDYU = MXNS
        IF (JY .EQ. MY) IDYU = -MXNS
        IDYL = MXNS
        IF (JY .EQ. 1) IDYL = -MXNS
        DO 40 JX = 1,MX
          IC = IYOFF + NS*(JX-1) + 1
C Get interaction rates at one point (X,Y).
          CALL WEBR (T, JX, JY, CC(IC), RPAR(2+IC),senpar)
          IDXU = NS
          IF (JX .EQ. MX) IDXU = -NS
          IDXL = NS
          IF (JX .EQ. 1) IDXL = -NS
          DO 20 I = 1,NS
            ICI = IC + I - 1
C Do differencing in Y.
            DCYLI = CC(ICI) - CC(ICI-IDYL)
            DCYUI = CC(ICI+IDYU) - CC(ICI)
C Do differencing in X.
            DCXLI = CC(ICI) - CC(ICI-IDXL)
            DCXUI = CC(ICI+IDXU) - CC(ICI)
C Collect terms and load CRATE elements.
            CRATE(ICI) = COY(I)*(DCYUI - DCYLI) + COX(I)*(DCXUI - DCXLI)
     1                  + RPAR(2+ICI)
 20         CONTINUE
 40       CONTINUE
 60    CONTINUE
      RETURN
C------------  End of Subroutine FWEB  ---------------------------------
      END

      SUBROUTINE WEBR (T, JX, JY, C, CRATE, senpar)
C-----------------------------------------------------------------------
C This routine computes one block of the interaction term R of the
C system, namely block (JX,JY), for use in preconditioning.
C-----------------------------------------------------------------------
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DIMENSION C(*), CRATE(*), senpar(*)
      PARAMETER (MAXS = 2)
      COMMON /PPAR2/ NP, NS, AX, AY, ACOEF(MAXS,MAXS), BCOEF(MAXS),
     1               DX, DY,  FPI, DIFF(MAXS),
     2               COX(MAXS), COY(MAXS), MX, MY, MXNS
C
      alph = senpar(1)
      beta = senpar(2)
      Y = REAL(JY-1)*DY
      X = REAL(JX-1)*DX
      DO 10 I = 1,NS
 10     CRATE(I) = 0.0D0
      DO 15 J = 1,NS
        CALL DAXPY (NS, C(J), ACOEF(1,J), 1, CRATE, 1)
 15     CONTINUE
      FAC = 1.0D0 + ALPH*X*Y + BETA*SIN(FPI*X)*SIN(FPI*Y)
      DO 20 I = 1,NS
 20     CRATE(I) = C(I)*(BCOEF(I)*FAC + CRATE(I))
      RETURN
C------------  End of Subroutine WEBR  ---------------------------------
      END


c     program DRDSYMQL
c>> 1996-05-28 DRDSYMQL  Krogh Added external statement.
c>> 1994-10-19 DRDSYMQL  Krogh  Changes to use M77CON
c>> 1994-09-22 DRDSYMQL  CLL
c>> 1992-04-23 CLL
c>> 1992-03-04 DRDSYMQL  Krogh Initial version.
c     Demonstrate symmetric eigenvalue/eigenvector subroutine DSYMQL.
c     ------------------------------------------------------------------
c--D replaces "?": DR?SYMQL, ?SYMQL, ?VECP, ?MATP, ?DOT
c     ------------------------------------------------------------------
      integer I, IERR, J, LDA, N
      parameter (LDA = 4)
      double precision A(LDA,LDA), ASAV(LDA,LDA), ANORM, D(LDA,LDA)
      external DDOT
      double precision DDOT, EVAL(LDA), WORK(LDA)
      data A(1,1)          /  5.0d0 /
      data (A(2,J), J=1,2) /  4.0d0,  5.0d0 /
      data (A(3,J), J=1,3) /  1.0d0,  1.0d0, 4.0d0 /
      data (A(4,J), J=1,4) /  1.0d0,  1.0d0, 2.0d0, 4.0d0 /
      data ANORM / 11.0d0 /
      data N /LDA/
c     ------------------------------------------------------------------
      print*,'DRDSYMQL..  Demo driver for DSYMQL.'
c
c     First copy A() to ASAV() for later residual check.
c
      do 20 I = 1,N
         do 10 J = 1,I
            ASAV(I,J) = A(I,J)
            ASAV(J,I) = ASAV(I,J)
   10    continue
   20 continue
      call DSYMQL(A, LDA, N, EVAL, WORK, IERR)
      if (IERR .eq. 0) then
         call DVECP(EVAL, N, '0 Eigenvalues')
         call DMATP(A, LDA, N, N,  '0 Eigenvectors as column vectors')
c
c        As a check compute D = (ASAV*EVEC - EVEC*EVAL) / ANORM.
c        The EVEC's are in the array A().
c        Expect D to be close to machine precision.
c
         do 40 J = 1, N
            do 30 I = 1, N
               D(I, J) = (DDOT(N, ASAV(I,1), LDA, A(1,J), 1) -
     *                  A(I,J) * EVAL(J)) / ANORM
   30       continue
   40    continue
         call DMATP(D, LDA, N, N,
     *         '0 Residual matrix D = (A*EVEC - EVEC*EVAL) / ANORM')

      else
         print '(/a,i5)',' Convergence failure in DSYMQL, IERR =',IERR
      end if
      stop
      end