! { dg-do run }
! PR83811 fortran 'e' format broken for single digit exponents
program test
  character(25) :: s
  write(s, '(1pe5.0e1)') 1.e-4
  if (s.ne."1.E-4") STOP 1
  write(s, '(e5.1e1)') 1.e12
  if (s.ne."*****") STOP 2
end


MODULE DISP_R16MOD

  ! Add-on module to M_display to display selected_real_kind(25) reals
  ! (these are probably 16 bytes and possibly quadruple precision)
  !
  ! This module is obtained by copying the section SINGLE PRECSION PROCEDURES from
  ! M_display.f90, replacing sngl with quad, single withe quadruple (only appears
  ! in comments) and cplx with cplq, adding a DECLARATIONS section, and defining
  ! the constant quad as selected_real_kind(25).
  !
  ! Copyright (c) 2008, Kristj n J nasson, Dept. of Computer Science, University of
  ! Iceland (jonasson@hi.is). This software is free. For details see the file README.

  ! ******************************** DECLARATIONS ********************************************
  use M_display_util

  PUBLIC DISP
  PUBLIC TOSTRING

  PRIVATE

  interface disp
    module procedure disp_s_quad, disp_ts_quad, disp_v_quad, disp_tv_quad, disp_m_quad, disp_tm_quad
    module procedure disp_s_cplq, disp_ts_cplq, disp_v_cplq, disp_tv_cplq, disp_m_cplq, disp_tm_cplq
  end interface

  interface tostring
    module procedure tostring_quad, tostring_f_quad, tostring_s_quad, tostring_sf_quad
    module procedure tostring_cplq, tostring_f_cplq, tostring_s_cplq, tostring_sf_cplq
  end interface

  integer, parameter :: quad = selected_real_kind(25)

CONTAINS

  ! **************************** QUADRUPLE PRECISION PROCEDURES *******************************
  subroutine disp_s_quad(x, fmt, advance, digmax, sep, trim, unit, zeroas)
    ! quadruple precision scalar without title
    character(*), intent(in), optional :: fmt, advance, sep, trim, zeroas
    real(quad), intent(in) :: x
    integer, intent(in), optional :: unit, digmax
    call disp_ts_quad('', x, fmt, advance, digmax, sep, 'left', trim, unit, zeroas)
  end subroutine disp_s_quad

  subroutine disp_v_quad(x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
    ! quadruple precision vector without title
    character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
    real(quad), intent(in) :: x(:)
    integer, intent(in), optional :: unit, lbound(:), digmax
    call disp_tv_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
  end subroutine disp_v_quad

  subroutine disp_m_quad(x, fmt, advance, lbound, sep, style, trim, unit, digmax, zeroas)
    ! quadruple precision matrix without title
    character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
    real(quad), intent(in) :: x(:,:)
    integer, intent(in), optional :: unit, digmax, lbound(:)
    call disp_tm_quad('', x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
  end subroutine disp_m_quad

  subroutine disp_ts_quad(title, x, fmt, advance, digmax, sep, style, trim, unit, zeroas)
    ! quadruple precision scalar with title
    character(*), intent(in) :: title
    character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas
    real(quad), intent(in) :: x
    integer, intent(in), optional :: unit, digmax
    call disp_tm_quad(title, reshape((/x/), (/1, 1/)), fmt, advance, digmax, sep=sep, style=style, trim=trim, &
         unit=unit, zeroas=zeroas)
  end subroutine disp_ts_quad

  subroutine disp_tv_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, orient, zeroas)
    ! quadruple precision vector with title
    character(*), intent(in) :: title
    character(*), intent(in), optional :: fmt, advance, sep, style, trim, zeroas, orient
    real(quad), intent(in) :: x(:)
    integer, intent(in), optional :: unit, lbound(:), digmax
    type(settings) :: SE
    call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, zeroas, digmax)
    if (SE % row) then
      call disp_quad(title, reshape(x, (/1, size(x)/)), SE)
    else
      call disp_quad(title, reshape(x, (/size(x), 1/)), SE)
    end if
  end subroutine disp_tv_quad

  subroutine disp_tm_quad(title, x, fmt, advance, digmax, lbound, sep, style, trim, unit, zeroas)
    ! quadruple precision matrix with title
    character(*), intent(in)           :: title      ! The title to use for the matrix
    real(quad),   intent(in)           :: x(:,:)     ! The matrix to be written
    character(*), intent(in), optional :: fmt        ! Editdit descriptor to use for each matrix element (e.g. 'F5.2')
    integer,      intent(in), optional :: unit       ! Unit to display on
    integer,      intent(in), optional :: digmax     ! Nbr of significant digits for largest abs value in x
    character(*), intent(in), optional :: advance    ! 'No' to print next matrix to right of current, otherewise 'Yes'
    character(*), intent(in), optional :: sep        ! Separator between matrix columns (e.g. ", ")
    character(*), intent(in), optional :: zeroas     ! Zeros are replaced with this string if it is not empty
    character(*), intent(in), optional :: style      ! Style(s): See NOTE 1 below
    character(*), intent(in), optional :: trim       ! 'Auto' (the default) to trim if fmt absent, 'no' for no
    !                                                ! trimming, 'yes' for trimming
    integer,      intent(in), optional :: lbound(:)  ! Lower bounds of x
    type(settings) :: SE
    !
    call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, zeroas=zeroas, digmax=digmax)
    call disp_quad(title, x, SE)
  end subroutine disp_tm_quad

  subroutine disp_quad(title, x, SE)
    ! quadruple precision item
    character(*),   intent(in)    :: title
    real(quad),     intent(in)    :: x(:,:)
    type(settings), intent(inout) :: SE
    integer wid(size(x,2)), nbl(size(x,2))
    call find_editdesc_quad(x, SE, wid, nbl) ! determine also SE % w
    call tobox_quad(title, x, SE, wid, nbl)
  end subroutine disp_quad

  subroutine tobox_quad(title, x, SE, wid, nbl)
    ! Write quadruple precision matrix to box
    character(*),   intent(in)    :: title   ! title
    real(quad),     intent(in)    :: x(:,:)  ! item
    type(settings), intent(inout) :: SE      ! settings
    integer,        intent(inout) :: wid(:)  ! widths of columns
    integer,        intent(inout) :: nbl(:)  ! number of blanks to trim from left
    character(SE % w)  :: s(size(x,1))
    integer            :: lin1, j, wleft, m, n, widp(size(wid))
    character, pointer :: boxp(:,:)
    real(quad)         :: xj(size(x,1)), h
    m = size(x,1)
    n = size(x,2)
    h = huge(x)
    call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
    do j=1,n
      xj = x(:, j)
      if (m > 0) write(s, SE % ed) xj
      call replace_zeronaninf(s, SE % zas(1:SE % lzas), xj == 0, xj /= xj, xj < -h, xj > h)
      call copytobox(s, lin1, wid(j), widp(j), nbl(j), boxp,  wleft)
      if (j<n) call copyseptobox(SE % sep(1:SE % lsep), m, lin1, boxp,  wleft)
    enddo
    call finishbox(title, SE, boxp)
  end subroutine tobox_quad

  pure function maxw_quad(x, d) result(w)
    ! Find max field width needed (F0.d editing is specified)
    real(quad), intent(in) :: x(:)
    integer, intent(in) :: d
    integer expmax, expmin, w
    logical xfinite(size(x))
    real(quad) xmax, xmin, h
    character(12) :: f1, s(2)
    xmin = 0; xmax = 0; h = huge(h)
    xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf
    if (.not. any(xfinite)) then
      w = 4
    else
      xmax = maxval(x, mask=xfinite)
      xmin = minval(x, mask=xfinite)
      f1 = '(SS,ES9.0E4)'
      write(s,f1) xmax, xmin
      read(s(:)(5:9),'(I5)') expmax, expmin
      w = max(0, expmax, expmin) + d + 4
    end if
    if (.not. all(xfinite)) w = max(w, 4)
  end function maxw_quad

  subroutine find_editdesc_quad(x, SE, wid, nbl)
    ! Determine SE % ed, SE % w (unless specified) and wid.
    ! The if-block (*) is for safety: make f wider in case xm is written ok with the
    ! ES format in fmt but overflows with F format (the feature has been tested through
    ! manual changes to the program).
    real(quad),     intent(in)    :: x(:,:)         ! Item to be written
    type(settings), intent(inout) :: SE             ! Settings
    integer,        intent(out)   :: wid(size(x,2)) ! Widths of individual columns
    integer,        intent(out)   :: nbl(size(x,2)) ! Blanks to trim from left of individual columns
    integer :: expmax, expmin, ww, dd, dmx
    real(quad) xmaxv(size(x,2)), xminv(size(x,2)), xp, xm, h
    character(14) :: f1 = '(SS,ESxx.xxE4)'  ! could be ES99.89E4; default is ES14.05E4
    character(99) s
    logical xzero(size(x,2)), xallz(size(x,2)), xfinite(size(x,1),size(x,2)), xnonn(size(x,2)), xalln(size(x,2))
    !
    dmx = SE % dmx
    h = huge(h)
    xfinite = x == x .and. x >= -h .and. x <= h ! neither NaN, Inf nor -Inf
    if (SE % w == 0) then  ! Edit descriptor 'F0.d' specified
      ww = maxw_quad(reshape(x, (/size(x)/)), SE % d)
      if (SE % lzas > 0 .and. any(x == 0._quad))  ww = max(ww, SE % lzas)
      call replace_w(SE % ed, ww)
      SE % w = ww
    elseif (SE % w < 0) then ! No edit descriptor specified
      if (size(x) == 0) then
        SE % w = 0
        wid = 0
        nbl = 0
        return
      endif
      if (any(xfinite)) then
        xp = maxval(x, mask=xfinite)
        xm = minval(x, mask=xfinite)
        write(f1(7:11), '(SS,I2,".",I2.2)') dmx + 8, dmx - 1
        write(s,f1) xp; read(s(dmx+4:dmx+8),'(I5)') expmax
        write(s,f1) xm; read(s(dmx+4:dmx+8),'(I5)') expmin
        call find_editdesc_real(expmax, expmin, dmx,  SE % ed, ww, dd, xm >= 0)
        if (.not. all(xfinite))                     ww = max(ww, 4)
        if (SE % lzas > 0 .and. any(x == 0._quad))  ww = max(ww, SE % lzas)
        if (SE % ed(5:5)=='F') then  ! (*)
          write(s, SE % ed) xp; if (s(1:1) == '*') ww = ww + 1
          write(s, SE % ed) xm; if (s(1:1) == '*') ww = ww + 1
          write(SE % ed(6:10), '(SS,I2,".",I2)') ww, dd
        endif
      else
        ww = 4
        SE % ed = '(F4.0)'
      endif
      SE % w = ww
    endif
    if (SE % trm) then
      xmaxv = maxval(x, 1, mask=xfinite)  ! max in each column
      xminv = minval(x, 1, mask=xfinite)  ! min
      xzero = any(x == 0._quad, 1) ! true where column has some zeros
      xallz = all(x == 0._quad, 1) ! true where column has only zeros
      xnonn = any(x > h .or. x < -h .or. x /= x, 1)  ! true where column has some nonnormals (inf, -inf, nan)
      xalln = all(x > h .or. x < -h .or. x /= x, 1)  ! true where column has only nonnormals (inf, -inf, nan)
      call getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE,  wid, nbl)
    else
      wid = SE % w
      nbl = 0
    endif
  end subroutine find_editdesc_quad

  subroutine getwid_quad(xmaxv, xminv, xzero, xallz, xnonn, xalln, SE,  wid, nbl)
    ! determine length of the strings that result when writing with edit descriptor SE%ed a
    ! vector v where v(i) is xmaxv(i) or xminv(i) depending on which gives longer output
    real(quad),     intent(in)  :: xmaxv(:), xminv(:) ! max and min values in each column
    logical,        intent(in)  :: xzero(:), xallz(:) ! true for columns with some/all zeros
    logical,        intent(in)  :: xnonn(:), xalln(:) ! true for columns with some/all nonnormals
    type(settings), intent(in)  :: SE                 ! settings
    integer,        intent(out) :: wid(:)             ! widths of columns
    integer,        intent(out) :: nbl(:)             ! number of blanks to peel from left (w-wid)
    character(SE % w) :: stmax(size(xmaxv)), stmin(size(xmaxv))
    integer w
    w = SE % w
    write(stmin, SE % ed) xminv
    write(stmax, SE % ed) xmaxv
    nbl = mod(verify(stmin, ' ') + w, w + 1) ! loc. of first nonblank
    nbl = min(nbl, mod(verify(stmax, ' ') + w, w + 1))
    if (SE % gedit) then
      wid = w
    else
      wid = len_trim(adjustl(stmin))
      wid = max(wid, len_trim(adjustl(stmax)))
    endif
    if (SE % lzas > 0) then
      wid = merge(SE % lzas, wid, xallz)
      wid = max(wid, merge(SE % lzas, 0, xzero))
    endif
    wid = merge(4, wid, xalln)
    wid = max(wid, merge(4, 0, xnonn))
    nbl = w - wid
  end subroutine getwid_quad

  ! ******** TOSTRING QUADRUPLE PRECISION PROCEDURES ***********
  function tostring_s_quad(x) result(st)
    ! Scalar to string
    real(quad), intent(in) :: x
    character(len_f_quad((/x/), tosset % rfmt)) :: st
    st = tostring_f_quad((/x/), tosset % rfmt)
  end function tostring_s_quad

  function tostring_sf_quad(x, fmt) result(st)
    ! Scalar with specified format to string
    real(quad),   intent(in) :: x
    character(*), intent(in) :: fmt
    character(len_f_quad((/x/), fmt)) :: st
    st = tostring_f_quad((/x/), fmt)
  end function tostring_sf_quad

  function tostring_quad(x) result(st)
    ! Vector to string
    real(quad), intent(in) :: x(:)
    character(len_f_quad(x, tosset % rfmt)) :: st
    st = tostring_f_quad(x, tosset % rfmt)
  end function tostring_quad

  function tostring_f_quad(x, fmt) result(st)
    ! Vector with specified format to string
    real(quad)    ,       intent(in) :: x(:)
    character(*),         intent(in) :: fmt
    character(len_f_quad(x, fmt))    :: st
    character(widthmax_quad(x, fmt)) :: sa(size(x))
    character(nnblk(fmt)+8)          :: fmt1  !(5 for readfmt and 3 for replace_w)
    integer                          :: w, d, ww
    logical                          :: gedit
    call readfmt(fmt, fmt1, w, d, gedit)
    if (w < 0) then
      st = errormsg
      return
    elseif (w == 0) then
      ww = maxw_quad(x, d)
      call replace_w(fmt1, ww)
    endif
    write(sa, fmt1) x
    call trim_real(sa, gedit, w)
    call tostring_get(sa, st)
  end function tostring_f_quad

  pure function len_f_quad(x, fmt) result(wtot)
    ! Total length of returned string, vector s
    real(quad), intent(in)           :: x(:)
    character(*), intent(in)         :: fmt
    character(widthmax_quad(x, fmt)) :: sa(size(x))
    integer                          :: wtot, w, d, ww
    logical                          :: gedit
    character(nnblk(fmt)+8)          :: fmt1  !(5 for readfmt and 3 for replace_w)
    call readfmt(fmt, fmt1, w, d, gedit)
    if (w < 0) then; wtot = len(errormsg); return; endif
    if (w == 0) then
      ww = maxw_quad(x, d)
      call replace_w(fmt1, ww)
    endif
    write(sa, fmt1) x
    call trim_real(sa, gedit, w)
    wtot = sum(len_trim(sa)) + (size(x) - 1)*(tosset % seplen)
  end function len_f_quad

  pure function widthmax_quad(x, fmt) result(w)
    ! Maximum width of an element of x
    real(quad), intent(in)   :: x(:)
    character(*), intent(in) :: fmt
    character(nnblk(fmt)+5)  :: fmt1
    integer w, d
    logical gedit
    call readfmt(fmt, fmt1, w, d, gedit)
    if (w < 0) then ! illegal format, use 1
      w = 1
    elseif (w == 0) then
      w = maxw_quad(x, d)
    endif
  end function widthmax_quad

  ! *************************************** END OF QUADRUPLE PRECISION PROCEDURES ***************************************

  ! *************************************** QUADRUPLE PRECISION COMPLEX PROCEDURES **************************************
  subroutine disp_s_cplq(x, fmt, fmt_imag, advance, digmax, sep, trim, unit)
    ! quadruple precision complex scalar without title
    character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, trim
    complex(quad), intent(in) :: x
    integer, intent(in), optional :: unit, digmax
    call disp_ts_cplq('', x, fmt, fmt_imag, advance, digmax, sep, 'left', trim, unit)
  end subroutine disp_s_cplq

  subroutine disp_v_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
    ! quadruple precision complex vector without title
    character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
    complex(quad), intent(in) :: x(:)
    integer, intent(in), optional :: unit, lbound(:), digmax
    call disp_tv_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
  end subroutine disp_v_cplq

  subroutine disp_m_cplq(x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
    ! quadruple precision complex matrix without title
    character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
    complex(quad), intent(in) :: x(:,:)
    integer, intent(in), optional :: unit, digmax, lbound(:)
    call disp_tm_cplq('', x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
  end subroutine disp_m_cplq

  subroutine disp_ts_cplq(title, x, fmt, fmt_imag, advance, digmax, sep, style, trim, unit)
    ! quadruple precision complex scalar with title
    character(*), intent(in) :: title
    character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim
    complex(quad), intent(in) :: x
    integer, intent(in), optional :: unit, digmax
    call disp_tm_cplq(title, reshape((/x/), (/1, 1/)), fmt, fmt_imag, advance, digmax, sep=sep, style=style, &
                                                       trim=trim, unit=unit)
  end subroutine disp_ts_cplq

  subroutine disp_tv_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit, orient)
    ! quadruple precision complex vector with title
    character(*), intent(in) :: title
    character(*), intent(in), optional :: fmt, fmt_imag, advance, sep, style, trim, orient
    complex(quad), intent(in) :: x(:)
    integer, intent(in), optional :: unit, lbound(:), digmax
    type(settings) SE, SEim
    call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, orient, digmax=digmax)
    if (present(fmt_imag)) then
      if (.not.present(fmt)) then
        call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return;
      endif
      call get_SE(SEim, title, shape(x), fmt_imag)
    else
      SEim = SE
    end if
    if (SE % row) then
      call disp_cplq(title, reshape(x, (/1, size(x)/)), SE, SEim, n = size(x))
    else
      call disp_cplq(title, reshape(x, (/size(x), 1/)), SE, SEim, n = 1)
    end if
  end subroutine disp_tv_cplq

  subroutine disp_tm_cplq(title, x, fmt, fmt_imag, advance, digmax, lbound, sep, style, trim, unit)
    ! quadruple precision complex matrix with title
    character(*), intent(in)           :: title      ! The title to use for the matrix
    complex(quad),  intent(in)         :: x(:,:)     ! The matrix to be written
    character(*), intent(in), optional :: fmt        ! Edit descriptor for each element (real element when fmt_imag &
    !                                                ! is present)
    character(*), intent(in), optional :: fmt_imag   ! Edit descriptor for each imaginary element
    integer,      intent(in), optional :: unit       ! Unit to display on
    integer,      intent(in), optional :: digmax     ! Nbr of significant digits for largest abs value in real(x) &
    !                                                ! and aimag(x)
    character(*), intent(in), optional :: advance    ! 'No' to print next matrix to right of current, otherewise 'Yes'
    character(*), intent(in), optional :: sep        ! Separator between matrix columns (e.g. ", ")
    character(*), intent(in), optional :: style      ! Style(s): See NOTE 1 below
    character(*), intent(in), optional :: trim       ! 'Auto' (the default) to trim if fmt absent, 'no' for no
    !                                                ! trimming, 'yes' for trimming
    integer,      intent(in), optional :: lbound(:)  ! Lower bounds of x
    !
    type(settings) :: SE, SEim
    call get_SE(SE, title, shape(x), fmt, advance, lbound, sep, style, trim, unit, digmax=digmax)
    if (present(fmt_imag)) then
      if (.not.present(fmt)) then
        call disp_errmsg('DISP: error, FMT must be present if FMT_IMAG is present'); return
      endif
      call get_SE(SEim, title, shape(x), fmt_imag)
    else
      SEim = SE
    end if
    call disp_cplq(title, x, SE, SEim, n = size(x,2))
  end subroutine disp_tm_cplq

  subroutine disp_cplq(title, x, SE, SEim, n)
    ! quadruple precision item
    character(*),   intent(in)    :: title
    complex(quad),  intent(in)    :: x(:,:)
    type(settings), intent(inout) :: SE, SEim
    integer,        intent(in)    :: n
    integer, dimension(n) :: widre(n), widim(n), nblre(n), nblim(n)
    call find_editdesc_quad(real(x), SE, widre, nblre)         ! determine also SE % w
    call find_editdesc_quad(abs(aimag(x)), SEim, widim, nblim) ! determine also SEim % w
    call tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m = size(x,1), n = size(x,2))
  end subroutine disp_cplq

  subroutine tobox_cplq(title, x, SE, SEim, widre, widim, nblre, nblim, m, n)
    ! Write quadruple precision complex matrix to box
    character(*),   intent(in)    :: title
    complex(quad),  intent(in)    :: x(:,:)
    integer,        intent(in)    :: m, n, widre(:), widim(:), nblre(:), nblim(:)
    type(settings), intent(inout) :: SE, SEim
    character(SE % w)   :: s(m)
    character(SEim % w) :: sim(m)
    character(3)        :: sgn(m)
    integer             :: lin1, i, j, wleft, wid(n), widp(n)
    character, pointer  :: boxp(:,:)
    SE % zas = ''
    SEim % zas = ''
    wid = widre + widim + 4
    call preparebox(title, SE, m, n, wid, widp, lin1, wleft, boxp)
    do j=1,n
      if (m > 0) write(s, SE % ed) (real(x(i,j)), i=1,m)
      call copytobox(s, lin1, widre(j), widp(j) - widim(j) - 4, nblre(j), boxp,  wleft)
      do i=1,m
        if (aimag(x(i,j)) < 0) then; sgn(i) = ' - '; else; sgn(i) = ' + '; endif
        enddo
      call copytobox(sgn, lin1, 3, 3, 0, boxp,  wleft)
      if (m > 0) write(sim, SEim % ed) (abs(aimag(x(i,j))), i=1,m)
      call copytobox(sim, lin1, widim(j), widim(j), nblim(j), boxp,  wleft)
      call copyseptobox('i', m, lin1, boxp, wleft)
      if (j<n) call copyseptobox(SE % sep(1:SE % lsep), m, lin1, boxp,  wleft)
    enddo
    call finishbox(title, SE, boxp)
  end subroutine tobox_cplq

  ! ******* TOSTRING QUADRUPLE PRECISION COMPLEX PROCEDURES ********

  function tostring_s_cplq(x) result(st)
    complex(quad), intent(in)                   :: x
    character(len_s_cplq(x, tosset % rfmt)) :: st
    st = tostring_f_cplq((/x/), tosset % rfmt)
  end function tostring_s_cplq

  function tostring_sf_cplq(x, fmt) result(st)
    complex(quad),  intent(in)        :: x
    character(*), intent(in)          :: fmt
    character(len_s_cplq(x, fmt)) :: st
    st = tostring_f_cplq((/x/), fmt)
  end function tostring_sf_cplq

  function tostring_cplq(x) result(st)
    complex(quad), intent(in)               :: x(:)
    character(len_f_cplq(x, tosset % rfmt)) :: st
    st = tostring_f_cplq(x, tosset % rfmt)
  end function tostring_cplq

  function tostring_f_cplq(x, fmt) result(st)
    complex(quad),  intent(in)                    :: x(:)
    character(*),   intent(in)                    :: fmt
    character(len_f_cplq(x, fmt))                 :: st
    character(widthmax_quad(real(x), fmt))        :: sar(size(x))
    character(widthmax_quad(abs(x-real(x)), fmt)) :: sai(size(x))  ! x-real(x) instead of aimag(x) to enable the fnction
    character(1)                                  :: sgn(size(x))  ! to pass -stand:f95 switch of the ifort compiler.
    integer                                       :: w, d, wr, wi, i
    logical                                       :: gedit
    character(nnblk(fmt)+8)                       :: fmt1  !(5 for readfmt and 3 for replace_w)
    real(quad)                                    :: xre(size(x)), xim(size(x)), h
    call readfmt(fmt, fmt1, w, d, gedit)
    xre = real(x)
    xim = aimag(x)
    h = huge(h)
    if (w < 0) then
      st = errormsg
      return
    elseif (w == 0) then
      wr = maxw_quad(xre, d)
      wi = maxw_quad(xim, d)
      call replace_w(fmt1, max(wr, wi))
    endif
    write(sar, fmt1) real(x)
    write(sai, fmt1) abs(aimag(x))
    call trim_real(sar, gedit, w)
    call trim_real(sai, gedit, w)
    do i = 1,size(x); if (aimag(x(i)) < 0) then; sgn(i) = '-'; else; sgn(i) = '+'; endif; enddo
    call tostring_get_complex(sar, sgn, sai, st)
  end function tostring_f_cplq

  pure function len_s_cplq(x, fmt) result(wtot)
    complex(quad), intent(in) :: x
    character(*), intent(in)  :: fmt
    integer                   :: wtot, w, d
    logical                   :: gedit
    character(nnblk(fmt)+8)   :: fmt1
    call readfmt(fmt, fmt1, w, d, gedit)
    if (w < 0) then; wtot = len(errormsg); return; endif
    wtot = len_f_quad((/real(x)/), fmt) + len_f_quad((/abs(aimag(x))/), fmt) + 4
  end function len_s_cplq

  pure function len_f_cplq(x, fmt) result(wtot)
    complex(quad), intent(in) :: x(:)
    character(*), intent(in)  :: fmt
    integer                   :: wtot, w, d
    logical                   :: gedit
    character(nnblk(fmt)+8)   :: fmt1
    call readfmt(fmt, fmt1, w, d, gedit)
    if (w < 0) then; wtot = len(errormsg); return; endif
    wtot = len_f_quad(real(x), fmt) + len_f_quad(abs(aimag(x)), fmt) + size(x)*4 - (size(x) - 1)*(tosset % seplen)
    ! subtract seplen because it has been added twice in len_f_quad
  end function len_f_cplq
  ! *************************************** END OF QUADRUPLE PRECISION COMPLEX PROCEDURES ********************************

END MODULE DISP_R16MOD


module interface_07_mod
implicit none

interface a
    module procedure a1
    module procedure a2
end interface

contains

    integer function a1(a)
    integer, intent(in) :: a
    a1 = a + 1
    end function

    real function a2(a)
    real, intent(in) :: a
    a2 = a + 1
    end function

    subroutine run()
    integer :: i
    real :: r

    i = 5
    i = a(i)
    if (i /= 6) error stop

    r = 6
    r = a(r)
    if (r /= 7) error stop

    i = 7
    i = a(i)
    if (i /= 8) error stop
    end subroutine

end module

program interface_07
use interface_07_mod, only: run
implicit none

call run()

end program


program ch1001
    ! Reading Integer Data
    implicit none

    integer, parameter :: npeople = 10
    integer, dimension(1:npeople) :: height_feet, &
        height_inch, weight_stone, weight_pound
    real, dimension(1:npeople) :: height_m, weight_kg
    integer :: i

    open(10,file='ch1001.txt',status='old')
    open(20,file='ch1001.out',status='new')

    do i = 1, npeople
        read(10,100) height_feet(i), height_inch(i), &
            weight_stone(i), weight_pound(i)
        height_m(i) = (height_feet(i)*12+height_inch(i))*2.54/100
        weight_kg(i) = (weight_stone(i)*14+weight_pound(i))/2.2
        write(20,110) height_m(i), weight_kg(i)
    end do
    close(10)
    close(20)

100 format(i2,2x,i2,2x,i2,2x,i2)
110 format(1x,f5.2,2x,f4.1)
end program


! { dg-do run }
! Testcase for PR 31203
! We used to create strings with negative length
subroutine foo(i)
  integer :: i
  character(len=i) :: s(2)
  if (len(s) < 0) call abort
  if (len(s) /= max(i,0)) call abort
end

function gee(i)
  integer, intent(in) :: i
  character(len=i) :: gee

  gee = ""
end function gee

subroutine s1(i,j)
  character(len=i-j) :: a
  if (len(a) < 0) call abort()
end subroutine

program test
  interface
    function gee(i)
      integer, intent(in) :: i
      character(len=i) :: gee
    end function gee
  end interface

  call foo(2)
  call foo(-1)
  call s1(1,2)
  call s1(-1,-8)
  call s1(-8,-1)

  if (len(gee(2)) /= 2) call abort
  if (len(gee(-5)) /= 0) call abort
  if (len(gee(intfunc(3))) /= max(intfunc(3),0)) call abort
  if (len(gee(intfunc(2))) /= max(intfunc(2),0)) call abort

  if (len(bar(2)) /= 2) call abort
  if (len(bar(-5)) /= 0) call abort
  if (len(bar(intfunc(3))) /= max(intfunc(3),0)) call abort
  if (len(bar(intfunc(2))) /= max(intfunc(2),0)) call abort

  if (cow(bar(2)) /= 2) call abort
  if (cow(bar(-5)) /= 0) call abort
  if (cow(bar(intfunc(3))) /= max(intfunc(3),0)) call abort
  if (cow(bar(intfunc(2))) /= max(intfunc(2),0)) call abort

contains

  function bar(i)
    integer, intent(in) :: i
    character(len=i) :: bar

    bar = ""
  end function bar

  function cow(c)
    character(len=*), intent(in) :: c
    integer :: cow
    cow = len(c)
  end function cow

  pure function intfunc(i)
    integer, intent(in) :: i
    integer :: intfunc

    intfunc = 2*i-5
  end function intfunc

end program test


program incomp_beta
use statistical
implicit none
integer,parameter :: rs=8
real(rs) :: z,a,b,incomp_beta_f,t,dt
character(len=80) :: arg

if (command_argument_count() /= 3) then
   write(*,'(a)') 'Usage: incomp_beta [z] [a] [b]'
   stop
endif

call get_command_argument(1,arg) ; read(arg,*) z
call get_command_argument(2,arg) ; read(arg,*) a
call get_command_argument(3,arg) ; read(arg,*) b

write(*,*) incomp_beta_func(z,a,b)

end program


!##########################################################################
        module vars
!##########################################################################
	  SAVE
        double precision g_dx,g_dy,g_dz,dens,Re,eps,fac,Pr,beta,Th,Tc
        double precision qzero,qstpn,forcn,gx,gy,gz,Sc_t
        double precision flomas,rmax,alfapr,resor,fric,TI_SEM
        double precision ctime,dt,dtavg,dtsum,safety_factor,noise,Mdef
        double precision t_start_averaging1,t_start_averaging2,ubulk
	  double precision xst,xen,yst,yen,zst,zen
        integer alfabc,niter,nswp(4),nsweep,iter,nsweeps,ntime
        integer ngg,nge,ngc,n_unstpt,OMP_threads,iaddinlet,ireadinlet
        integer ngrid_input,ngrd_gl,maxcy,iproln,irestr
        integer itmax,sweeps,numfile,numfile1,numfile2
        integer conv_sch,diff_sch,sgs_model,solver,mg_itrsch
        integer bc_w,bc_e,bc_s,bc_n,bc_b,bc_t,UPROF_SEM
        integer Tbc_w,Tbc_e,Tbc_s,Tbc_n,Tbc_b,Tbc_t
        integer itime,itime_start,itime_end,n_out,ITMAX_PI
        integer ipref,jpref,kpref,prefdom,ITMAX_SEM,NE_SEM
	  integer pl,pl_ex,differencing,LMR,normal_inter,order
        character*80 keyword,L_n
	  logical :: LRESTART,LIMB,SGS,PERIODIC,LENERGY,LROUGH,PASSIVE ! passive tracer 10/2019
	  logical :: pressureforce,time_averaging,reinitmean
	  logical :: LPT,save_inflow,read_inflow,L_dt,LSCALAR,LSTRA ! stratification 09/2019
!============================== LSM VARIABLES =============================
        double precision reldif_LSM,length,densl,densg,nul,nug,mul,mug
        double precision cfl_lsm
        double precision uprev
	  double precision grx,gry,grz
	  double precision slope
        double precision densip12,densjp12,denskp12
	  double precision densim12,densjm12,denskm12
        double precision muip12,mujp12,mukp12,muim12,mujm12,mukm12
	  double precision Mdef_w
        integer ntime_reinit,accuracy
	  integer ngrid
	  integer numfile3
	  logical :: L_LSM,REINIT,L_LSMbase,L_LSMinit,LENDS
	  logical :: L_anim_phi,L_anim_grd
!=========================================================================
        end module
!##########################################################################


!___________________________________________________________________________
!     --- MODULE for quench behavior (quench.f90)
!     --- defines Jc(B,T)
!     --- computes Tcs(B,J),TcB0(B) IF desired
!     --- distribution R1.0, Lucas Brouwer 11/15/2018
!___________________________________________________________________________

MODULE quench

IMPLICIT NONE

PRIVATE

!     SUBROUTINEs
  PUBLIC check_quench
  PRIVATE secant,JcSCU,bisect

CONTAINS

!___________________________________________________________________________
!     --- Jc fit for SCU (from Diego)
!___________________________________________________________________________

	SUBROUTINE JcSCU(Temp,Bmag,Jc,TcB0)
		DOUBLE PRECISION Temp,Bmag,Jc,Bc
		DOUBLE PRECISION Jc0,Tc0,Bc0,TcB0
		DOUBLE PRECISION t,h

! RRP wire 0.6 mm diameter -> Diego's fit for SCU
    Jc0 = 6600;
    Tc0 = 16.7;
    Bc0 = 26.25;

!	Calc Jc for given B,T
    t = temp/Tc0
		Bc = Bc0*(1d0-t**1.52d0)
    h = Bmag/Bc
		TcB0 = Tc0*((1d0-Bmag/Bc0)**(1d0/1.52d0))
		IF (Bmag .lt. Bc) THEN
		  Jc = Jc0*(1d0-t**2d0)*h**(-0.5d0)*(1d0-h)**2
!		  Jc = Jc0*(1d0-(temp/Tc0)**2d0)*(Bmag/(Bc0*(1d0-(temp/Tc0)**1.52d0)))**(-0.5d0)*(1d0-(Bmag/(Bc0*(1d0-(temp/Tc0)**1.52d0))))**2
    ELSE
		  Jc = 0d0
    ENDIF

		RETURN
	END SUBROUTINE JcSCU

!___________________________________________________________________________
!     --- determines quench state
!___________________________________________________________________________

	SUBROUTINE check_quench(Jcw,Temp,Bmag,Jc,qflag,IfCu,Jc0,Tc0,Bc0,alpha,p)

		DOUBLE PRECISION Jcw,Temp,Bmag
		DOUBLE PRECISION Jc,IfCu
		INTEGER qflag

		DOUBLE PRECISION Jc0,Tc0,Bc0,Bc,Jc0m
		DOUBLE PRECISION t,h,alpha,p,TcB0,mm2msq

! RRP wire 0.6 mm diameter -> Diego's fit for SCU
!    Jc0 = 6600.0d0
!    Tc0 = 16.7d0
!    Bc0 = 26.25d0
!    alpha = 1.0d0
!    p = 1.52d0
		mm2msq = 1.0d6
		Jc0m = Jc0*mm2msq

    IF ((temp .GE. Tc0) .OR. (Jcw .GE. Jc0m) .OR. (Bmag .GE. Bc0))  THEN
      qflag = 1
      IfCu = 1.0d0
      Jc = -1.0d0
		ELSE
!	    Calc Jc for given B,T
      t = temp/Tc0
		  Bc = Bc0*(1d0-t**p)
      h = Bmag/Bc
		  TcB0 = Tc0*((1d0-Bmag/Bc0)**(1d0/p))
  		IF (Bmag .lt. Bc) THEN
!        Jc = mm2msq*Jc0*(1d0-t**2d0)*h**(-0.5d0)*(1d0-h)**2d0
        Jc = mm2msq*Jc0*(1d0-t**2d0)**alpha*(1d0-t**p)**(alpha-1d0)*h**(-0.5d0)*(1d0-h)**2d0
!		    Jc = Jc0*(1d0-(temp/Tc0)**2d0)*(Bmag/(Bc0*(1d0-(temp/Tc0)**1.52d0)))**(-0.5d0)*(1d0-(Bmag/(Bc0*(1d0-(temp/Tc0)**1.52d0))))**2
        IF (Jc .ge. Jc0m) THEN
				  Jc = Jc0m
        ENDIF
      ELSE
		    Jc = 0d0
      ENDIF

      IF (temp .GE. TcB0)  THEN
        qflag = 1
        IfCu = 1.0d0
			ELSE IF (Jcw .LE. Jc)  THEN
        qflag = -1
        IfCu = 0.0d0
      ELSE
        qflag = 0
        IfCu = 1.0d0-Jc/Jcw
      ENDIF

    ENDIF

		RETURN
	END SUBROUTINE check_quench

!___________________________________________________________________________
!     --- secant method for finding Tcs -> root search
!___________________________________________________________________________

	SUBROUTINE secant(Temp,Bmag,Jcw,Tcs,maxit,tol,i)
	  DOUBLE PRECISION Tcs,tol,x0,x1,y0,y1,dx,dy,x2
		DOUBLE PRECISION Temp,Bmag,Jcw,TcB0,mm2msq,Tc0
		INTEGER maxit
		INTEGER i,j
		mm2msq = 1.0d6

!   initial guesses -> probably dont want to overshoot b/c of multiple roots
!   bisection may be better to avoid multiple roots
!   could also make dx very small to hopefully avoid jumping around
    i = 0
    x0 = 1.9d0
    x1 = 2.0d0
		dx = x1-x0
		CALL JcSCU(x0,Bmag,y0,TcB0)
		y0 = y0-Jcw/mm2msq

		DO WHILE (ABS(dx).GT.tol)
		  CALL JcSCU(x1,Bmag,y1,TcB0)
		  y1 = y1-Jcw/mm2msq
			x2 = x1-y1*(x1-x0)/(y1-y0)
			x0 = x1
			x1 = x2
			dx = x1-x0
			y0 = y1

      i = i+1
		  IF (i.eq.maxit) THEN
		    EXIT
      END IF
		END DO

		Tcs = x0

		RETURN
	END SUBROUTINE secant

!___________________________________________________________________________
!     --- bisection method for finding Tcs -> root search
!___________________________________________________________________________

	SUBROUTINE bisect(Temp,Bmag,Jcw,Tcs,maxit,tol,i)
	  DOUBLE PRECISION Tcs,tol,x0,x1,y0,y1,dx,dy,x2
		DOUBLE PRECISION Temp,Bmag,Jcw,TcB0,mm2msq
		INTEGER maxit
		INTEGER i,j
		DOUBLE PRECISION a,b,c

		mm2msq = 1.0d6

!    search in 0.2 K ranges up to Tcs
!      -> hopefully never dips below and back up in this size
!      -> could be improved with safety and exit conditions
!         and by capping search range at TcB0

		DO i = 1,78,1
			x0 = 1d0+i*.2d0
			x1 = 1d0+(i+1)*.2d0

			CALL JcSCU(x0,Bmag,y0,TcB0)
			y0 = y0-Jcw/mm2msq
		  CALL JcSCU(x1,Bmag,y1,TcB0)
		  y1 = y1-Jcw/mm2msq

			IF (y1*y0 .lt. 0) THEN
				a = x0
				b = x1
				EXIT
			END IF
		END DO

		i = 1
		DO WHILE ((b-a)/2.0d0 .GT. tol)
			c = (a+b)/2.0d0

			CALL JcSCU(a,Bmag,y0,TcB0)
			y0 = y0-Jcw/mm2msq
		  CALL JcSCU(c,Bmag,y1,TcB0)
		  y1 = y1-Jcw/mm2msq

			IF (y1*y0 .lt. 0) THEN
				b=c
			ELSE
			  a=c
			END IF

      i = i+1
		  IF (i.eq.maxit) THEN
		    EXIT
      END IF

		END DO
		Tcs = (a+b)/2.0d0

		RETURN
	END SUBROUTINE bisect

END MODULE quench


!!
!! Luke McCulloch
!! solver.f90
!! 11-4-2012
!! Serial Approximate Riemann Solver

PROGRAM solver

  use precise, only : defaultp   ! Module to handle precision
  use constants                  ! Module for pi
  use input                      ! io module
  use geo                        ! geometry
  use initial_conditions         ! initial conditions
  use inv                        ! my implementation of the Thomas Algorithm
  use analytic                   ! exact solution

  IMPLICIT NONE

  integer, parameter :: WP=defaultp
  integer, parameter :: num_eqn = 2
  integer, parameter :: num_waves = 2
  real(wp), parameter :: e=2.718281828459045
  real(wp), parameter :: atol = 0.00000000000000001    ! a new tolerance
  INTEGER, DIMENSION(3), PARAMETER :: it1 = (/ 40, 80, 120 /)   ! output times

  INTEGER :: narg    ! # of command line arguments
  INTEGER :: i       ! dummy index in space
  INTEGER :: j       ! dummy index in space
  INTEGER :: n       ! dummy index in time
  INTEGER :: ex_n    ! seperate time index for exact sol.
  INTEGER :: npts    ! # of points 64001 interfaces (1D boundary is a point ghost nodes need to outer boundary)
  INTEGER :: ncells  ! # of cells 64002 centers (cell -> cell center)
  INTEGER :: nt      ! # of timesteps
  INTEGER :: t_1sec  ! index at approx 1 sec
  INTEGER :: waveI   ! index location of the max Left Eigenvalue

  INTEGER :: m,mw,mx ! entropy dummies

  ! Efficient Placement of these declarations...?
  CHARACTER(len=24) :: inputfile
  CHARACTER(len=24) :: outputfile
  CHARACTER(len=30) :: title
  CHARACTER(len=30) :: title2
  CHARACTER(len=30) :: scheme_type

  LOGICAL :: flexists     ! a logical variable. I .true. or .false.
  LOGICAL :: godunov      ! true for theta == integer 1 else theta is real

  integer, ALLOCATABLE, DIMENSION(:)      :: mthlim       ! LaVeque limiter selector

  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: pts          ! 1 x npts array of points (cell boundaries)
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: cells        ! 1 x ncells = npts+1  array of cells

  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: lamda        ! 2 x ncells = vector of eigenvalues
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: F            ! 2 x ncells = Flux vector for each cell
  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: Q            ! 2 x ncells = storage vector for current H,uH
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: qL,qR        ! left and right q(i) on the ith cell
                                                          ! these agree with Q(i), the cell average.
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: alpha        ! 1 x ncells = npts+1  array of cells
  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: wave         ! Riemann problem waves (num_eqn, num_wave, ncells)

  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: H            ! 1 x ncells array cell - height
  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: uH           ! 1 x ncells array cell - momentum
  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: u            ! 1 x ncells array cell - speed
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: H_hat        ! 1 x npts face centered
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: u_hat        ! 1 x npts face centered
  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: H_exact      ! 1 x ncells array cell

  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: s            ! entropy fix
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: amdq         ! left-going flux-differences
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: apdq         ! right-going flux-differences

  REAL(WP), ALLOCATABLE, DIMENSION(:,:,:) :: error        ! 1 x ncells array cell temperatures
  REAL(WP), ALLOCATABLE, DIMENSION(:,:)   :: k            ! 1 x npts array of heat fluxes
  REAL(WP), ALLOCATABLE, DIMENSION(:)     :: am           ! sub   - diagonal
  REAL(WP), ALLOCATABLE, DIMENSION(:)     :: bm           ! main  - diagonal
  REAL(WP), ALLOCATABLE, DIMENSION(:)     :: cm           ! super - diagonal
  REAL(WP), ALLOCATABLE, DIMENSION(:)     :: dm           ! implicit RHS

  real(wp) :: g        ! gravitational acceleration
  real(wp) :: L        ! length
  real(wp) :: xo       ! starting position
  real(wp) :: dx       ! cell width
  real(wp) :: dt       ! timestep
  real(wp) :: dtdx     ! dt/dx
  real(wp) :: dt_max   ! timestep max
  real(wp) :: HL       ! thermal conductivity cnst
  real(wp) :: HRoHL    ! part of Robin's B.C
  real(wp) :: C        ! Courant Number
  real(wp) :: ev_max   ! max eigenvale abs value from analytic solution
  real(wp) :: time     ! actual time
  real(wp) :: svtm     ! saved time
  real(wp) :: tol      ! tolerance value
  real(wp) :: tout     ! print at this time
  real(wp) :: waveloc  ! x location of max left eigenvalue

  real(wp) :: store1p  ! store a variable
  real(wp) :: store2p  ! store a variable
  real(wp) :: store1n  ! store a variable
  real(wp) :: store2n  ! store a variable

  real(wp) :: dummy1   ! dummy vbl
  !real(wp) :: dummy2   ! dummy vbl
  !sreal(wp) :: dummy3   ! dummy vbl
  real(wp) :: dummy4   ! dummy vbl
  real(wp) :: dummy5   ! dummy vbl
  real(wp) :: dummy6   ! dummy vbl

  real(wp) :: delta(2) !

  real(wp) :: cbar     ! sqrt(gh)

!!$  real(wp) :: rho_c    ! density times specific heat
!!$  real(wp) :: a        ! part of Robin's B.C.
!!$  real(wp) :: b        ! part of Robin's B.C.
!!$  real(wp) :: t_s      ! part of Robin's B.C.
!!$  real(wp) :: cnst1    ! placeholder for calculations
!!$  real(wp) :: cnst2    ! placeholder for calculations
!!$  real(wp) :: delta_q  ! change
!!$  real(wp) :: a1       ! i-1 term
!!$  real(wp) :: b1       ! i   term
!!$  real(wp) :: c1       ! i+1 term
!!$  real(wp) :: theta    ! scheme variable
!!$  real(wp) :: RHS      ! explicit Physics
!!$  real(wp) :: Su       ! source used for explicit B.C. -> bk pg. 250 ex. 8.1
!!$  real(wp) :: ae       ! book shorthand
!!$  real(wp) :: aw       ! book shorthand
!!$  real(wp) :: apo      ! book shorthand

  real(wp) :: start
  real(wp) :: finish

  !entropy fix
  real(wp) :: s0 ! entropy
  real(wp) :: s1 ! entropy
  real(wp) :: s2 ! entropy
  real(wp) :: s3 ! entropy

  real(wp) :: hr1 ! entropy
  real(wp) :: uhr1 ! entropy
  real(wp) :: hl2 ! entropy
  real(wp) :: uhl2 ! entropy
  real(wp) :: sfract ! entropy

  real(wp) :: df      ! entropy
  real(wp) :: dtdxave ! entropy

  !! Command Line argument input stuff... zzz --zz---z--------------------------------------!
  write(*,*) ''
  WRITE(6,'(A)') 'Project 1, v 1.0, Sept 2012, Main Program, Luke McCulloch '
  narg = command_argument_count()
  WRITE(6, FMT='(AI3A)') 'we have ', narg, ' command line arguments '
  IF ( narg > 1 ) THEN

     CALL get_command_argument(1, inputfile)

     CALL get_command_argument(2, outputfile)

     !CALL get_command_argument(3, scheme_type)

  ELSE
     WRITE(6,'(A)') ' Input file or Output file missing!'
     WRITE(6,'(A)') ' Usage:>  ./test <inputfile> <outputfile>' ! <scheme_type> '
     STOP
  ENDIF
  INQUIRE(file=inputfile, exist=flexists)
  !! Parse the input & output files
  IF (flexists) THEN
     !! Startup:
     WRITE(6,'(AA)') ' input file,  ', inputfile
     WRITE(6,*) 'output file, ', outputfile
     !WRITE(6,*) 'scheme type, ', scheme_type
     WRITE(6,'(A)') 'ENME 6728 Unsteady Shallow Water Scheme'
     Write(6,*)     ' 8-25-2012 Implementation By Luke McCulloch'
     write(6,*) ''
     Write(6,*)     ' Soving the Shallow Water Equations in 1D'
     write(6,*) '-----------------------------------------------------'
     call input_discrete( inputfile, outputfile, title, &
                         L, xo, npts, pts, ncells, cells, &
                         nt, H, u, uH, HL, HRoHL, H_hat, u_hat,C)

     write(*,*)'HL=',HL
     write(*,*)'HR/HL=',HRoHL
     ! Parse the Scheme Type
     godunov = .True.

  ENDIF
  !! End command line argument stuff---------------------------------------------------------!

  write(*,'(A4,D16.4,A8,I4,A10,I4,A12,I4,A12,D16.4)') '  L= ',L,'  npts= ', npts,'ncells= ',ncells
  write(*,'(A12,I4,A12,D16.4)') ' nt= ',nt

  write(*,*) ''
  call line(dx, L, xo, npts, pts, ncells, cells)
  write(6,'(A4,D16.8)') '  dx =', dx
  write(*,*) ''
  write(*,*) '  Face Locations:'
  !write(*,'(1D16.8)') pts

  If (godunov .eqv. .true.) then
     !dt_max = 0.9
     !write(*,*) 'Explicit scheme, dt max =', dt_max
     !write(*,*) 'Choose a time step less than this'
     !write(*,*) 'Please input your choice of time step size as a real number :>'
     !write(*,*) 'Using Cournot Number of 0.9:'
     OPEN(10,file='ev.dat')
     read(10,'(AAAAA)') title2
     read(10,*) ev_max
     !read(*,*)  dt
     close(10)
     dt = C*dx/(ev_max+1)
     write(*,*) 'Using C =',C,', and lamda_max = ',ev_max,'dt = ',dt
     !write(*,*) 'dt=',dt
  end if

  !write(*,*) 'Please input your choice of output time as a real number, in seconds :>'
  !read(*,*)  tout
  tout = 1.
  !nt = !int(tout/dt)+1
  nt=1!do time stepping in place.
  write(*,*)'nt*dt=',nt*dt,'nt=', nt

  ALLOCATE( h(1,ncells,nt+1))
  ALLOCATE( uH(1,ncells,nt+1))
  ALLOCATE( u(1,ncells,nt+1))
  ALLOCATE( Q(num_eqn,ncells,nt+1) )
  allocate( qL(num_eqn,ncells))
  allocate( qR(num_eqn,ncells))
  allocate( wave(num_eqn, num_waves, ncells ) )
  allocate( s(num_waves, ncells ) )
  allocate( amdq(num_eqn, ncells ) )
  allocate( apdq(num_eqn, ncells ) )
  allocate( mthlim(num_waves) )

!! limiter settings
! mthlim(mw) = 0 for no limiter
!             = 1 for minmod
!             = 2 for superbee
!             = 3 for van Leer
!             = 4 for monotonized centered
  mthlim(1) = 1
  mthlim(2) = 1

  write(*,*) ''
  call InitialConditions1D(npts, ncells, pts, cells,  HL, HRoHL, H, u, uH, Q, qL, qR)
  !call InitialConditions1D(npts, ncells, pts, cells,  HL, HRoHL, H, u, uH, Q, qL, qR)
  !write(*,*) '  Initial H:'
  !do i=1,ncells
  !   write(*,*)'cell loc=',cells(1,i),'initial H=', H(1,i,1),'initial U = ',u(1,i,1),'initial uH=',uH(1,i,1)
  !end do
  !write(*,'(A4,D16.4)') '  k= ',k
  !stop
  ALLOCATE( lamda(num_eqn,npts) )
  ALLOCATE( F(num_eqn,npts) )
  ALLOCATE( alpha(num_eqn,npts) )

  print*, 'npts   = ', npts
  print*, 'ncells = ', ncells

  g=9.81 !! gravitational acceleration, m/s/s
  !tol = .001
!!=============================================f===========================================
  !If (explicit .eqv. .True.) Then
  call cpu_time(start)
  Write (*,*) '------------------Begin Godunov Shallow Water Solver------------------------'
  Write (*,*) '============================================================================'

  u(1,1,1)=1.0
  time=0.
  !! #Time Loop -> changed for do while!
  n=1
  do while (time<tout)
!  do n=1,nt
   !write(*,*) time

     !! #Cell face "pts" loop to update Roe avg vbls at the faces
     dummy5=1.

     !------------------------------------------------------
     ! Main loop of the Riemann solver.
     do i=1,npts
        ! hbar, LaVeque 15.32
        H_hat(1,i)=(H(1,i+1,n)+H(1,i,n))/2.

        ! Roe Average Velocity, LaVeque 15.35
        u_hat(1,i)=( u(1,i+1,n)*sqrt(H(1,i+1,n)) + u(1,i,n)*sqrt(H(1,i,n)) )/&
             (sqrt(H(1,i+1,n))+sqrt(H(1,i,n)))
        !mixing conventions.... sorry!
        cbar = sqrt(0.5d0*g*(qr(1,i+1) + ql(1,i)))  !  0.5 * g * (u(1,i) + u(1,i-1)) where u(1) is h

        !! eigen values, LaVeque 15.36
        lamda(1,i) = u_hat(1,i)-sqrt(g*H_hat(1,i))
        lamda(2,i) = u_hat(1,i)+sqrt(g*H_hat(1,i))

        ! ubar = (sqrt(u_l) + sqrt(u_r)) / (sqrt(h_l) + sqrt(h_r))
        ! cbar = sqrt( 0.5 * g * (h_l + h_r))
        !
        ! ubar = u_hat
        ! cbar = sqrt(g*H_hat(1,i))

        dummy1 = 1.0/( lamda(2,i) - lamda(1,i) )
        delta(1) = H(1,i+1,n)-H(1,i,n) !delta1
        delta(2) = uH(1,i+1,n) - uH(1,i,n) !delta2
        dummy4 = u(1,i,n)*uH(1,i,n) + g*((H(1,i,n))**2)/2.

        !! alpha coefficients, LaVeque 15.39. eignevector expansion of delta(1) delta(2)
        !alpha(1,i) = dummy1* (  lamda(2,i)*delta(1) - delta(2) )
        !alpha(2,i) = dummy1* ( -lamda(1,i)*delta(1) + delta(2) )
!
        alpha(1,i) = 0.5d0*(-delta(2) + (u_hat(1,i) + cbar) * delta(1))/cbar
        alpha(2,i) = 0.5d0*( delta(2) - (u_hat(1,i) - cbar) * delta(1))/cbar

        ! Finally, compute the waves:
        wave(1,1,i) = alpha(1,i)
        wave(2,1,i) = alpha(1,i)*(u_hat(1,i) - cbar)
        s(1,i) = u_hat(1,i) - cbar

        wave(1,2,i) = alpha(2,i)
        wave(2,2,i) = alpha(2,i)*(u_hat(1,i) + cbar)
        s(2,i) = u_hat(1,i) + cbar
        ! needed for HR schemes and for entropy fix

        !! Define the flux at each interface
        !F(1,i) = uH(1,i,n) + min(lamda(1,i),0.)*alpha(1,i) + min(lamda(2,i),0.)*alpha(2,i)
        !F(2,i) = dummy4 + min(lamda(1,i),0.)*alpha(1,i)*lamda(1,i) + min(lamda(2,i),0.)*alpha(2,i)*lamda(2,i)

     end do !End Riemann flux update, non entropy
     !------------------------------------------------------

     !------------------------------------------------------
     !! entropy fix for transonic rarefaction (FIXME!)
      !do 200 i=1,npts
      do 200 i = 2, ncells-1

         ! u-c in left state
         s0 = qr(2,i-1)/qr(1,i-1) - sqrt(g*qr(1,i-1))  !uh/u - sqrt(hu)

        ! check for fully supersonic case:
        if (s0 >= 0.0 .and. s(1,i) > 0.0)  then
            !all right-going
            do m=1,2
               !amdq,apdq = 0.d0 !left and right going waves
               amdq(m,i) = 0.d0
            enddo
            go to 200
        endif

        ! u-c to right of 1-wave
        hr1  = qr(1,i-1) + wave(1,1,i)
        uhr1 = qr(2,i-1) + wave(2,1,i)
        s1 =  uhr1/hr1 - dsqrt(g*hr1)
        if (s0 < 0.d0 .and. s1 > 0.d0) then
            ! transonic rarefaction in the 1-wave
            !write(*,*) 'found transonic rarefaction in the 1 wave'
            sfract = s0 * (s1-s(1,i)) / (s1-s0)
            !write(*,*) 's0 ',s0,'s1 ',s1,'s(1,i) ',s(1,i)
            !write(*,*) 'sfract ',sfract
            !write(*,*) 'time = ', time

        else if (s(1,i) < 0.d0) then
            ! 1-wave is leftgoing
            !write(*,*) '1 wave is leftgoing'
            sfract = s(1,i)
        else
            ! 1-wave is rightgoing
            !write(*,*) '1 wave is rightgoing'
            sfract = 0.d0   !# this shouldn't happen since s0 < 0
        endif

        do m=1,2
            amdq(m,i) = sfract*wave(m,1,i)
            !if (s0 < 0.d0 .and. s1 > 0.d0) then
            !   write(*,*) 'amdq(m,i) = ',amdq(m,i)
            !endif
            enddo

        ! -------------------------------------------------------
        ! check 2-wave:
        ! ---------------
        ! u+c in right state  (cell i)
        s3 = ql(2,i)/ql(1,i) + dsqrt(g*ql(1,i))

        ! u+c to left of 2-wave
        hl2  = ql(1,i) - wave(1,2,i)
        uhl2 = ql(2,i) - wave(2,2,i)
        s2 = uhl2/hl2 + dsqrt(g*hl2)

        if (s2 < 0.d0 .and. s3 > 0.d0) then
            ! transonic rarefaction in the 2-wave
            !write(*,*) 'found transonic rarefaction in the 2 wave'
            sfract = s2 * (s3-s(2,i)) / (s3-s2)
        else if (s(2,i) < 0.d0) then
            ! 2-wave is leftgoing
            !write(*,*) '2 wave is leftgoing'
            sfract = s(2,i)
        else
            ! 2-wave is rightgoing
            !write(*,*) '2 wave is rightgoing'
            go to 200
        endif

        do m=1,2
            amdq(m,i) = amdq(m,i) + sfract*wave(m,2,i)
            !if (s2 < 0.d0 .and. s3 > 0.d0) then
            !   write(*,*) 'amdq(m,i) = ',amdq(m,i)
            !endif
            enddo

    200 enddo

    ! compute the rightgoing flux differences:
    ! df = SUM s*wave   is the total flux difference and apdq = df - amdq

    do m=1,2
        do i=1,npts
        !do i = 2, ncells-1
            df = 0.d0
            do mw=1,num_waves
                df = df + s(mw,i)*wave(m,mw,i)
            enddo
            apdq(m,i) = df - amdq(m,i)
         enddo
    enddo

!    !End Riemann entropy correction
! !  ============================================

!     !! apply correction
     dtdx = dt/dx

    do i = 1, ncells-1
    !do i = 2, ncells
      ! do m = 1, num_eqn ! left boundary
      !     Q(m,i-1,n) = Q(m,i-1,n) - dtdx*amdq(m,i)
      ! end do
      ! do m = 1, num_eqn ! right boundary
      !    Q(m,i,n) = Q(m,i,n) - dtdx*apdq(m,i)
      ! end do
      do m = 1, num_eqn ! left boundary
          Q(m,i,n) = Q(m,i,n) - dtdx*amdq(m,i)
      end do
      do m = 1, num_eqn ! right boundary
         Q(m,i+1,n) = Q(m,i+1,n) - dtdx*apdq(m,i)
      end do

      !write(*,*)'i= ',i, 'amdq(m,i)=',amdq(m,i), ' apdq(m,i)= ',apdq(m,i)
   end do

!     # compute maximum wave speed:
   C = 0.d0
   do i = 2, ncells-1
       do mw=1,num_waves
       !          # if s>0 use dtdx(i) to compute CFL,
       !          # if s<0 use dtdx(i-1) to compute CFL:
           C = dmax1(C, dtdx*s(mw,i), -dtdx*s(mw,i))
       end do
   end do

   !! call second order limiter:
!  ============================================
   call limiter(ncells,num_eqn,num_waves,1,ncells, wave,s,mthlim)

!  apply the f
!  ============================================
   !do i=1,mx+1
   do i=1,npts
   !do i = 2, ncells-1
   !do i = 1, ncells
      do m = 1,num_eqn
          f(m,i) = 0.d0
      end do
      dtdxave = dtdx ! 0.5d0 * ( dtdx(left) + dtdx(right) )
      do mw=1,num_waves
          do m=1,num_eqn
              f(m,i) = f(m,i) + 0.5d0 * dabs(s(mw,i)) &
              * (1.d0 - dabs(s(mw,i))*dtdxave) * wave(m,mw,i)
          end do
      end do
  end do

!  # Update cell centered values H, uH, and u
!  # i.e. Q by differencing correction fluxes
!  ============================================
   do i = 2, ncells-1
      do m = 1, num_eqn
        Q(m,i,n+1) = Q(m,i,n) + dtdx * ( F(m,i-1) - F(m,i) )
      end do
      !Q(1,i,n+1) = Q(1,i,n) + dtdx * ( F(1,i-1) - F(1,i) )
      !Q(2,i,n+1) = Q(2,i,n) + dtdx * ( F(2,i-1) - F(2,i) )
      H(1,i,n+1)  = Q(1,i,n+1)
      uH(1,i,n+1) = Q(2,i,n+1)
      u(1,i,n+1)  = uH(1,i,n+1)/H(1,i,n+1)
   end do

     !! #Update cell centered values H, uH, and u
   !   do i=2,ncells-1
   !      H(1,i,n+1)  = H(1,i,n) + (dt/dx)*(F(1,i-1)-F(1,i))
   !      uH(1,i,n+1) = uH(1,i,n) + (dt/dx)*(F(2,i-1)-F(2,i))
   !      u(1,i,n+1)  = uH(1,i,n+1)/H(1,i,n+1)

   !      Q(1,i,n+1) = H(1,i,n+1)
   !      Q(2,i,n+1) = uH(1,i,n+1)

   !      !write(*,*)'i= ',i,' H= ',H(1,i,n),'uH=',uH(1,i,n),' u= ',u(1,i,n)
   !   end do !End conservation update

     !Update the LHS ghost cell:
     H(1,1, n+1)  =  H(1,2,n+1)
     u(1,1, n+1)  = -u(1,2,n+1)
     uH(1,1,n+1) =   H(1,1,n+1)*u(1,1,n+1)
     Q(1,1, n+1) =   H(1,2,n+1)
     Q(2,1, n+1) =   H(1,1,n+1)*u(1,1,n+1)
     !Update the RHS ghost cell:
     H(1,ncells, n+1)  = H(1,ncells-1,n+1)
     u(1,ncells, n+1)  = -u(1,ncells-1,n+1)
     uH(1,ncells,n+1) = u(1,ncells,n)*H(1,ncells,n)
     Q(1,ncells, n+1) = H(1,ncells-1,n+1)
     Q(2,ncells, n+1) = u(1,ncells,n)*H(1,ncells,n)

     ! This is the time at which the updated values exist
     !time = time+dt
     store1p=0.
     store2p=0.
     store1n=0.
     store2n=0.

     if (n==nt) then
        t_1sec = n
        svtm   = time
        !WRITE(*,*) 't_1sec = ',t_1sec, 't=',time
        !write(*,*)'--------------------Soulution out:------------------------------'
        !do i=1,ncells
        !   write(*,*)'i= ',i,'cell = ',cells(1,i),' H= ',H(1,i,n+1),'uH=',uH(1,i,n+1),' u= ',u(1,i,n+1)
        !end do
        do i=1,npts
           store1p=max(store1p,lamda(1,i))
           store2p=max(store2p,lamda(2,i))
           store1n=max(store1n,-lamda(1,i))
           store2n=max(store2n,-lamda(2,i))
           !write(*,*)'i= ',i,'cell = ',cells(1,i),' eigen1= ', lamda(1,i),'  eigen2= ', lamda(2,i)
        end do
        store1p=max(store1p,store2p)
        store1n=-max(store1n,store2n)

        !print*

        !print*
        !write(*,*)'eigen1 max = ',store1n,'eigen2 max=',store1p
     end if

     !Update in place
     do i=1,ncells
        H(1,i,n)  = H(1,i,n+1)
        uH(1,i,n) = uH(1,i,n+1)
        u(1,i,n)  = u(1,i,n+1)

        Q(1,i,n) = Q(1,i,n+1)
        Q(2,i,n) = Q(2,i,n+1)

        qL(:,i) = Q(:,i,n+1)
        qR(:,i) = Q(:,i,n+1)

        !write(*,*)'i= ',i,' H= ',H(1,i,n),'uH=',uH(1,i,n),' u= ',u(1,i,n)
     end do !End conservation update

     dt = C*dx/(store1p)
     time = time+dt
  !end time loop
  end do
  write(*,*)'eigen1 max = ',store1n,'eigen2 max=',store1p

  do i=1,npts
     if (abs((lamda(1,i)-store1n)) < atol) then
        !write(*,*) lamda(1,i), store1n, ((lamda(1,i)-store1n))
        waveloc = pts(1,i)
        waveI=i
        !write(*,*) waveloc, waveI
     end if

     !write(*,*)'i= ',i,'lamda1= ',lamda(1,i),'lamda2= ',lamda(2,i),'','Flux1=',F(1,i),'Flux2=',F(2,i)
     !write(*,*)'i= ',i,'uhat= ',H_hat(1,i),'Hhat= ',H_hat(1,i)
  end do
  call cpu_time(finish)
!!========================================================================================

!!----------------------------Exact Solution----------------------------------------
  ALLOCATE( H_exact(1,ncells,3) )
  ALLOCATE( error(1,ncells,3) )

!!$  print*
!!$   write(*,*)'----------------------------------------------------'
!!$   write(*,*) 'Comparison,         Numerical    to        Exact'
!!$  do i=1,ncells
!!$     write(*,*) n, H(1,i,n+1), H_exact(1,i,n)
!!$  end do
!!$  print*
!!$  write(*,*) '  % Error'
!!$  do i=1,ncells
!!$     write(*,*) error(1,i,n)
!!$  end do

!!----------------------------End Exact Solution----------------------------------------

  print '("Computation Time = ",f19.10," seconds.")',finish-start
  ! Question 1 output style
  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=1, FILE='x_pos.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO i=2, ncells-1
     WRITE(UNIT=1,FMT='(F19.10)')cells(1,i)
  End do
  WRITE(UNIT=1,FMT='(" ")')
  CLOSE(UNIT=1)

  ! output Gnuplot file-------------------------Solution---------------------------
  OPEN(UNIT=2, FILE='u.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO i=2, ncells-1
     WRITE(UNIT=2,FMT='(F19.10)') u(1,i,t_1sec)
  End do
  WRITE(UNIT=2,FMT='(" ")')
  CLOSE(UNIT=2)
!!$
  OPEN(UNIT=3, FILE='H.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO  i=2, ncells-1
     WRITE(UNIT=3,FMT='(F19.10)')H(1,i,t_1sec)
  End do
  WRITE(UNIT=3,FMT='(" ")')
  CLOSE(UNIT=3)

  OPEN(UNIT=4, FILE='uH.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  DO  i=2, ncells-1
     WRITE(UNIT=4,FMT='(F19.10)')uH(1,i,t_1sec)
  End do
  WRITE(UNIT=4,FMT='(" ")')
  CLOSE(UNIT=4)

  OPEN(UNIT=5, FILE='time.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  WRITE(UNIT=5,FMT='(F19.10)')svtm
  WRITE(UNIT=5,FMT='(" ")')
  CLOSE(UNIT=5)

  OPEN(UNIT=5, FILE='LeftWaveSpeed.dat',FORM='FORMATTED',STATUS='REPLACE')!,IOSTAT=ios)
  WRITE(UNIT=5,FMT='(F19.10,F19.10,I5)')store1n, waveloc, waveI
  WRITE(UNIT=5,FMT='(" ")')
  CLOSE(UNIT=5)

  IF (ALLOCATED(pts))          DEALLOCATE(pts)
  IF (ALLOCATED(cells))        DEALLOCATE(cells)
  IF (ALLOCATED(lamda))        DEALLOCATE(lamda)
  IF (ALLOCATED(F))            DEALLOCATE(F)
  IF (ALLOCATED(Q))            DEALLOCATE(Q)
  IF (ALLOCATED(alpha))        DEALLOCATE(alpha)

  IF (ALLOCATED(H))            DEALLOCATE(H)
  IF (ALLOCATED(u))            DEALLOCATE(u)
  IF (ALLOCATED(H_hat))        DEALLOCATE(H_hat)
  IF (ALLOCATED(u_hat))        DEALLOCATE(u_hat)
  IF (ALLOCATED(uH))           DEALLOCATE(uH)
  IF (ALLOCATED(H_exact))      DEALLOCATE(H_exact)

  IF (ALLOCATED(k))            DEALLOCATE(k)
  IF (ALLOCATED(am))           DEALLOCATE(am)
  IF (ALLOCATED(bm))           DEALLOCATE(bm)
  IF (ALLOCATED(cm))           DEALLOCATE(cm)
  IF (ALLOCATED(dm))           DEALLOCATE(dm)

  IF (ALLOCATED(qL))           DEALLOCATE(qL)
  IF (ALLOCATED(qR))           DEALLOCATE(qR)
  IF (ALLOCATED(wave))         DEALLOCATE(wave)
  IF (ALLOCATED(s))            DEALLOCATE(s)
  IF (ALLOCATED(amdq))         DEALLOCATE(amdq)
  IF (ALLOCATED(apdq))         DEALLOCATE(apdq)

  if (allocated(mthlim))       deallocate(mthlim)

END PROGRAM solver


        subroutine iddp_aid0(eps,m,n,a,krank,list,proj,rnorms)
c
c       uses routine iddp_id to ID a without modifying its entries
c       (in contrast to the usual behavior of iddp_id).
c
c       input:
c       eps -- precision of the decomposition to be constructed
c       m -- first dimension of a
c       n -- second dimension of a
c
c       output:
c       krank -- numerical rank of the ID
c       list -- indices of the columns in the ID
c       proj -- matrix of coefficients needed to interpolate
c               from the selected columns to the other columns in a;
c               proj doubles as a work array in the present routine, so
c               must be at least m*n real*8 elements long
c
c       work:
c       rnorms -- must be at least n real*8 elements long
c
c       _N.B._: proj must be at least m*n real*8 elements long
c
        implicit none
        integer m,n,krank,list(n),j,k
        real*8 eps,a(m,n),proj(m,n),rnorms(n)
c
c
c       Copy a into proj.
c
        do k = 1,n
          do j = 1,m
            proj(j,k) = a(j,k)
          enddo ! j
        enddo ! k
c
c
c       ID proj.
c
        call iddp_id(eps,m,n,proj,krank,list,rnorms)
c
c
        return
        end
c
c
c
c


*> \brief \b SGBTF2 computes the LU factorization of a general band matrix using the unblocked version of the algorithm.
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download SGBTF2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
*       .. Scalar Arguments ..
*       INTEGER            INFO, KL, KU, LDAB, M, N
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       REAL               AB( LDAB, * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGBTF2 computes an LU factorization of a real m-by-n band matrix A
*> using partial pivoting with row interchanges.
*>
*> This is the unblocked version of the algorithm, calling Level 2 BLAS.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] KL
*> \verbatim
*>          KL is INTEGER
*>          The number of subdiagonals within the band of A.  KL >= 0.
*> \endverbatim
*>
*> \param[in] KU
*> \verbatim
*>          KU is INTEGER
*>          The number of superdiagonals within the band of A.  KU >= 0.
*> \endverbatim
*>
*> \param[in,out] AB
*> \verbatim
*>          AB is REAL array, dimension (LDAB,N)
*>          On entry, the matrix A in band storage, in rows KL+1 to
*>          2*KL+KU+1; rows 1 to KL of the array need not be set.
*>          The j-th column of A is stored in the j-th column of the
*>          array AB as follows:
*>          AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
*>
*>          On exit, details of the factorization: U is stored as an
*>          upper triangular band matrix with KL+KU superdiagonals in
*>          rows 1 to KL+KU+1, and the multipliers used during the
*>          factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
*>          See below for further details.
*> \endverbatim
*>
*> \param[in] LDAB
*> \verbatim
*>          LDAB is INTEGER
*>          The leading dimension of the array AB.  LDAB >= 2*KL+KU+1.
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (min(M,N))
*>          The pivot indices; for 1 <= i <= min(M,N), row i of the
*>          matrix was interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>          INFO is INTEGER
*>          = 0: successful exit
*>          < 0: if INFO = -i, the i-th argument had an illegal value
*>          > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
*>               has been completed, but the factor U is exactly
*>               singular, and division by zero will occur if it is used
*>               to solve a system of equations.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date September 2012
*
*> \ingroup realGBcomputational
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  The band storage scheme is illustrated by the following example, when
*>  M = N = 6, KL = 2, KU = 1:
*>
*>  On entry:                       On exit:
*>
*>      *    *    *    +    +    +       *    *    *   u14  u25  u36
*>      *    *    +    +    +    +       *    *   u13  u24  u35  u46
*>      *   a12  a23  a34  a45  a56      *   u12  u23  u34  u45  u56
*>     a11  a22  a33  a44  a55  a66     u11  u22  u33  u44  u55  u66
*>     a21  a32  a43  a54  a65   *      m21  m32  m43  m54  m65   *
*>     a31  a42  a53  a64   *    *      m31  m42  m53  m64   *    *
*>
*>  Array elements marked * are not used by the routine; elements marked
*>  + need not be set on entry, but are required by the routine to store
*>  elements of U, because of fill-in resulting from the row
*>  interchanges.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
*
*  -- LAPACK computational routine (version 3.4.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     September 2012
*
*     .. Scalar Arguments ..
      INTEGER            INFO, KL, KU, LDAB, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               AB( LDAB, * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J, JP, JU, KM, KV
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      EXTERNAL           ISAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGER, SSCAL, SSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     KV is the number of superdiagonals in the factor U, allowing for
*     fill-in.
*
      KV = KU + KL
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KL.LT.0 ) THEN
         INFO = -3
      ELSE IF( KU.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDAB.LT.KL+KV+1 ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGBTF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Gaussian elimination with partial pivoting
*
*     Set fill-in elements in columns KU+2 to KV to zero.
*
      DO 20 J = KU + 2, MIN( KV, N )
         DO 10 I = KV - J + 2, KL
            AB( I, J ) = ZERO
   10    CONTINUE
   20 CONTINUE
*
*     JU is the index of the last column affected by the current stage
*     of the factorization.
*
      JU = 1
*
      DO 40 J = 1, MIN( M, N )
*
*        Set fill-in elements in column J+KV to zero.
*
         IF( J+KV.LE.N ) THEN
            DO 30 I = 1, KL
               AB( I, J+KV ) = ZERO
   30       CONTINUE
         END IF
*
*        Find pivot and test for singularity. KM is the number of
*        subdiagonal elements in the current column.
*
         KM = MIN( KL, M-J )
         JP = ISAMAX( KM+1, AB( KV+1, J ), 1 )
         IPIV( J ) = JP + J - 1
         IF( AB( KV+JP, J ).NE.ZERO ) THEN
            JU = MAX( JU, MIN( J+KU+JP-1, N ) )
*
*           Apply interchange to columns J to JU.
*
            IF( JP.NE.1 )
     $         CALL SSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
     $                     AB( KV+1, J ), LDAB-1 )
*
            IF( KM.GT.0 ) THEN
*
*              Compute multipliers.
*
               CALL SSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
*
*              Update trailing submatrix within the band.
*
               IF( JU.GT.J )
     $            CALL SGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
     $                       AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
     $                       LDAB-1 )
            END IF
         ELSE
*
*           If pivot is zero, set INFO to the index of the pivot
*           unless a zero pivot has already been found.
*
            IF( INFO.EQ.0 )
     $         INFO = J
         END IF
   40 CONTINUE
      RETURN
*
*     End of SGBTF2
*
      END


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
cc
      subroutine dirft2d1(nj,xj,yj,cj, iflag, ms,mt,fk)
      implicit none
      integer nj, iflag, ms, mt
      real(8) xj(nj), yj(nj)
      complex(8) cj(nj), fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2)
c     ------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c                  1  nj
c     fk(k1,k2) = -- SUM cj(j) exp(+/-i k1 xj(j)) exp(+/-i k2 yj(j))
c                 nj j=1
c
c     for -ms/2 <= k1 <= (ms-1)/2, -mt/2 <= k2 <= (mt-1)/2
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
c***********************************************************************
      integer j, k1, k2
      complex(8) zf, cm1, z1n(-ms/2:(ms-1)/2)
c
      do k2 = -mt/2, (mt-1)/2
         do k1 = -ms/2, (ms-1)/2
            fk(k1,k2) = cmplx(0d0,0d0, kind=8)
         enddo
      enddo
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
c
         if (iflag .ge. 0) then
            zf = cmplx(dcos(xj(j)),+dsin(xj(j)),kind=8)
         else
            zf = cmplx(dcos(xj(j)),-dsin(xj(j)),kind=8)
         endif
         z1n(0) = cmplx(1d0,0d0, kind=8)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= conjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = conjg(zf*z1n(ms/2-1))
c
c     ----------------------------------------------------------
c     Loop over k2 for yj
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = cmplx(dcos(yj(j)),+dsin(yj(j)),kind=8)
         else
            zf = cmplx(dcos(yj(j)),-dsin(yj(j)),kind=8)
         endif
c
         cm1 = cj(j) / cmplx(nj,0.0d0,kind=8)
         do k2 = 0, (mt-1)/2
            do k1 = -ms/2, (ms-1)/2
              fk(k1,k2) = fk(k1,k2) + cm1*z1n(k1)
            enddo
            cm1 = cm1*zf
         enddo
c
         zf = conjg(zf)
         cm1 = cj(j) / cmplx(nj,0.,kind=8)
         do k2 = -1, -mt/2, -1
            cm1 = cm1*zf
            do k1 = -ms/2, (ms-1)/2
              fk(k1,k2) = fk(k1,k2) + cm1*z1n(k1)
            enddo
         enddo
      enddo
      end
c
c
c
c
c
c************************************************************************
      subroutine dirft2d2(nj,xj,yj,cj, iflag, ms,mt,fk)
      implicit none
      integer nj, iflag, ms, mt
      real(8) xj(nj), yj(nj)
      complex(8) cj(nj), fk(-ms/2:(ms-1)/2,-mt/2:(mt-1)/2)
c     ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c
c     cj(j) = SUM  SUM  fk(k1,k2) exp(+/-i k1 xj(j)) exp(+/-i k2 yj(j))
c             k1   k2
c
c                            for j = 1,...,nj
c
c     where -ms/2 <= k1 <= (ms-1)/2, -mt/2 <= k2 <= (mt-1)/2
c
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
************************************************************************
      integer j, k1, k2
      complex(8) zf, cm1, cm2, z1n(-ms/2:(ms-1)/2)
c
      do j = 1, nj
c
c     ----------------------------------------------------------
c     Precompute exponential for exp(+/-i k1 xj)
c     ----------------------------------------------------------
         if (iflag .ge. 0) then
            zf = cmplx(dcos(xj(j)),+dsin(xj(j)),kind=8)
         else
            zf = cmplx(dcos(xj(j)),-dsin(xj(j)),kind=8)
         endif
         z1n(0) = cmplx(1d0,0d0,kind=8)
         do k1 = 1, (ms-1)/2
            z1n(k1) = zf*z1n(k1-1)
            z1n(-k1)= conjg(z1n(k1))
         enddo
         if (ms/2*2.eq.ms) z1n(-ms/2) = conjg(zf*z1n(ms/2-1))
         if (iflag .ge. 0) then
            zf = cmplx(dcos(yj(j)),+dsin(yj(j)),kind=8)
         else
            zf = cmplx(dcos(yj(j)),-dsin(yj(j)),kind=8)
         endif
c
         cm1 = cmplx(0d0, 0d0,kind=8)
         do k1 = -ms/2, (ms-1)/2
           cm1 = cm1 + z1n(k1) * fk(k1,0)
         enddo
         cj(j) = cm1
c
c     ----------------------------------------------------------
c     Loop over k2 for yj
c     ----------------------------------------------------------
c
         cm2 = zf
         do k2 = 1, (mt-1)/2
            cm1 = cmplx(0d0, 0d0,kind=8)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,k2)
            enddo
            cj(j) = cj(j) + cm2 * cm1

            cm1 = cmplx(0d0, 0d0,kind=8)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,-k2)
            enddo
            cj(j) = cj(j) + conjg(cm2) * cm1
            cm2 = cm2*zf
         enddo
c
         if (mt/2*2.eq.mt) then
            cm1 = cmplx(0d0, 0d0,kind=8)
            do k1 = -ms/2, (ms-1)/2
              cm1 = cm1 + z1n(k1) * fk(k1,-mt/2)
            enddo
            cj(j) = cj(j) + conjg(cm2) * cm1
         endif

      enddo
      end

************************************************************************
      subroutine dirft2d3(nj,xj,yj,cj, iflag, nk,sk,tk,fk)
      implicit none
      integer nj, iflag, nk
      real(8) xj(nj), yj(nj), sk(nk), tk(nk)
      complex(8) cj(nj), fk(nk)
c ----------------------------------------------------------------------
c     direct computation of nonuniform FFT
c
c              nj
c     fk(k) = SUM cj(j) exp(+/-i s(k) xj(j)) exp(+/-i t(k) yj(j))
c             j=1
c
c                    for k = 1, ..., nk
c
c     If (iflag .ge.0) the + sign is used in the exponential.
c     If (iflag .lt.0) the - sign is used in the exponential.
c
************************************************************************
      integer k, j
      real(8) ssk, stk
c
      do k = 1, nk
         if (iflag .ge. 0) then
            ssk =  sk(k)
            stk =  tk(k)
         else
            ssk =  -sk(k)
            stk =  -tk(k)
         endif
c
         fk(k) = cmplx(0d0,0d0,kind=8)
         do j = 1, nj
            fk(k) = fk(k) + cj(j) * cmplx( dcos(ssk*xj(j)+stk*yj(j)),
     &                                     dsin(ssk*xj(j)+stk*yj(j)),
     &                                     kind=8 )
         enddo
      enddo
      end


c> \file
c> \defgroup Averaging Average fine grids to a coarse grid
c> Average cells from coarse grid to fine grid.
c>
c> Routines described here average are used to fill coarse grid ghost
c> cells, and average sibling grids onto a parent grid.  Indices
c> for cells at block boundaries are transformed using encodings
c> stored in `transform_cptr`.
c>
c> \param [in] mx,my       Number of cells in x,y direction
c> \param [in] mbc      Number of ghost cells
c> \param [in] meqn     Number of equations
c> \param [in] qcoarse,qfine  Solution on coarse,fine grid
c> \param [in] areacoarse,areafine  Area of mesh cells on coarse,fine grids.
c> \param [in] idir     Face orientation - 0 for x-faces; 1 for y-faces [0-1]
c> \param [in] iface    Face number of fine grid [0-3].
c> \param [in] iface_coarse Face number of coarse grid [0-3].
c> \param [in] num_neighbors Number of fine grid neighbors [2].
c> \param [in] refratio  Refinement ratio between coarse and fine grids [2].
c> \param [in] manifold  Flag indicating whether we are on mapped grid [0-1].
c> \param [in] transform_cptr  Encoding for indices at block boundaries (C only).

c> \ingroup Averaging
c> Average fine ghost cell values.
c>
c> Average fine grid interior values to neighboring ghost cell values of
c> the coarse grid.
      subroutine fclaw2d_clawpatch5_fort_average_face(mx,my,mbc,meqn,
     &      qcoarse,qfine,areacoarse, areafine,
     &      idir,iface_coarse,num_neighbors,refratio,igrid,
     &      manifold, transform_cptr)
      implicit none

      integer mx,my,mbc,meqn,refratio,igrid,idir,iface_coarse
      integer manifold
      integer*8 transform_cptr
      integer num_neighbors
      double precision qfine(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
      double precision qcoarse(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

c     # these will be empty if we are not on a manifold.
      double precision areacoarse(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision   areafine(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      double precision sum, qf, kf
      logical is_manifold

      integer mq,r2, m, m1
      integer ic, ic1, ibc
      integer jc, jc1, jbc

c     # This should be refratio*refratio.
      integer rr2
      parameter(rr2 = 4)
      integer i2(0:rr2-1),j2(0:rr2-1)
      double precision kc

      logical fclaw2d_clawpatch_is_valid_average, skip_this_grid
      double precision af_sum, qv(0:rr2-1)

      is_manifold = manifold .eq. 1

c     # 'iface' is relative to the coarse grid

      r2 = refratio*refratio
      if (r2 .ne. rr2) then
         write(6,*) 'average_face_ghost (claw2d_utils.f) ',
     &         '  Refratio**2 is not equal to rr2'
         stop
      endif

c     # Average fine grid onto coarse grid
      if (idir .eq. 0) then
         do mq = 1,meqn
            do jc = 1,my
               do ibc = 1,mbc
c                 # ibc = 1 corresponds to first layer of ghost cells, and
c                 # ibc = 2 corresponds to the second layer

                  if (iface_coarse .eq. 0) then
                     ic = 1-ibc
                  elseif (iface_coarse .eq. 1) then
                     ic = mx+ibc
                  endif

                  call
     &       fclaw2d_clawpatch_transform_face_half(ic,jc,i2,j2,
     &                  transform_cptr)
c                 # ---------------------------------------------
c                 # Two 'half-size' neighbors will be passed into
c                 # this routine.  Only half of the coarse grid ghost
c                 # indices will be valid for the particular grid
c                 # passed in.  We skip those ghost cells that will
c                 # have to be filled in by the other half-size
c                 # grid.
c                 # ---------------------------------------------
                  skip_this_grid = .false.
                  do m = 0,r2-1
                     if (.not.
     &       fclaw2d_clawpatch_is_valid_average(i2(m),j2(m),mx,my))
     &                     then
                        skip_this_grid = .true.
                        exit
                     endif
                  enddo

                  if (.not. skip_this_grid) then
                     if (is_manifold) then
                        sum = 0
                        af_sum = 0
                        do m = 0,r2-1
                           qf = qfine(mq,i2(m),j2(m))
                           qv(m) = qf
                           kf = areafine(i2(m),j2(m))
                           sum = sum + qf*kf
                           af_sum = af_sum + kf
                        enddo
c                       # ----------------------------------------
c                       # At block seams, the coarse grid mesh cell
c                       # areas may not have been computed using
c                       # the correct metrics.
c                       # ----------------------------------------
c                       kc = areacoarse(ic,jc)
c                       qcoarse(mq,ic,jc) = sum/kc

c                       # Use areas of the fine grid mesh cells instead.
                        qcoarse(mq,ic,jc) = sum/af_sum
                     else
                        sum = 0
                        do m = 0,r2-1
                           sum = sum + qfine(mq,i2(m),j2(m))
                        enddo
                        qcoarse(mq,ic,jc) = sum/dble(r2)
                     endif
                  endif
               enddo
            enddo
         enddo
      else
         do mq = 1,meqn
c           # idir = 1 (faces 2,3)
            do jbc = 1,mbc
               do ic = 1,mx

                  if (iface_coarse .eq. 2) then
                     jc = 1-jbc
                  elseif (iface_coarse .eq. 3) then
                     jc = my+jbc
                  endif

                  call
     &       fclaw2d_clawpatch_transform_face_half(ic,jc,i2,j2,
     &                  transform_cptr)
                  skip_this_grid = .false.
                  do m = 0,r2-1
                     if (.not.
     &          fclaw2d_clawpatch_is_valid_average(i2(m),j2(m),mx,my))
     &                     then
                        skip_this_grid = .true.
                     endif
                  enddo
                  if (.not. skip_this_grid) then
                     if (is_manifold) then
                        sum = 0
                        af_sum = 0
                        do m = 0,r2-1
                           qf = qfine(mq,i2(m),j2(m))
                           kf = areafine(i2(m),j2(m))
                           sum = sum + qf*kf
                           af_sum = af_sum + kf
                        enddo
                        kc = areacoarse(ic,jc)
c                       qcoarse(mq,ic,jc) = sum/kc
                        qcoarse(mq,ic,jc) = sum/af_sum
                     else
                        sum = 0
                        do m = 0,r2-1
                           sum = sum + qfine(mq,i2(m),j2(m))
                        enddo
                        qcoarse(mq,ic,jc) = sum/dble(r2)
                     endif              !! manifold loop
                  endif                 !! skip grid loop
               enddo
            enddo
         enddo
      endif

      end

c> \ingroup Averaging
c> Average across corners.
      subroutine fclaw2d_clawpatch5_fort_average_corner(mx,my,mbc,meqn,
     &      refratio,qcoarse,qfine,areacoarse,areafine,
     &      manifold,icorner_coarse,transform_cptr)
      implicit none

      integer mx,my,mbc,meqn,refratio,icorner_coarse, manifold
      integer*8 transform_cptr
      double precision qcoarse(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
      double precision qfine(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

c     # these will be empty if we are not on a manifold.
      double precision areacoarse(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision   areafine(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      double precision sum

      integer i,j,ibc,jbc,ii,jj,mq,r2
      integer ifine, jfine
      logical is_manifold
      double precision qf,kf, kc

c     # This should be refratio*refratio.
      integer i1,j1,m
      integer rr2
      parameter(rr2 = 4)
      integer i2(0:rr2-1),j2(0:rr2-1)

      double precision af_sum

      r2 = refratio*refratio
      if (r2 .ne. rr2) then
         write(6,*) 'average_corner_ghost (claw2d_utils.f) ',
     &         '  Refratio**2 is not equal to rr2'
         stop
      endif

      is_manifold = manifold .eq. 1

      r2 = refratio*refratio
c     # Loop over four corner cells on coarse grid
      do ibc = 1,mbc
         do jbc = 1,mbc
c           # Average fine grid corners onto coarse grid ghost corners
            if (icorner_coarse .eq. 0) then
    1          i1 = 1-ibc
               j1 = 1-jbc
            elseif (icorner_coarse .eq. 1) then
               i1 = mx+ibc
               j1 = 1-jbc
            elseif (icorner_coarse .eq. 2) then
               i1 = 1-ibc
               j1 = my+jbc
            elseif (icorner_coarse .eq. 3) then
               i1 = mx+ibc
               j1 = my+jbc
            endif

c           # Again, a fake routine until the real one is
c           # available (be sure to pass in (i1,j1)
            call fclaw2d_clawpatch_transform_corner_half(i1,j1,i2,j2,
     &            transform_cptr)
            if (is_manifold) then
               do mq = 1,meqn
                  sum = 0
                  af_sum = 0
                  do m = 0,r2-1
                     qf = qfine(mq,i2(m),j2(m))
                     kf = areafine(i2(m),j2(m))
                     sum = sum + kf*qf
                     af_sum = af_sum + kf
                  enddo
                  kc = areacoarse(i1,j1)
c                 qcoarse(mq,i1,j1) = sum/kc
                  qcoarse(mq,i1,j1) = sum/af_sum
               enddo
            else
               do mq = 1,meqn
                  sum = 0
                  do m = 0,r2-1
                     sum = sum + qfine(mq,i2(m),j2(m))
                  enddo
                  qcoarse(mq,i1,j1) = sum/dble(r2)
               enddo
            endif
         enddo
      enddo

      end

c> \ingroup  Averaging
c> Average fine grid siblings to parent coarse grid.
      subroutine fclaw2d_clawpatch5_fort_average2coarse(mx,my,mbc,meqn,
     &      qcoarse,qfine,areacoarse,areafine,igrid,manifold)
      implicit none

      integer mx,my,mbc,meqn,p4est_refineFactor, refratio, igrid
      integer manifold
      double precision qcoarse(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
      double precision qfine(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)

c     # these will be empty if we are not on a manifold.
      double precision areacoarse(-mbc:mx+mbc+1,-mbc:my+mbc+1)
      double precision   areafine(-mbc:mx+mbc+1,-mbc:my+mbc+1)

      integer i,j, ig, jg, ic_add, jc_add, ii, jj, ifine, jfine
      integer mq
      double precision sum
      logical is_manifold

c     # This should be refratio*refratio.
      integer i1,j1, r2, m
      integer rr2
      parameter(rr2 = 4)
      integer i2(0:rr2-1),j2(0:rr2-1)
      double precision kc, kf, qf

      p4est_refineFactor = 2
      refratio = 2

      is_manifold = manifold .eq. 1

c     # 'iface' is relative to the coarse grid

      r2 = refratio*refratio
      if (r2 .ne. rr2) then
         write(6,*) 'average_face_ghost (claw2d_utils.f) ',
     &         '  Refratio**2 is not equal to rr2'
         stop
      endif

c     # Get (ig,jg) for grid from linear (igrid) coordinates
      ig = mod(igrid,refratio)
      jg = (igrid-ig)/refratio

c     # Get rectangle in coarse grid for fine grid.
      ic_add = ig*mx/p4est_refineFactor
      jc_add = jg*mx/p4est_refineFactor

      r2 = refratio*refratio
      do mq = 1,meqn
         do j = 1,my/p4est_refineFactor
            do i = 1,mx/p4est_refineFactor
               i1 = i+ic_add
               j1 = j+jc_add
               m = 0
               do jj = 1,refratio
                  do ii = 1,refratio
                     i2(m) = (i-1)*refratio + ii
                     j2(m) = (j-1)*refratio + jj
                     m = m + 1
                  enddo
               enddo
               if (is_manifold) then
                  sum = 0
                  do m = 0,r2-1
                     qf = qfine(mq,i2(m),j2(m))
                     kf = areafine(i2(m),j2(m))
                     sum = sum + kf*qf
                  enddo
                  kc = areacoarse(i1,j1)
                  qcoarse(mq,i1,j1) = sum/kc
               else
                  sum = 0
                  do m = 0,r2-1
                     qf = qfine(mq,i2(m),j2(m))
                     sum = sum + qf
                  enddo
                  qcoarse(mq,i1,j1) = sum/r2
               endif
            enddo
         enddo
      enddo
      end


MODULE m_qranf
CONTAINS
   REAL FUNCTION qranf(x,j)
!     **********************************************************
!     quasi random generator in the interval (0.,1.)
!     **********************************************************

      IMPLICIT NONE
!     .. Scalar Arguments ..
      REAL x
      INTEGER j
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC aint
!     ..
      j = j + 1
      qranf = j*x
      qranf = qranf - aint(qranf)
      RETURN
   END FUNCTION
END


program nans
    use, intrinsic :: ieee_arithmetic
    use, intrinsic :: iso_fortran_env, only : DP => REAL64
    implicit none
    real :: r, x
    real(kind=DP) :: nan
    character(len=20) :: fmt_str = '(A15, F15.7)'

    ! The compiler will generate errors for expressions that generate
    ! obvious NaNs, so we have to trick it using random numbers.
    x = 1.0
    call random_number(r)
    if (r > 1.0e-38) x = -1.0
    print fmt_str, 'sqrt(-1.0) =', sqrt(x)
    if (r > 1.0e-38) x = 0.0
    print fmt_str, '0.0/0.0 =', 0.0/x

    nan = ieee_value(0.0_DP, ieee_quiet_nan)
    if (nan /= nan) then
        print '(A)', 'NaN is not equal to itself'
    else
        print '(A)', 'NaN should be equal to itself'
    end if
    if (ieee_is_nan(nan)) then
        print '(A)', 'NaN is NaN'
    else
        print '(A)', 'NaN is not NaN'
    end if

end program nans