! { dg-do run }
! Tests the fix for PR35780, in which the assignment for C was not
! scalarized in expr.c.
!
! Contributed by Dick Hendrickson <dick.hendrickson@gmail.com>
!
MODULE MODS
  integer, parameter :: N = 10
  INTEGER, PARAMETER, DIMENSION(N) ::  A = [(i, i = 1, N)]
  INTEGER, PARAMETER, DIMENSION(N) ::  B = [(i - 5, i = 1, N)]
  INTEGER, PARAMETER, DIMENSION(N)  :: C = ISHFTC(3, B, 5)   !ICE
  INTEGER, PARAMETER, DIMENSION(N)  :: D = ISHFTC(A, 3, 5)   !  OK
  INTEGER, PARAMETER, DIMENSION(N)  :: E = ISHFTC(A, B, 5)   !  OK

END MODULE MODS

  use mods
  integer, dimension(N) :: X = A
  integer, dimension(N) :: Y = B

! Check the simplifed expressions against the library
  if (any (ISHFTC(3, Y, 5) /= C)) call abort ()
  if (any (ISHFTC(X, 3, 5) /= D)) call abort ()
  if (any (ISHFTC(X, Y, 5) /= E)) call abort ()
end
! { dg-final { cleanup-modules "mods" } }


program ch1303
    ! Simple Calculator
    implicit none

    integer :: i, j, k
    character :: op

    do
        print *, 'type in two integers'
        read *, i, j
        print *, 'type in operator'
        read '(a)', op

        select case (op)
        case ('+')
            k = i+j
            print *, 'sum of numbers is ', k
        case ('-')
            k = i-j
            print *, 'difference is ', k
        case ('*')
            k = i*j
            print *, 'multiplication is ', k
        case ('/')
            k = i/j
            print *, 'division is ', k
        case default
            exit
        end select
    end do
end program


!
! Copyright (C) by Argonne National Laboratory
!     See COPYRIGHT in top-level directory
!

! This file created from test/mpi/f77/datatype/typesubf.f with f77tof90

      program main
      use mpi_f08
      integer errs, ierr
      integer maxn, maxm
      parameter (maxn=10,maxm=15)
      integer fullsizes(2), subsizes(2), starts(2)
      integer fullarr(maxn,maxm),subarr(maxn-3,maxm-4)
      integer i,j, ssize
      integer size, rank, ans
      TYPE(MPI_Datatype) newtype

      errs = 0
      call mtest_init( ierr )
      call mpi_comm_size( MPI_COMM_WORLD, size, ierr )
      call mpi_comm_rank( MPI_COMM_WORLD, rank, ierr )
!
! Create a Fortran-style subarray
      fullsizes(1) = maxn
      fullsizes(2) = maxm
      subsizes(1)  = maxn - 3
      subsizes(2)  = maxm - 4
! starts are from zero, even in Fortran
      starts(1)    = 1
      starts(2)    = 2
! In Fortran 90 notation, the original array is
!    integer a(maxn,maxm)
! and the subarray is
!    a(1+1:(maxn-3) +(1+1)-1,2+1:(maxm-4)+(2+1)-1)
! i.e., a (start:(len + start - 1),...)
      call mpi_type_create_subarray( 2, fullsizes, subsizes, starts,  &
      &         MPI_ORDER_FORTRAN, MPI_INTEGER, newtype, ierr )
      call mpi_type_commit( newtype, ierr )
!
! Prefill the array
      do j=1, maxm
         do i=1, maxn
            fullarr(i,j) = (i-1) + (j-1) * maxn
         enddo
      enddo
      do j=1, subsizes(2)
         do i=1, subsizes(1)
            subarr(i,j) = -1
         enddo
      enddo
      ssize = subsizes(1)*subsizes(2)
      call mpi_sendrecv( fullarr, 1, newtype, rank, 0,  &
      &                   subarr, ssize, MPI_INTEGER, rank, 0,  &
      &                   MPI_COMM_WORLD, MPI_STATUS_IGNORE, ierr )
!
! Check the data
      do j=1, subsizes(2)
         do i=1, subsizes(1)
            ans = (i+starts(1)-1) + (j+starts(2)-1) * maxn
            if (subarr(i,j) .ne. ans) then
               errs = errs + 1
               if (errs .le. 10) then
                  print *, rank, 'subarr(',i,',',j,') = ', subarr(i,j)
               endif
            endif
         enddo
      enddo

      call mpi_type_free( newtype, ierr )

      call mtest_finalize( errs )

      end


Module grid_io_module

  Implicit None

  Public :: grid_io_save

  Private

Contains

  Subroutine grid_io_save( unit, filename, l, grid )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Use lattice_module, Only : lattice

    Integer                            , Intent( In ) :: unit
    Character( Len = * )               , Intent( In ) :: filename
    Type( lattice )                    , Intent( In ) :: l
    Real( wp ), Dimension( 0:, 0:, 0: ), Intent( In ) :: grid

    Real( wp ), Dimension( : , : ), Allocatable  :: lattice_vectors

    Real( wp ), Dimension( 1:3 ) :: f_point
    Real( wp ), Dimension( 1:3 ) :: r_point

    Integer, Dimension( 1:3 ) :: n_grid
    Integer, Dimension( 1:3 ) :: i_grid

    Integer :: i
    Integer :: i1, i2, i3

    n_grid = Ubound( grid ) + 1

    lattice_vectors = l%get_direct_vectors()

    Open( unit, file = filename )
    Write( unit, * ) 'Sum over grid           ', Sum( grid )
    Write( unit, * ) 'Average per unit volume ', Sum( grid ) / l%get_volume()
    Write( unit, '( 3( i0, 1x ), t60, a )' ) n_grid, '# grid size'
    Do i = 1, Ubound( lattice_vectors , Dim = 2 )
       Write( unit, '( 3( f11.6, 1x ), t60, a, i0  )' ) lattice_vectors( :, i ), '# lattice vector ', i
    End Do
    Do i3 = 0, n_grid( 3 ) - 1
       Do i2 = 0, n_grid( 2 ) - 1
          Do i1 = 0, n_grid( 1 ) - 1
             i_grid = [ i1, i2, i3 ]
             f_point = Real( i_grid, wp ) / n_grid
             Call l%to_direct( f_point, r_point )
             Write( unit, '( 3( f6.2, 1x ), 5x, f30.16 )' ) r_point, grid( i1, i2, i3 )
          End Do
       End Do
    End Do
    Close( unit )

  End Subroutine grid_io_save

End Module grid_io_module


module slope_module

  use bl_types

  implicit none

  integer, private, parameter :: cen = 1, lim = 2, flag = 3, fromm = 4

contains

  subroutine slopex_1d(s,slx,lo,hi,ng,nvar,bc)

    use bc_module
    use bl_constants_module
    use probin_module, only : slope_order

    integer        , intent(in   ) :: lo(:),hi(:),ng,nvar
    real(kind=dp_t), intent(in   ) ::   s(lo(1)-ng:,:)
    real(kind=dp_t), intent(  out) :: slx(lo(1)- 1:,:)
    integer        , intent(in)    :: bc(:,:,:)

    ! Local variables
    integer :: is,ie
    integer :: i,comp

    real(kind=dp_t) :: del,slim,sflag,dpls,dmin,ds
    real(kind=dp_t) :: dxscr(lo(1)-2:hi(1)+2,4)

    is = lo(1)
    ie = hi(1)
    if (slope_order .eq. 0) then

       ! HERE DOING 1ST ORDER
       slx = zero

    else if (slope_order .eq. 2) then

       ! HERE DOING 2ND ORDER
       do comp=1,nvar
          do i = is-1,ie+1
             del = half*(s(i+1,comp) - s(i-1,comp))
             dpls = two*(s(i+1,comp) - s(i  ,comp))
             dmin = two*(s(i  ,comp) - s(i-1,comp))
             slim = min(abs(dpls), abs(dmin))
             slim = merge(slim, zero, dpls*dmin.gt.ZERO)
             sflag = sign(one,del)
             slx(i,comp)= sflag*min(slim,abs(del))
          enddo

          if (bc(1,1,comp) .eq. EXT_DIR  .or. bc(1,1,comp) .eq. HOEXTRAP) then

             slx(is-1,comp) = zero
             del = (s(is+1,comp)+three*s(is,comp)- &
                  four*s(is-1,comp) ) * third
             dpls = two*(s(is+1,comp) - s(is  ,comp))
             dmin = two*(s(is  ,comp) - s(is-1,comp))
             slim = min(abs(dpls), abs(dmin))
             slim = merge(slim, zero, dpls*dmin.gt.ZERO)
             sflag = sign(one,del)
             slx(is,comp)= sflag*min(slim,abs(del))

          endif

          if (bc(1,2,comp) .eq. EXT_DIR  .or. bc(1,2,comp) .eq. HOEXTRAP) then

             slx(ie+1,comp) = zero
             del = -(s(ie-1,comp)+three*s(ie,comp)- &
                  four*s(ie+1,comp) ) * third
             dpls = two*(s(ie  ,comp) - s(ie-1,comp))
             dmin = two*(s(ie+1,comp) - s(ie  ,comp))
             slim = min(abs(dpls), abs(dmin))
             slim = merge(slim, zero, dpls*dmin.gt.ZERO)
             sflag = sign(one,del)
             slx(ie,comp)= sflag*min(slim,abs(del))

          endif
       enddo

    else

       ! HERE DOING 4TH ORDER
       do comp=1,nvar

          do i = is-2,ie+2
             dxscr(i,cen) = half*(s(i+1,comp)-s(i-1,comp))
             dmin = two*(s(i  ,comp)-s(i-1,comp))
             dpls = two*(s(i+1,comp)-s(i  ,comp))
             dxscr(i,lim)= min(abs(dmin),abs(dpls))
             dxscr(i,lim) = merge(dxscr(i,lim),zero,dpls*dmin.gt.ZERO)
             dxscr(i,flag) = sign(one,dxscr(i,cen))
             dxscr(i,fromm)= dxscr(i,flag)*min(dxscr(i,lim), &
                  abs(dxscr(i,cen)))
          enddo

          do i = is-1,ie+1
             ds = two * two3rd * dxscr(i,cen) - &
                  sixth * (dxscr(i+1,fromm) + dxscr(i-1,fromm))
             slx(i,comp) = dxscr(i,flag)*min(abs(ds),dxscr(i,lim))
          enddo

          if (bc(1,1,comp) .eq. EXT_DIR  .or. bc(1,1,comp) .eq. HOEXTRAP) then

             slx(is-1,comp) = zero

             del = -sixteen/fifteen*s(is-1,comp) + half*s(is,comp) + &
                  two3rd*s(is+1,comp) - tenth*s(is+2,comp)
             dmin = two*(s(is  ,comp)-s(is-1,comp))
             dpls = two*(s(is+1,comp)-s(is  ,comp))
             slim = min(abs(dpls), abs(dmin))
             slim = merge(slim, zero, dpls*dmin.gt.ZERO)
             sflag = sign(one,del)
             slx(is,comp)= sflag*min(slim,abs(del))

             ! Recalculate the slope at is+1 using the revised dxscr(is,fromm)
             dxscr(is,fromm) = slx(is,comp)
             ds = two * two3rd * dxscr(is+1,cen) - &
                  sixth * (dxscr(is+2,fromm) + dxscr(is,fromm))
             slx(is+1,comp) = dxscr(is+1,flag)*min(abs(ds),dxscr(is+1,lim))

          endif

          if (bc(1,2,comp) .eq. EXT_DIR  .or. bc(1,2,comp) .eq. HOEXTRAP) then

             slx(ie+1,comp) = zero

             del = -( -sixteen/fifteen*s(ie+1,comp) + half*s(ie,comp) +  &
                  two3rd*s(ie-1,comp) - tenth*s(ie-2,comp) )
             dmin = two*(s(ie  ,comp)-s(ie-1,comp))
             dpls = two*(s(ie+1,comp)-s(ie  ,comp))
             slim = min(abs(dpls), abs(dmin))
             slim = merge(slim, zero, dpls*dmin.gt.ZERO)
             sflag = sign(one,del)
             slx(ie,comp)= sflag*min(slim,abs(del))

             ! Recalculate the slope at ie-1 using the revised dxscr(ie,fromm)
             dxscr(ie,fromm) = slx(ie,comp)
             ds = two * two3rd * dxscr(ie-1,cen) - &
                  sixth * (dxscr(ie-2,fromm) + dxscr(ie,fromm))
             slx(ie-1,comp) = dxscr(ie-1,flag)*min(abs(ds),dxscr(ie-1,lim))

          endif
       enddo

    endif

  end subroutine slopex_1d

  subroutine slopex_2d(s,slx,lo,hi,ng,nvar,bc)

    use bc_module
    use bl_constants_module
    use probin_module, only : slope_order

    integer        , intent(in   ) :: lo(:),hi(:),ng,nvar
    real(kind=dp_t), intent(in   ) ::   s(lo(1)-ng:, lo(2)-ng:,:)
    real(kind=dp_t), intent(  out) :: slx(lo(1)- 1:, lo(2)- 1:,:)
    integer        , intent(in)    :: bc(:,:,:)

    ! Local variables
    integer :: is,js,ie,je
    integer :: i,j,comp

    real(kind=dp_t) :: del,slim,sflag,dpls,dmin,ds
    real(kind=dp_t) :: dxscr(lo(1)-2:hi(1)+2,4)

    is = lo(1)
    js = lo(2)
    ie = hi(1)
    je = hi(2)

    if (slope_order .eq. 0) then

       ! HERE DOING 1ST ORDER
       slx = zero

    else if (slope_order .eq. 2) then

       ! HERE DOING 2ND ORDER
       do comp=1,nvar
          do j = js-1,je+1
             do i = is-1,ie+1
                del = half*(s(i+1,j,comp) - s(i-1,j,comp))
                dpls = two*(s(i+1,j,comp) - s(i  ,j,comp))
                dmin = two*(s(i  ,j,comp) - s(i-1,j,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                slx(i,j,comp)= sflag*min(slim,abs(del))
             enddo

             if (bc(1,1,comp) .eq. EXT_DIR  .or. bc(1,1,comp) .eq. HOEXTRAP) then

                slx(is-1,j,comp) = zero
                del = (s(is+1,j,comp)+three*s(is,j,comp)- &
                     four*s(is-1,j,comp) ) * third
                dpls = two*(s(is+1,j,comp) - s(is  ,j,comp))
                dmin = two*(s(is  ,j,comp) - s(is-1,j,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                slx(is,j,comp)= sflag*min(slim,abs(del))

             endif

             if (bc(1,2,comp) .eq. EXT_DIR  .or. bc(1,2,comp) .eq. HOEXTRAP) then

                slx(ie+1,j,comp) = zero
                del = -(s(ie-1,j,comp)+three*s(ie,j,comp)- &
                     four*s(ie+1,j,comp) ) * third
                dpls = two*(s(ie  ,j,comp) - s(ie-1,j,comp))
                dmin = two*(s(ie+1,j,comp) - s(ie  ,j,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                slx(ie,j,comp)= sflag*min(slim,abs(del))

             endif
          enddo
       enddo

    else

       ! HERE DOING 4TH ORDER
       do comp=1,nvar
          do j = js-1,je+1

             do i = is-2,ie+2
                dxscr(i,cen) = half*(s(i+1,j,comp)-s(i-1,j,comp))
                dmin = two*(s(i  ,j,comp)-s(i-1,j,comp))
                dpls = two*(s(i+1,j,comp)-s(i  ,j,comp))
                dxscr(i,lim)= min(abs(dmin),abs(dpls))
                dxscr(i,lim) = merge(dxscr(i,lim),zero,dpls*dmin.gt.ZERO)
                dxscr(i,flag) = sign(one,dxscr(i,cen))
                dxscr(i,fromm)= dxscr(i,flag)*min(dxscr(i,lim), &
                     abs(dxscr(i,cen)))
             enddo

             do i = is-1,ie+1
                ds = two * two3rd * dxscr(i,cen) - &
                     sixth * (dxscr(i+1,fromm) + dxscr(i-1,fromm))
                slx(i,j,comp) = dxscr(i,flag)*min(abs(ds),dxscr(i,lim))
             enddo

             if (bc(1,1,comp) .eq. EXT_DIR  .or. bc(1,1,comp) .eq. HOEXTRAP) then

                slx(is-1,j,comp) = zero

                del = -sixteen/fifteen*s(is-1,j,comp) + half*s(is,j,comp) + &
                     two3rd*s(is+1,j,comp) - tenth*s(is+2,j,comp)
                dmin = two*(s(is  ,j,comp)-s(is-1,j,comp))
                dpls = two*(s(is+1,j,comp)-s(is  ,j,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                slx(is,j,comp)= sflag*min(slim,abs(del))

                ! Recalculate the slope at is+1 using the revised dxscr(is,fromm)
                dxscr(is,fromm) = slx(is,j,comp)
                ds = two * two3rd * dxscr(is+1,cen) - &
                     sixth * (dxscr(is+2,fromm) + dxscr(is,fromm))
                slx(is+1,j,comp) = dxscr(is+1,flag)*min(abs(ds),dxscr(is+1,lim))

             endif

             if (bc(1,2,comp) .eq. EXT_DIR  .or. bc(1,2,comp) .eq. HOEXTRAP) then

                slx(ie+1,j,comp) = zero

                del = -( -sixteen/fifteen*s(ie+1,j,comp) + half*s(ie,j,comp) +  &
                     two3rd*s(ie-1,j,comp) - tenth*s(ie-2,j,comp) )
                dmin = two*(s(ie  ,j,comp)-s(ie-1,j,comp))
                dpls = two*(s(ie+1,j,comp)-s(ie  ,j,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                slx(ie,j,comp)= sflag*min(slim,abs(del))

                ! Recalculate the slope at ie-1 using the revised dxscr(ie,fromm)
                dxscr(ie,fromm) = slx(ie,j,comp)
                ds = two * two3rd * dxscr(ie-1,cen) - &
                     sixth * (dxscr(ie-2,fromm) + dxscr(ie,fromm))
                slx(ie-1,j,comp) = dxscr(ie-1,flag)*min(abs(ds),dxscr(ie-1,lim))

             endif
          enddo
       enddo

    endif

  end subroutine slopex_2d

  subroutine slopey_2d(s,sly,lo,hi,ng,nvar,bc)

    use bc_module
    use bl_constants_module
    use probin_module, only : slope_order

    integer        , intent(in)  :: lo(:),hi(:),ng,nvar
    integer        , intent(in)  :: bc(:,:,:)
    real(kind=dp_t), intent( in) ::   s(lo(1)-ng:,lo(2)-ng:,:)
    real(kind=dp_t), intent(out) :: sly(lo(1)- 1:,lo(2)- 1:,:)

    ! local
    real(kind=dp_t) :: dyscr(lo(2)-2:hi(2)+2,4)
    real(kind=dp_t) :: dpls,dmin,ds,del,slim,sflag

    integer :: is,js,ie,je,i,j,comp

    is = lo(1)
    js = lo(2)
    ie = hi(1)
    je = hi(2)

    if (slope_order .eq. 0) then

       ! HERE DOING 1ST ORDER
       sly = zero

    else if (slope_order .eq. 2) then

       ! HERE DOING 2ND ORDER
       do comp=1,nvar
          do j = js-1,je+1
             do i = is-1,ie+1

                del  = half*(s(i,j+1,comp) - s(i,j-1,comp))
                dpls = two *(s(i,j+1,comp) - s(i,j  ,comp))
                dmin = two *(s(i,j  ,comp) - s(i,j-1,comp))
                slim = min(abs(dpls),abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                sly(i,j,comp)= sflag*min(slim,abs(del))

             enddo
          enddo

          if (bc(2,1,comp) .eq. EXT_DIR .or. bc(2,1,comp) .eq. HOEXTRAP) then

             do i = is-1,ie+1
                sly(i,js-1,comp) = zero
                del = (s(i,js+1,comp)+three*s(i,js,comp)- &
                     four*s(i,js-1,comp)) * third
                dpls = two*(s(i,js+1,comp) - s(i,js  ,comp))
                dmin = two*(s(i,js  ,comp) - s(i,js-1,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                sly(i,js,comp)= sflag*min(slim,abs(del))
             enddo

          endif

          if (bc(2,2,comp) .eq. EXT_DIR .or. bc(2,2,comp) .eq. HOEXTRAP) then

             do i = is-1, ie+1
                sly(i,je+1,comp) = zero
                del = -(s(i,je-1,comp)+three*s(i,je,comp)- &
                     four*s(i,je+1,comp)) * third
                dpls = two*(s(i,je+1,comp) - s(i,je ,comp))
                dmin = two*(s(i,je  ,comp) - s(i,je-1,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                sly(i,je,comp)= sflag*min(slim,abs(del))
             enddo

          endif
       enddo

    else

       ! HERE DOING 4TH ORDER
       do comp=1,nvar
          do i = is-1,ie+1
             do j = js-2,je+2
                dyscr(j,cen) = half*(s(i,j+1,comp)-s(i,j-1,comp))
                dmin = two*(s(i,j  ,comp)-s(i,j-1,comp))
                dpls = two*(s(i,j+1,comp)-s(i,j  ,comp))
                dyscr(j,lim)  = min(abs(dmin),abs(dpls))
                dyscr(j,lim)  = merge(dyscr(j,lim),zero,dpls*dmin.gt.ZERO)
                dyscr(j,flag) = sign(one,dyscr(j,cen))
                dyscr(j,fromm)= dyscr(j,flag)*min(dyscr(j,lim),abs(dyscr(j,cen)))
             enddo

             do j = js-1,je+1
                ds = two * two3rd * dyscr(j,cen) -  &
                     sixth * (dyscr(j+1,fromm) + dyscr(j-1,fromm))
                sly(i,j,comp) = dyscr(j,flag)*min(abs(ds),dyscr(j,lim))
             enddo

             if (bc(2,1,comp) .eq. EXT_DIR .or. bc(2,1,comp) .eq. HOEXTRAP) then

                sly(i,js-1,comp) = zero
                del = -sixteen/fifteen*s(i,js-1,comp) +  half*s(i,js ,comp) +  &
                     two3rd*s(i,js+1,comp) - tenth*s(i,js+2,comp)
                dmin = two*(s(i,js  ,comp)-s(i,js-1,comp))
                dpls = two*(s(i,js+1,comp)-s(i,js  ,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                sly(i,js,comp)= sflag*min(slim,abs(del))

                ! Recalculate the slope at js+1 using the revised dyscr(js,fromm)
                dyscr(js,fromm) = sly(i,js,comp)
                ds = two * two3rd * dyscr(js+1,cen) - &
                     sixth * (dyscr(js+2,fromm) + dyscr(js,fromm))
                sly(i,js+1,comp) = dyscr(js+1,flag)*min(abs(ds),dyscr(js+1,lim))

             endif

             if (bc(2,2,comp) .eq. EXT_DIR .or. bc(2,2,comp) .eq. HOEXTRAP) then

                sly(i,je+1,comp) = zero
                del = -( -sixteen/fifteen*s(i,je+1,comp) +  half*s(i,je  ,comp) + &
                     two3rd*s(i,je-1,comp) - tenth*s(i,je-2,comp) )
                dmin = two*(s(i,je ,comp)-s(i,je-1,comp))
                dpls = two*(s(i,je+1,comp)-s(i,je ,comp))
                slim = min(abs(dpls), abs(dmin))
                slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                sflag = sign(one,del)
                sly(i,je,comp)= sflag*min(slim,abs(del))

                ! Recalculate the slope at js+1 using the revised dyscr(js,fromm)
                dyscr(je,fromm) = sly(i,je,comp)
                ds = two * two3rd * dyscr(je-1,cen) -  &
                     sixth * (dyscr(je-2,fromm) + dyscr(je,fromm))
                sly(i,je-1,comp) = dyscr(je-1,flag)*min(abs(ds),dyscr(je-1,lim))

             endif

          enddo
       enddo

    endif

  end subroutine slopey_2d

  subroutine slopez_3d(s,slz,lo,hi,ng,nvar,bc)

    use bc_module
    use bl_constants_module
    use probin_module, only : slope_order

    integer        , intent(in)  :: lo(:),hi(:),ng,nvar
    integer        , intent(in)  :: bc(:,:,:)
    real(kind=dp_t), intent( in) ::   s(lo(1)-ng:,lo(2)-ng:,lo(3)-ng:,:)
    real(kind=dp_t), intent(out) :: slz(lo(1)- 1:,lo(2)- 1:,lo(3)- 1:,:)

    real(kind=dp_t) :: dzscr(lo(3)-2:hi(3)+2,4)
    real(kind=dp_t) :: dpls,dmin,ds,del,slim,sflag

    integer :: is,js,ks,ie,je,ke,i,j,k,comp

    is = lo(1)
    js = lo(2)
    ks = lo(3)
    ie = hi(1)
    je = hi(2)
    ke = hi(3)

    if (slope_order .eq. 0) then

       ! HERE DOING 1ST ORDER
       slz = zero

    else if (slope_order .eq. 2) then

       ! HERE DOING 2ND ORDER
       do comp=1,nvar
          do k = ks-1,ke+1
             do j = js-1,je+1
                do i = is-1,ie+1

                   del  = half*(s(i,j,k+1,comp) - s(i,j,k-1,comp))
                   dpls = two *(s(i,j,k+1,comp) - s(i,j,k  ,comp))
                   dmin = two *(s(i,j,k  ,comp) - s(i,j,k-1,comp))
                   slim = min(abs(dpls),abs(dmin))
                   slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                   sflag = sign(one,del)
                   slz(i,j,k,comp)= sflag*min(slim,abs(del))

                enddo
             enddo
          enddo

          if (bc(3,1,comp) .eq. EXT_DIR .or. bc(3,1,comp) .eq. HOEXTRAP) then
             do j = js-1,je+1
                do i = is-1,ie+1
                   slz(i,j,ks-1,comp) = zero
                   del = (s(i,j,ks+1,comp)+three*s(i,j,ks,comp)- &
                        four*s(i,j,ks-1,comp)) * third
                   dpls = two*(s(i,j,ks+1,comp) - s(i,j,ks  ,comp))
                   dmin = two*(s(i,j,ks  ,comp) - s(i,j,ks-1,comp))
                   slim = min(abs(dpls), abs(dmin))
                   slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                   sflag = sign(one,del)
                   slz(i,j,ks,comp)= sflag*min(slim,abs(del))
                enddo
             enddo

          endif

          if (bc(3,2,comp) .eq. EXT_DIR .or. bc(3,2,comp) .eq. HOEXTRAP) then

             do j = js-1, je+1
                do i = is-1, ie+1
                   slz(i,j,ke+1,comp) = zero
                   del = -(s(i,j,ke-1,comp)+three*s(i,j,ke,comp)- &
                        four*s(i,j,ke+1,comp)) * third
                   dpls = two*(s(i,j,ke+1,comp) - s(i,j,ke ,comp))
                   dmin = two*(s(i,j,ke  ,comp) - s(i,j,ke-1,comp))
                   slim = min(abs(dpls), abs(dmin))
                   slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                   sflag = sign(one,del)
                   slz(i,j,ke,comp)= sflag*min(slim,abs(del))
                enddo
             enddo

          endif
       enddo

    else

       ! HERE DOING 4TH ORDER
       do comp=1,nvar
          do j = js-1,je+1
             do i = is-1,ie+1
                do k = ks-2,ke+2
                   dzscr(k,cen) = half*(s(i,j,k+1,comp)-s(i,j,k-1,comp))
                   dmin = two*(s(i,j,k  ,comp)-s(i,j,k-1,comp))
                   dpls = two*(s(i,j,k+1,comp)-s(i,j,k  ,comp))
                   dzscr(k,lim)  = min(abs(dmin),abs(dpls))
                   dzscr(k,lim)  = merge(dzscr(k,lim),zero,dpls*dmin.gt.ZERO)
                   dzscr(k,flag) = sign(one,dzscr(k,cen))
                   dzscr(k,fromm)= dzscr(k,flag)*min(dzscr(k,lim),abs(dzscr(k,cen)))
                enddo

                do k = ks-1,ke+1
                   ds = two * two3rd * dzscr(k,cen) -  &
                        sixth * (dzscr(k+1,fromm) + dzscr(k-1,fromm))
                   slz(i,j,k,comp) = dzscr(k,flag)*min(abs(ds),dzscr(k,lim))
                enddo

                if (bc(3,1,comp) .eq. EXT_DIR .or. bc(3,1,comp) .eq. HOEXTRAP) then

                   slz(i,j,ks-1,comp) = zero
                   del = -sixteen/fifteen*s(i,j,ks-1,comp) +  half*s(i,j,ks ,comp) +  &
                        two3rd*s(i,j,ks+1,comp) - tenth*s(i,j,ks+2,comp)
                   dmin = two*(s(i,j,ks  ,comp)-s(i,j,ks-1,comp))
                   dpls = two*(s(i,j,ks+1,comp)-s(i,j,ks  ,comp))
                   slim = min(abs(dpls), abs(dmin))
                   slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                   sflag = sign(one,del)
                   slz(i,j,ks,comp)= sflag*min(slim,abs(del))

                   ! Recalculate the slope at js+1 using the revised dzscr(js,fromm)
                   dzscr(ks,fromm) = slz(i,j,ks,comp)
                   ds = two * two3rd * dzscr(ks+1,cen) - &
                        sixth * (dzscr(ks+2,fromm) + dzscr(ks,fromm))
                   slz(i,j,ks+1,comp) = dzscr(ks+1,flag)*min(abs(ds),dzscr(ks+1,lim))

                endif

                if (bc(3,2,comp) .eq. EXT_DIR .or. bc(3,2,comp) .eq. HOEXTRAP) then

                   slz(i,j,ke+1,comp) = zero
                   del = -( -sixteen/fifteen*s(i,j,ke+1,comp) +  half*s(i,j,ke  ,comp) + &
                        two3rd*s(i,j,ke-1,comp) - tenth*s(i,j,ke-2,comp) )
                   dmin = two*(s(i,j,ke ,comp)-s(i,j,ke-1,comp))
                   dpls = two*(s(i,j,ke+1,comp)-s(i,j,ke ,comp))
                   slim = min(abs(dpls), abs(dmin))
                   slim = merge(slim, zero, dpls*dmin.gt.ZERO)
                   sflag = sign(one,del)
                   slz(i,j,ke,comp)= sflag*min(slim,abs(del))

                   ! Recalculate the slope at ks+1 using the revised dzscr(ks,fromm)
                   dzscr(ke,fromm) = slz(i,j,ke,comp)
                   ds = two * two3rd * dzscr(ke-1,cen) -  &
                        sixth * (dzscr(ke-2,fromm) + dzscr(ke,fromm))
                   slz(i,j,ke-1,comp) = dzscr(ke-1,flag)*min(abs(ds),dzscr(ke-1,lim))

                endif
             enddo
          enddo
       enddo

    endif

  end subroutine slopez_3d

end module slope_module


      SUBROUTINE ETRBMS
C
C     BASIC BENDING TRIANGLE ELEMENT ROUTINE
C     SINGLE PRECISION VERSION
C
C     THIS SUBROUTINE CALCULATES THE COUPLED MASS MATRIX FOR THE BASIC
C     BENDING TRIANGLE.
C
C     ECPT LIST FOR BASIC BENDING TRIANGLE             NAME IN
C                                                      THIS
C     ECPT                                             ROUTINE   TYPE
C     ******************************************************************
C     ECPT( 1) = ELEMENT ID                            NECPT(1)  INTEGER
C     ECPT( 2) = GRID POINT A                          NGRID(1)  INTEGER
C     ECPT( 3) = GRID POINT B                          NGRID(2)  INTEGER
C     ECPT( 4) = GRID POINT C                          NGRID(3)  INTEGER
C     ECPT( 5) = THETA = ANGLE OF MATERIAL             ANGLE     REAL
C     ECPT( 6) = MATERIAL ID 1                         MATID1    INTEGER
C     ECPT( 7) = I = MOMENT OF INERTIA                 EYE       REAL
C     ECPT( 8) = MATERIAL ID 2                         MATID2    INTEGER
C     ECPT( 9) = T2                                    T2        REAL
C     ECPT(10) = NON-STRUCTURAL-MASS                   FMU       REAL
C     ECPT(11) = Z1                                    Z11       REAL
C     ECPT(12) = Z2                                    Z22       REAL
C     ECPT(13) = COORD. SYSTEM ID 1                    NECPT(13) INTEGER
C     ECPT(14) = X1                                    X1        REAL
C     ECPT(15) = Y1                                    Y1        REAL
C     ECPT(16) = Z1                                    Z1        REAL
C     ECPT(17) = COORD. SYSTEM ID 2                    NECPT(17) INTEGER
C     ECPT(18) = X2                                    X2        REAL
C     ECPT(19) = Y2                                    Y2        REAL
C     ECPT(20) = Z2                                    Z2        REAL
C     ECPT(21) = COORD. SYSTEM ID 3                    NECPT(21) INTEGER
C     ECPT(22) = X3                                    X3        REAL
C     ECPT(23) = Y3                                    Y3        REAL
C     ECPT(24) = Z3                                    Z3        REAL
C     ECPT(25) = ELEMENT TEMPERATURE                   ELTEMP    REAL
C
      LOGICAL          NOGO
      INTEGER          NECPT(26)
      REAL             ECPT(1),MBARAA,MAR,MRR,J2X2
      DIMENSION        D(9),G(9),G2X2(4),J2X2(4),S(18),HYQ(6),SIIJ(7,7),
     1                 MBARAA(9),MAR(18),MRR(36)
      COMMON /EMGPRM/  DUM(15),ISMB(3),IPREC,NOGO
      COMMON /MATIN /  MATID,INFLAG,ELTEMP,STRESS,SINTH,COSTH
      COMMON /MATOUT/  G11,G12,G13,G22,G23,G33,RHO,ALPHA1,ALPHA2,ALP12,
     1                 T SUB 0,G SUB E,SIGTEN,SIGCOM,SIGSHE,
     2                 G2X211,G2X212,G2X222,SPACE(2)
      COMMON /EMGEST/  IELID,NGRID(3),ANGLE,MATID1,EYE,MATID2,T2,FMU,
     1                 Z11,Z22,DUMMY1,X1,Y1,Z1,DUMMY2,X2,Y2,Z2,DUMMY3,
     2                 X3,Y3,Z3,DUMB(76)
      COMMON /EMGTRX/  A(225),PROD9(9),TEMP9(9),XSUBB,XSUBC,YSUBC,
     1                 BFACT,E(18),AOUT(324)
      EQUIVALENCE      (IELID,ECPT(1),NECPT(1)),(J2X2(1),A(14)),
     1                 (D(1),G(1),A(1),SIIJ(1,1)),(G2X2(1),A(10)),
     2                 (HYQ(1),A(50)),(MBARAA(1),A(136)),
     3                 (MAR(1),A(145)),(MRR(1),A(163)),(S(1),A(82))
C
C     SETTING UP G MATRIX
C     BEFORE THIS SUBROUTINE CAN FUNCTION SEVERAL TERMS MUST BE DEFINED
C     SEE ETRBKD.
C
C     POSSIBLE ERROR SOURCE FIX.  MAY REQUIRE LOADER CHANGE.
C     IF (ISMB(1) .EQ. 0)  CALL ETRBKD (1)
C
      INFLAG = 2
      MATID  = MATID1
      CALL MAT (ECPT(1))
C
C     FILL G-MATRIX WITH OUTPUT FROM MAT ROUTINE
C
      G(1) = G11
      G(2) = G12
      G(3) = G13
      G(4) = G12
      G(5) = G22
      G(6) = G23
      G(7) = G13
      G(8) = G23
      G(9) = G33
C
      DO 350 I = 1,9
  350 D(I) = G(I)*DBLE(EYE)
C
C     F1LL  (HBAR) MATRIX STORING AT A(100). . .A(135)
C
      XCSQ = XSUBC**2
      YCSQ = YSUBC**2
      XBSQ = XSUBB**2
      XCYC = XSUBC*YSUBC
C
      DO 380 I = 100,135
  380 A(I) = 0.
C
      A(100) = XBSQ
      A(103) = XBSQ*XSUBB
      A(107) = XSUBB
      A(112) =-2.*XSUBB
      A(115) =-3.*XBSQ
      A(118) = XCSQ
      A(119) = XCYC
      A(120) = YCSQ
      A(121) = XCSQ*XSUBC
      A(122) = YCSQ*XSUBC
      A(123) = YCSQ*YSUBC
      A(125) = XSUBC
      A(126) = YSUBC*2.0
      A(128) = XCYC *2.0
      A(129) = YCSQ *3.0
      A(130) =-2.0*XSUBC
      A(131) =-YSUBC
      A(133) =-3.0*XCSQ
      A(134) =-YCSQ
C
      IF (T2 .EQ. 0.) GO TO 410
C
C     ALL OF THE FOLLOWING OPERATIONS THROUGH STATEMENT LABEL 110
C     ARE NECESSARY IF T2 IS NON-ZERO.
C
C     GET THE G2X2 MATRIX
C
      MATID  = MATID2
      INFLAG = 3
      CALL MAT (ECPT(1))
      IF (G2X211.EQ.0.0 .AND. G2X212.EQ.0.0 .AND. G2X222.EQ.0.0)
     1    GO TO 410
C
      G2X2(1) = DBLE(G2X211)*DBLE(T2)
      G2X2(2) = DBLE(G2X212)*DBLE(T2)
      G2X2(4) = DBLE(G2X222)*DBLE(T2)
C
      DETERM  = G2X2(1)*G2X2(4) - G2X2(3)*G2X2(2)
      J2X2(1) = G2X2(4)/DETERM
      J2X2(2) =-G2X2(2)/DETERM
      J2X2(3) = J2X2(2)
      J2X2(4) = G2X2(1)/DETERM
C
C     (H  ) IS PARTITIONED INTO A LEFT AND RIGHT PORTION AND ONLY THE
C       YQ  RIGHT PORTION IS COMPUTED AND USED AS A  (2X3). THE LEFT
C           2X3 PORTION IS NULL.  THE RIGHT PORTION WILL BE STORED AT
C           A(50)...A(55) UNTIL NOT NEEDED ANY FURTHER.
C
      TEMP   =  2.*D(2) + 4.*D(9)
      HYQ(1) = -6.*(J2X2(1)*D(1) + J2X2(2)*D(3))
      HYQ(2) = -J2X2(1)*TEMP -  6.*J2X2(2)*D(6)
      HYQ(3) = -6.*(J2X2(1)*D(6) + J2X2(2)*D(5))
      HYQ(4) = -6.*(J2X2(2)*D(1) + J2X2(4)*D(3))
      HYQ(5) = -J2X2(2)*TEMP  - 6.*J2X2(4)*D(6)
      HYQ(6) = -6.*(J2X2(2)*D(6) + J2X2(4)*D(5))
C
C     ADD TO 6 OF THE (HBAR) ELEMENTS THE RESULT OF (H  )(H  )
C                                                    UY   YQ
C     THE PRODUCT IS FORMED DIRECTLY IN THE ADDITION PROCESS BELOW.
C     NO (H  ) MATRIX IS ACTUALLY COMPUTED DIRECTLY.
C          UY
C
C     THE FOLLOWING IS THEN STEP 6 PAGE 8, FMMS-66
C
      DO 400 I = 1,3
      A(I+102) = A(I+102) + XSUBB*HYQ(I)
  400 A(I+120) = A(I+120) + XSUBC*HYQ(I) + YSUBC*HYQ(I+3)
C
C     THIS ENDS ADDED COMPUTATION FOR CASE OF T2 NOT ZERO
C
  410 CONTINUE
C
C     AT THIS POINT INVERT  (H) WHICH IS STORED AT A(100). . .A(135)
C     STORE INVERSE BACK IN A(100). . A(135)
C     NO NEED TO COMPUTE DETERMINANT SINCE IT IS NOT USED SUBSEQUENTLY.
C
      ISING = -1
      CALL INVERS (6,A(100),6, A(136),0,DETERM,ISING,A(142))
C
C     CHECK TO SEE IF H WAS SINGULAR
C
      IF (ISING .EQ. 2) GO TO 600
C
C     ISING = 2 IMPLIES SINGULAR MATRIX THUS ERROR CONDITION.
C
C     CHUNK OUT INTEGRAL VALUES I   USED IN REFERENCED M MATRICES
C                                IJ                    SEE P.9, FMMS-66
C
C     THE CALCULATION FOR  (I  ) ARE AS FOLLOWS
C                            IJ
C                                                           ***
C         A1  = XSUBB * YSUBC**(J+1) / ((J+1)*(J+2))           *
C           0J                                                 *
C                                                              *
C         B   = XSUBC * YSUBC**(J+1) / (J+2)                   *
C           0J                                                 ** J=0,6
C                                                              *
C         A   = A1   + B                                       *
C           0J    0J    0J                                     *
C                                                              *
C         I   = MU * A1                                        *
C           0J         0J                                   ***
C
C                                                           ***
C         A1  = I * XSUBB * A      /(I+J+2)                    *
C           IJ               I-1,J                             *
C                                                              *
C         B   = XSUBC**(I+1) * YSUBC**(J+1) /((I+1)*(I+J+2))   *  I=1,6
C           IJ                                                 ** J=0,6
C                                                              *
C         A   = A1   + B                                       *
C           IJ    IJ    IJ                                     *
C                                                              *
C         I     MU * A1                                        *
C           IJ=        IJ                                      *
C                                                           ***
C      NOTE.. LOOPS FOR PROGRAM BEGIN AT 1 INSTEAD OF 0
C                                      I.E.  I = 1,7
C                                            J = 1,7
C
      DO 440 J = 1,7
      YPRODJ = YSUBC**J
      FJ  = J
      FJ2 = J + 1
      AIJ = XSUBB*YPRODJ/(FJ*FJ2)
      BIJ = XSUBC*YPRODJ/FJ2
      SIIJ(1,J) = FMU*AIJ
      AIJ = AIJ + BIJ
      IF (J .EQ. 7) GO TO 440
      K   = 8 - J
      DO 430 I = 2,K
      XPRODI = XSUBC**I
      FI  = I
      FIJ = I + J
      AIJ = (FI-1.)*XSUBB*AIJ/FIJ
      BIJ = XPRODI*YPRODJ/(FI*FIJ)
      SIIJ(I,J) = FMU*AIJ
  430 AIJ = AIJ + BIJ
C
  440 CONTINUE
      SIZERO = SIIJ(1,1)/3.
C
C     CHUNK IN NUMBERS FOR (M-BAR-AA) 3X3 MATRIX AS PER MS-48, PP. 6-10
C
C                    (M  )         3X6 MATRIX
C                      AR
C
C                    (M  )         6X6 MATRIX
C                      RR
C
C     (M-BAR-AA) MATRIX
C
      MBARAA(1) =  SIIJ(1,1)
      MBARAA(2) =  SIIJ(1,2)
      MBARAA(3) = -SIIJ(2,1)
      MBARAA(4) =  SIIJ(1,2)
      MBARAA(5) =  SIIJ(1,3)
      MBARAA(6) = -SIIJ(2,2)
      MBARAA(7) = -SIIJ(2,1)
      MBARAA(8) = -SIIJ(2,2)
      MBARAA(9) =  SIIJ(3,1)
C
C     (M  ) MATRIX
C       AR
C
      MAR( 1) = SIIJ(3,1)
      MAR( 2) = SIIJ(2,2)
      MAR( 3) = SIIJ(1,3)
      MAR( 4) = SIIJ(4,1)
      MAR( 5) = SIIJ(2,3)
      MAR( 6) = SIIJ(1,4)
      MAR( 7) = SIIJ(3,2)
      MAR( 8) = SIIJ(2,3)
      MAR( 9) = SIIJ(1,4)
      MAR(10) = SIIJ(4,2)
      MAR(11) = SIIJ(2,4)
      MAR(12) = SIIJ(1,5)
      MAR(13) =-SIIJ(4,1)
      MAR(14) =-SIIJ(3,2)
      MAR(15) =-SIIJ(2,3)
      MAR(16) =-SIIJ(5,1)
      MAR(17) =-SIIJ(3,3)
      MAR(18) =-SIIJ(2,4)
C
C     (M  ) MATRIX  A 6X6 SYMMETRIC MATRIX
C       RR
C
      MRR( 1) = SIIJ(5,1)
      MRR( 2) = SIIJ(4,2)
      MRR( 3) = SIIJ(3,3)
      MRR( 4) = SIIJ(6,1)
      MRR( 5) = SIIJ(4,3)
      MRR( 6) = SIIJ(3,4)
      MRR( 7) = MRR(2)
      MRR( 8) = SIIJ(3,3)
      MRR( 9) = SIIJ(2,4)
      MRR(10) = SIIJ(5,2)
      MRR(11) = SIIJ(3,4)
      MRR(12) = SIIJ(2,5)
      MRR(13) = MRR(3)
      MRR(14) = MRR(9)
      MRR(15) = SIIJ(1,5)
      MRR(16) = SIIJ(4,3)
      MRR(17) = SIIJ(2,5)
      MRR(18) = SIIJ(1,6)
      MRR(19) = MRR( 4)
      MRR(20) = MRR(10)
      MRR(21) = MRR(16)
      MRR(22) = SIIJ(7,1)
      MRR(23) = SIIJ(5,3)
      MRR(24) = SIIJ(4,4)
      MRR(25) = MRR( 5)
      MRR(26) = MRR(11)
      MRR(27) = MRR(17)
      MRR(28) = MRR(23)
      MRR(29) = SIIJ(3,5)
      MRR(30) = SIIJ(2,6)
      MRR(31) = MRR( 6)
      MRR(32) = MRR(12)
      MRR(33) = MRR(18)
      MRR(34) = MRR(24)
      MRR(35) = MRR(30)
      MRR(36) = SIIJ(1,7)
C
      IF (T2 .EQ. 0.) GO TO 445
C
      MAR( 4) = MAR( 4) + HYQ(1)*SIIJ(2,1) + HYQ(4)*SIIJ(1,2)
      MAR( 5) = MAR( 5) + HYQ(2)*SIIJ(2,1) + HYQ(5)*SIIJ(1,2)
      MAR( 6) = MAR( 6) + HYQ(3)*SIIJ(2,1) + HYQ(6)*SIIJ(1,2)
      MAR(10) = MAR(10) + HYQ(1)*SIIJ(2,2) + HYQ(4)*SIIJ(1,3)
      MAR(11) = MAR(11) + HYQ(2)*SIIJ(2,2) + HYQ(5)*SIIJ(1,3)
      MAR(12) = MAR(12) + HYQ(3)*SIIJ(2,2) + HYQ(6)*SIIJ(1,3)
      MAR(16) = MAR(16) - HYQ(1)*SIIJ(3,1) - HYQ(4)*SIIJ(2,2)
      MAR(17) = MAR(17) - HYQ(2)*SIIJ(3,1) - HYQ(5)*SIIJ(2,2)
      MAR(18) = MAR(18) - HYQ(3)*SIIJ(3,1) - HYQ(6)*SIIJ(2,2)
      MRR( 4) = MRR( 4) + HYQ(1)*SIIJ(4,1) + HYQ(4)*SIIJ(3,2)
      MRR( 5) = MRR( 5) + HYQ(2)*SIIJ(4,1) + HYQ(5)*SIIJ(3,2)
      MRR( 6) = MRR( 6) + HYQ(3)*SIIJ(4,1) + HYQ(6)*SIIJ(3,2)
      MRR(10) = MRR(10) + HYQ(1)*SIIJ(3,2) + HYQ(4)*SIIJ(2,3)
      MRR(11) = MRR(11) + HYQ(2)*SIIJ(3,2) + HYQ(5)*SIIJ(2,3)
      MRR(12) = MRR(12) + HYQ(3)*SIIJ(3,2) + HYQ(6)*SIIJ(2,3)
      MRR(16) = MRR(16) + HYQ(1)*SIIJ(2,3) + HYQ(4)*SIIJ(1,4)
      MRR(17) = MRR(17) + HYQ(2)*SIIJ(2,3) + HYQ(5)*SIIJ(1,4)
      MRR(18) = MRR(18) + HYQ(3)*SIIJ(2,3) + HYQ(6)*SIIJ(1,4)
      MRR(19) = MRR( 4)
      MRR(20) = MRR(10)
      MRR(21) = MRR(16)
      MRR(22) = MRR(22) + HYQ(1)*(HYQ(1)*SIIJ(3,1) + 2.0*(SIIJ(5,1) +
     1          HYQ(4)*SIIJ(2,2))) + HYQ(4)*(2.0*SIIJ(4,2) +
     2          HYQ(4)*SIIJ(1,3))
      MRR(23) = MRR(23) + HYQ(2)*SIIJ(5,1) + HYQ(5)*SIIJ(4,2) +
     1          HYQ(1)*(SIIJ(3,3) + HYQ(2)*SIIJ(3,1) + HYQ(5)*SIIJ(2,2))
     2        + HYQ(4)*(SIIJ(2,4) + HYQ(2)*SIIJ(2,2) + HYQ(5)*SIIJ(1,3))
      MRR(24) = MRR(24) + HYQ(3)*SIIJ(5,1) + HYQ(6)*SIIJ(4,2) +
     1          HYQ(1)*(SIIJ(2,4) + HYQ(3)*SIIJ(3,1) + HYQ(6)*SIIJ(2,2))
     2        + HYQ(4)*(SIIJ(1,5) + HYQ(3)*SIIJ(2,2) + HYQ(6)*SIIJ(1,3))
      MRR(25) = MRR( 5)
      MRR(26) = MRR(11)
      MRR(27) = MRR(17)
      MRR(28) = MRR(23)
      MRR(29) = MRR(29) + HYQ(2)*(HYQ(2)*SIIJ(3,1) + 2.0*(SIIJ(3,3) +
     1          HYQ(5)*SIIJ(2,2))) + HYQ(5)*(2.0*SIIJ(2,4) +
     2          HYQ(5)*SIIJ(1,3))
      MRR(30) = MRR(30) + HYQ(3)*SIIJ(3,3) + HYQ(6)*SIIJ(2,4) +
     1          HYQ(2)*(SIIJ(2,4) + HYQ(3)*SIIJ(3,1) + HYQ(6)*SIIJ(2,2))
     2        + HYQ(5)*(SIIJ(1,5) + HYQ(3)*SIIJ(2,2) + HYQ(6)*SIIJ(1,3))
      MRR(31) = MRR( 6)
      MRR(32) = MRR(12)
      MRR(33) = MRR(18)
      MRR(34) = MRR(24)
      MRR(35) = MRR(30)
      MRR(36) = MRR(36) + HYQ(3)*(HYQ(3)*SIIJ(3,1) + 2.0*(SIIJ(2,4) +
     1          HYQ(6)*SIIJ(2,2))) + HYQ(6)*(2.0*SIIJ(1,5) +
     2          HYQ(6)*SIIJ(1,3))
C
C     FILL S-MATRIX EQUIVALENCED TO A(82)  (S IS  6X3 )
C
  445 S( 1) = 1.
      S( 2) = 0.
      S( 3) =-XSUBB
      S( 4) = 0.
      S( 5) = 1.
      S( 6) = 0.
      S( 7) = 0.
      S( 8) = 0.
      S( 9) = 1.
      S(10) = 1.
      S(11) = YSUBC
      S(12) =-XSUBC
      S(13) = 0.
      S(14) = 1.
      S(15) = 0.
      S(16) = 0.
      S(17) = 0.
      S(18) = 1.
C
C     CAN NOW COMPUTE 9 (3X3) MASS MATRICES (FMMS-66, PAGES 10-11)
C
C                -1 T           -1
C     ( M ) = ( H  )  ( M  ) ( H  )
C                        RR
C
C              PARTITION (M)
C                                           ///       ///
C                                           /     *     /
C                                           / MBB * MBC /
C                                           /     *     /
C                                ( M )  =   / ********* /
C                                           /     *     /
C                                           / MCB * MCC /
C                                           /     *     /
C                                           ///       ///
C                                                       4 (3X3) MATRICES
C                        -1
C     ( M  ) = ( M  ) ( H  )
C        AI       AR
C
C              PARTITION (M  )              ///                 ///
C                          AI               /          *          /
C                               ( M  )  =   / M-BAR-AB * M-BAR-AC /
C                                  AI       /          *          /
C                                           ///                 ///
C                                                       2 (3X3) MATRICES
C                               T            T
C     ( MAB )  = (M-BAR-AB) - (S ) (MBB) - (S ) (MCB)
C                               B            C
C
C                               T            T
C     ( MAC )  = (M-BAR-AC) - (S ) (MBC) - (S ) (MCC)
C                               B            C
C
C                               T     T      T      T
C     ( MAA )  = (M-BAR-AA) - (S ) (M  ) - (S ) (MAC )
C                               B    AB      C
C
C                           - (M-BAR-AB) (S ) - (M-BAR-AC) (S )
C                                          B                 C
C
C                    T
C     ( MBA )  = (MAB )
C
C                    T
C     ( MCA )  = (MAC )
C
C     CHOOSE APPROPRIATE BLOCK OF A-ARRAY FOR STORAGE
C
C     (3X3)    STORED IN      (3X3)     STORED IN     (3X3)    STORED IN
C     (MAA)   A( 1... 9)      (MAB)   A(10)...8)      (MAC)   A(19...27)
C     (MBA)   A(28...36)      (MBB)   A(37)...45)     (MBC)   A(46...54)
C     (MCA)   A(55...63)      (MCB)   A(64...72)      (MCC)   A(73...81)
C
C       -1
C     (H  ) IS STORED AT A(100...135)
C     (S)   EQUIVALENCED A( 81... 99)
C     WORKING STORAGE IS A(181...216)
C     (M-BAR-AB) STORED UNTIL NO LONGER NEEDED IN A(163...171)
C     (M-BAR-AC) STORED UNTIL NO LONGER NEEDED IN A(172...180)
C
C                     -1 T          -1
C     COMPUTE (M) = (H  )  ((M  ) (H  ))
C                       RR
C
      CALL GMMATS (MRR(1), 6,6,0, A(100), 6,6,0, A(37))
      CALL GMMATS (A(100), 6,6,1, A(37),  6,6,0, A(1))
C
C     CREATE PARTITION OF 4 (3X3)
C
      DO 470 I = 1,3
      A(I+36) = A(I   )
      A(I+39) = A(I+ 6)
      A(I+42) = A(I+12)
C
      A(I+45) = A(I+ 3)
      A(I+48) = A(I+ 9)
      A(I+51) = A(I+15)
C
      A(I+63) = A(I+18)
      A(I+66) = A(I+24)
      A(I+69) = A(I+30)
C
      A(I+72) = A(I+21)
      A(I+75) = A(I+27)
  470 A(I+78) = A(I+33)
C
C     COMPUTE             -1
C         (M  ) = (M  ) (H  )  AND  PARTITION INTO 2 (3X3)  (M-BAR-AB)
C           AI      AR                                  AND (M-BAR-AC)
C
      CALL GMMATS (MAR(1), 3,6,0, A(100), 6,6,0, A(181))
      DO 480 I = 1,3
      A(I+162) = A(I+180)
      A(I+165) = A(I+186)
      A(I+168) = A(I+192)
C
      A(I+171) = A(I+183)
      A(I+174) = A(I+189)
  480 A(I+177) = A(I+195)
C
C     COMPUTE (MAB)
C
      CALL GMMATS (S(1), 3,3,1, A(37), 3,3,0,  A(181))
      CALL GMMATS (S(10), 3,3,1, A(64), 3,3,0, A(190))
      DO 490 I = 1,9
  490 A(I+9) = A(I+162) - A(I+180) - A(I+189)
C
C     COMPUTE (MAC)
C
      CALL GMMATS (S(1) , 3,3,1, A(46), 3,3,0, A(181))
      CALL GMMATS (S(10), 3,3,1, A(73), 3,3,0, A(190))
      DO 500 I = 1,9
  500 A(I+18) = A(I+171) - A(I+180) - A(I+189)
C
C     COMPUTE (MAA)
C
      CALL GMMATS (S(1) , 3,3,1, A(10), 3,3,1, A(181))
      CALL GMMATS (S(10), 3,3,1, A(19), 3,3,1, A(190))
      CALL GMMATS (A(163),3,3,0, S(1) , 3,3,0, A(199))
      CALL GMMATS (A(172),3,3,0, S(10), 3,3,0, A(208))
      DO 510 I = 1,9
  510 A(I) = MBARAA(I) - A(I+180) - A(I+189) - A(I+198) - A(I+207)
C
C     COMPUTE (MBA) AND (MCA)
C
      DO 520 I = 1,3
      NPT = 3*I + 7
      A(I+27) = A(NPT  )
      A(I+30) = A(NPT+1)
      A(I+33) = A(NPT+2)
C
      A(I+54) = A(NPT+ 9)
      A(I+57) = A(NPT+10)
  520 A(I+60) = A(NPT+11)
C
      DO 550 I = 1,136
  550 AOUT(I) = A(I)
      RETURN
C
C     ERROR EXITS
C
  600 CALL MESAGE (30,33,ECPT(1))
      NOGO = .TRUE.
      RETURN
      END


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_GLTR_test_deck
   USE GALAHAD_GLTR_DOUBLE                            ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: working = KIND( 1.0D+0 ) ! set precision
   REAL ( KIND = working ), PARAMETER :: one = 1.0_working, two = 2.0_working
   INTEGER, PARAMETER :: n = 100                  ! problem dimension
   INTEGER :: i, nn, pass
   REAL ( KIND = working ) :: f, radius
   REAL ( KIND = working ), DIMENSION( n ) :: X, R, VECTOR, H_vector
   REAL ( KIND = working ), DIMENSION( 0 ) :: X0, R0, VECTOR0
   TYPE ( GLTR_data_type ) :: data
   TYPE ( GLTR_control_type ) :: control
   TYPE ( GLTR_info_type ) :: info

!  ==============
!  Normal entries
!  ==============

   WRITE( 6, "( /, ' ==== normal exits ====== ', / )" )

! Initialize control parameters

   OPEN( UNIT = 23, STATUS = 'SCRATCH' )
!  OPEN( UNIT = 23 )
   DO pass = 1, 11
      IF ( pass /= 4 .AND. pass /= 7 .AND. pass /= 8 )                         &
           CALL GLTR_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      info%status = 1
      radius = one
      IF ( pass == 2 ) control%unitm = .FALSE. ; radius = 1000.0_working
      IF ( pass == 4 ) THEN
           radius = radius / two ; info%status = 4
      END IF
      IF ( pass == 5 ) radius = 0.0001_working
      IF ( pass == 7 ) THEN
         radius = 0.1_working ; control%boundary = .TRUE. ; info%status = 4
      END IF
      IF ( pass == 8 ) THEN
         radius = 100.0_working ; info%status = 4
      END IF
      IF ( pass == 9 ) radius = 10.0_working
      IF ( pass == 10 ) radius = 10.0_working
      IF ( pass == 11 ) radius = 10000.0_working

      IF ( pass == 10 .OR. pass == 11 ) THEN
         R( : n - 1 ) = 0.000000000001_working ; R( n ) = one
      ELSE
         R = one
      END IF

!  Iteration to find the minimizer

      DO
         CALL GLTR_solve( n, radius, f, X, R, VECTOR, data, control, info )

! Branch as a result of info%status

         SELECT CASE( info%status )

!  Form the preconditioned gradient

         CASE( 2, 6 )
            VECTOR = VECTOR / two

!  Form the matrix-vector product

         CASE ( 3, 7 )
            IF ( pass == 2 .OR. pass == 6 .OR. pass == 7 .OR. pass == 8 ) THEN
               H_vector( 1 ) =  two * VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) + two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) + two * VECTOR( n )
            ELSE IF ( pass == 9 ) THEN
               H_vector( 1 ) = VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) + VECTOR( n )
            ELSE IF ( pass == 10 .OR. pass == 11 ) THEN
              H_vector( 1 ) = - two * VECTOR( 1 )
              H_vector( 2 : n - 1 ) = 0.0001_working * VECTOR( 2 : n - 1 )
              H_vector( n ) = - VECTOR( n )
            ELSE
               H_vector( 1 ) = - two * VECTOR( 1 ) + VECTOR( 2 )
               DO i = 2, n - 1
                 H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                                 VECTOR( i + 1 )
               END DO
               H_vector( n ) = VECTOR( n - 1 ) - two * VECTOR( n )
            END IF
            VECTOR = H_vector

!  Restart

         CASE ( 5 )
            IF ( pass == 10 .OR. pass == 11 ) THEN
               R( : n - 1 ) = 0.000000000001_working
               R( n ) = one
            ELSE
               R = one
            END IF

!  Successful return

         CASE ( - 2 : 0 )
            EXIT

!  Error returns

         CASE DEFAULT
            EXIT
         END SELECT
      END DO

      WRITE( 6, "( ' pass ', I3, ' GLTR_solve exit status = ', I6 )" )         &
             pass, info%status
!     WRITE( 6, "( ' its, solution and Lagrange multiplier = ', I6, 2ES12.4 )")&
!               info%iter + info%iter_pass2, f, info%multiplier
      IF ( pass /= 3 .AND. pass /= 6 .AND. pass /= 7 )                         &
        CALL GLTR_terminate( data, control, info ) !  delete internal workspace
   END DO

!  =============
!  Error entries
!  =============

   WRITE( 6, "( /, ' ==== error exits ====== ', / )" )

! Initialize control parameters

   DO pass = 1, 5
      radius = one
      CALL GLTR_initialize( data, control )
      control%error = 23 ; control%out = 23 ; control%print_level = 10
      info%status = 1
      nn = n
      IF ( pass == 1 ) control%steihaug_toint = .TRUE.
      IF ( pass == 2 ) control%itmax = 0
      IF ( pass == 3 ) control%unitm = .FALSE.
      IF ( pass == 4 ) nn = 0
      IF ( pass == 5 ) radius = - one

      R = one

!  Iteration to find the minimizer

      DO
         IF ( pass /= 4 ) THEN
           CALL GLTR_solve( nn, radius, f, X( : nn ), R( : nn ),                &
                            VECTOR( : nn ), data, control, info )
         ELSE
           CALL GLTR_solve( nn, radius, f, X0, R0,                              &
                            VECTOR0, data, control, info )
         END IF

! Branch as a result of info%status

         SELECT CASE( info%status )

!  Form the preconditioned gradient

         CASE( 2, 6 )
            IF ( pass /= 3 ) THEN
               VECTOR = VECTOR / two
            ELSE
               VECTOR = - VECTOR / two
            END IF

!  Form the matrix-vector product

         CASE ( 3, 7 )
            H_vector( 1 ) = - two * VECTOR( 1 ) + VECTOR( 2 )
            DO i = 2, n - 1
              H_vector( i ) = VECTOR( i - 1 ) - two * VECTOR( i ) +         &
                              VECTOR( i + 1 )
            END DO
            H_vector( n ) = VECTOR( n - 1 ) - two * VECTOR( n )
            VECTOR = H_vector

!  Restart

         CASE ( 5 )
            R = one

!  Successful return

         CASE ( - 2 : 0 )
            EXIT

!  Error returns

         CASE DEFAULT
            EXIT
         END SELECT
      END DO

      WRITE( 6, "( ' pass ', I3, ' GLTR_solve exit status = ', I6 )" )         &
             pass, info%status
      CALL GLTR_terminate( data, control, info ) !  delete internal workspace
   END DO
   CLOSE( unit = 23 )

!  STOP
   END PROGRAM GALAHAD_GLTR_test_deck


module fcn_ysquared
    use mod_kinds,      only: rk,ik
    use type_function,  only: function_t
    use type_point,     only: point_t
    use type_point_ad,  only: point_ad_t
    use DNAD_D
    implicit none
    private

    !> y-squared function.
    !!
    !!  \f$     f(t,\vec{x}) = y^2      \f$
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/1/2016
    !!
    !!
    !------------------------------------------------------------------------------------
    type, extends(function_t), public :: ysquared_f

    contains

        procedure   :: init
        procedure   :: compute

    end type ysquared_f
    !************************************************************************************

contains

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

        !
        ! Set function name
        !
        call self%set_name("y_squared")

        !
        ! Set function options to default settings
        !

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

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

        type(AD_D)                        :: val

        ! f(x) = y**2
        val = coord%c2_  *  coord%c2_

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

end module fcn_ysquared


SUBROUTINE sub_args(x, y, sub, result)
IMPLICIT NONE
  EXTERNAL :: sub
  REAL, INTENT(IN) :: x, y
  REAL, INTENT(OUT) :: result
  CALL sub(x, y, result)
END SUBROUTINE sub_args

PROGRAM test_sub_args
IMPLICIT NONE
  EXTERNAL :: sum, prod
  REAL :: x, y, result

  WRITE(*, *) "Enter x:"
  READ(*, *) x
  WRITE(*, *) "Enter y:"
  READ(*, *) y

  CALL sub_args(x, y, prod, result)
  WRITE(*, *) "The product is ", result
  CALL sub_args(x, y, sum, result)
  WRITE(*, *) "The sum is ", result
END PROGRAM test_sub_args

SUBROUTINE prod(x, y, result)
IMPLICIT NONE
  REAL, INTENT(IN) :: x, y
  REAL, INTENT(OUT) :: result
  result = x * y
END SUBROUTINE prod

SUBROUTINE sum(x, y, result)
IMPLICIT NONE
  REAL, INTENT(IN) :: x, y
  REAL, INTENT(OUT) :: result
  result = x + y
END SUBROUTINE sum


module mod_utility
  use mod_prec
  implicit none

  private

  public :: maybe_deallocate, not_all_allocated

  public :: maxabs, z_maxabs, d_maxabs, z_maxabs_v, d_maxabs_v, &
       norm2, z_norm2_v, d_norm2_v, &
       normf, z_normf, d_normf

  public :: print_matrix, d_print_matrix, z_print_matrix, i_print_matrix

  public :: random_matrix_to, d_random_matrix_to, d_v_random_matrix_to, d_s_random_matrix_to, &
       z_random_matrix_to, z_v_random_matrix_to, z_s_random_matrix_to, &
       d_random_matrix, d_random_vector, z_random_matrix, z_random_vector

  public :: ip_transpose, d_ip_transpose, z_ip_transpose

  public :: equals_option, i_equals_option, d_equals_option, z_equals_option

  public :: dot_no_conjg

  public :: first_zero_diagonal, z_first_zero_diagonal, d_first_zero_diagonal, &
       reverse_first_zero_diagonal, z_reverse_first_zero_diagonal, d_reverse_first_zero_diagonal

  public :: first_zero, z_first_zero, d_first_zero, &
       reverse_first_zero, z_reverse_first_zero, d_reverse_first_zero

  interface maybe_deallocate
     module procedure d_maybe_deallocate2, z_maybe_deallocate2, i_maybe_deallocate2, &
          d_maybe_deallocate1, z_maybe_deallocate1, i_maybe_deallocate1
  end interface maybe_deallocate

  interface not_all_allocated
     module procedure d_not_all_allocated2, z_not_all_allocated2, &
          i_not_all_allocated2, &
          d_not_all_allocated1, z_not_all_allocated1, i_not_all_allocated1
  end interface not_all_allocated

  interface maxabs
     module procedure z_maxabs, d_maxabs, z_maxabs_v, d_maxabs_v
  end interface maxabs

  interface norm2
     module procedure z_norm2_v, d_norm2_v
  end interface norm2

  interface normf
     module procedure z_normf, d_normf
  end interface normf

  interface print_matrix
     module procedure d_print_matrix, z_print_matrix, i_print_matrix
  end interface print_matrix

  interface random_matrix_to
     module procedure d_random_matrix_to, d_v_random_matrix_to, d_s_random_matrix_to, &
          z_random_matrix_to, z_v_random_matrix_to, z_s_random_matrix_to
  end interface random_matrix_to

  interface ip_transpose
     module procedure d_ip_transpose, z_ip_transpose
  end interface ip_transpose

  interface equals_option
     module procedure i_equals_option, d_equals_option, z_equals_option
  end interface equals_option

  interface first_zero_diagonal
     module procedure z_first_zero_diagonal, d_first_zero_diagonal
  end interface first_zero_diagonal

  interface reverse_first_zero_diagonal
     module procedure z_reverse_first_zero_diagonal, d_reverse_first_zero_diagonal
  end interface reverse_first_zero_diagonal

  interface first_zero
     module procedure z_first_zero, d_first_zero
  end interface first_zero

  interface reverse_first_zero
     module procedure z_reverse_first_zero, d_reverse_first_zero
  end interface reverse_first_zero

  real(kind=dp), parameter :: d_random_shift=-1.0_dp, d_random_scale=2.0_dp
  complex(kind=dp), parameter :: z_random_shift=(-1.0_dp,-1.0_dp), z_random_scale=(2.0_dp,0.0_dp)

contains

  logical function d_not_all_allocated2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    real(kind=dp), dimension(:,:), allocatable :: a1
    real(kind=dp), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function d_not_all_allocated2

  logical function z_not_all_allocated2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    complex(kind=dp), dimension(:,:), allocatable :: a1
    complex(kind=dp), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function z_not_all_allocated2

  logical function i_not_all_allocated2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    integer(kind=int32), dimension(:,:), allocatable :: a1
    integer(kind=int32), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function i_not_all_allocated2

  logical function d_not_all_allocated1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    real(kind=dp), dimension(:), allocatable :: a1
    real(kind=dp), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function d_not_all_allocated1

  logical function z_not_all_allocated1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    complex(kind=dp), dimension(:), allocatable :: a1
    complex(kind=dp), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function z_not_all_allocated1

  logical function i_not_all_allocated1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) result(x)
    integer(kind=int32), dimension(:), allocatable :: a1
    integer(kind=int32), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    x=.false.
    if (.not. allocated(a1)) goto 1
    if (.not. present(a2)) return
    if (.not. allocated(a2)) goto 1
    if (.not. present(a3)) return
    if (.not. allocated(a3)) goto 1
    if (.not. present(a4)) return
    if (.not. allocated(a4)) goto 1
    if (.not. present(a5)) return
    if (.not. allocated(a5)) goto 1
    if (.not. present(a6)) return
    if (.not. allocated(a6)) goto 1
    if (.not. present(a7)) return
    if (.not. allocated(a7)) goto 1
    if (.not. present(a8)) return
    if (.not. allocated(a8)) goto 1
    if (.not. present(a9)) return
    if (.not. allocated(a9)) goto 1
    if (.not. present(a10)) return
    if (allocated(a10)) return
1   x=.true.
  end function i_not_all_allocated1

  subroutine d_maybe_deallocate2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    real(kind=dp), dimension(:,:), allocatable :: a1
    real(kind=dp), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine d_maybe_deallocate2

  subroutine z_maybe_deallocate2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    complex(kind=dp), dimension(:,:), allocatable :: a1
    complex(kind=dp), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine z_maybe_deallocate2

  subroutine i_maybe_deallocate2(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    integer(kind=int32), dimension(:,:), allocatable :: a1
    integer(kind=int32), dimension(:,:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine i_maybe_deallocate2

  subroutine d_maybe_deallocate1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    real(kind=dp), dimension(:), allocatable :: a1
    real(kind=dp), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine d_maybe_deallocate1

  subroutine z_maybe_deallocate1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    complex(kind=dp), dimension(:), allocatable :: a1
    complex(kind=dp), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine z_maybe_deallocate1

  subroutine i_maybe_deallocate1(a1,a2,a3,a4,a5,a6,a7,a8,a9,a10)
    integer(kind=int32), dimension(:), allocatable :: a1
    integer(kind=int32), dimension(:), optional, allocatable :: a2, a3, a4, a5, &
         a6, a7, a8, a9, a10
    if (allocated(a1)) deallocate(a1)
    if (.not. present(a2)) go to 1
    if (allocated(a2)) deallocate(a2)
    if (.not. present(a3)) go to 1
    if (allocated(a3)) deallocate(a3)
    if (.not. present(a4)) go to 1
    if (allocated(a4)) deallocate(a4)
    if (.not. present(a5)) go to 1
    if (allocated(a5)) deallocate(a5)
    if (.not. present(a6)) go to 1
    if (allocated(a6)) deallocate(a6)
    if (.not. present(a7)) go to 1
    if (allocated(a7)) deallocate(a7)
    if (.not. present(a8)) go to 1
    if (allocated(a8)) deallocate(a8)
    if (.not. present(a9)) go to 1
    if (allocated(a9)) deallocate(a9)
    if (.not. present(a10)) go to 1
    if (allocated(a10)) deallocate(a10)
1   return
  end subroutine i_maybe_deallocate1

  real(kind=dp) function z_maxabs(a) result(x)
    complex(kind=dp), dimension(:,:), intent(in) :: a
    !
    integer(kind=int32) :: j, k, m, n
    real(kind=dp) :: y
    m=size(a,1)
    n=size(a,2)
    x=0.0_dp
    do j=1,m
       do k=1,n
          y=abs(a(j,k))
          if (y > x .or. y /= y) then
             x=y
          end if
       end do
    end do
  end function z_maxabs

  real(kind=dp) function d_maxabs(a) result(x)
    real(kind=dp), dimension(:,:), intent(in) :: a
    !
    integer(kind=int32) :: j, k, m, n
    real(kind=dp) :: y
    m=size(a,1)
    n=size(a,2)
    x=0.0_dp
    do j=1,m
       do k=1,n
          y=abs(a(j,k))
          if (y > x .or. y /= y) then
             x=y
          end if
       end do
    end do
  end function d_maxabs

  real(kind=dp) function z_maxabs_v(a) result(x)
    complex(kind=dp), dimension(:), intent(in) :: a
    !
    integer(kind=int32) :: j, m
    real(kind=dp) :: y
    m=size(a)
    x=0.0_dp
    do j=1,m
       y=abs(a(j))
       if (y > x .or. y /= y) then
          x=y
       end if
    end do
  end function z_maxabs_v

  real(kind=dp) function d_maxabs_v(a) result(x)
    real(kind=dp), dimension(:), intent(in) :: a
    !
    integer(kind=int32) :: j, m
    real(kind=dp) :: y
    m=size(a)
    x=0.0_dp
    do j=1,m
       y=abs(a(j))
       if (y > x .or. y /= y) then
          x=y
       end if
    end do
  end function d_maxabs_v

  real(kind=dp) function z_norm2_v(a) result(x)
    complex(kind=dp), dimension(:), intent(in) :: a
    !
    integer(kind=int32) :: j, m
    real(kind=dp) :: y
    m=size(a)
    y=z_maxabs_v(a)
    if (y==0.0_dp) then
       x=0.0_dp
       return
    end if
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    x=0.0_dp
    do j=1,m
       x=x+abs(a(j)/y)**2
    end do
    x=sqrt(x)*y
  end function z_norm2_v

  real(kind=dp) function d_norm2_v(a) result(x)
    real(kind=dp), dimension(:), intent(in) :: a
    !
    integer(kind=int32) :: j, m
    real(kind=dp) :: y, tmp
    m=size(a)
    y=d_maxabs_v(a)
    if (y==0.0_dp) then
       x=0.0_dp
       return
    end if
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    x=0.0_dp
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do j=1,m
          tmp=a(j)/y
          x=x+tmp*tmp
       end do
       x=sqrt(x)*y
    else
       do j=1,m
          tmp=a(j)
          x=x+tmp*tmp
       end do
       x=sqrt(x)
    end if
  end function d_norm2_v

  real(kind=dp) function z_normf(a) result(x)
    complex(kind=dp), dimension(:,:), intent(in) :: a
    !
    integer(kind=int32) :: j, k, m, n
    real(kind=dp) :: y, tmp
    m=size(a,1)
    n=size(a,2)
    y=z_maxabs(a)
    if (y==0.0_dp) then
       x=0.0_dp
       return
    end if
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    x=0.0_dp
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do j=1,m
          do k=1,n
             tmp=abs(a(j,k)/y)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)*y
    else
       do j=1,m
          do k=1,n
             tmp=abs(a(j,k))
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function z_normf

  real(kind=dp) function d_normf(a) result(x)
    real(kind=dp), dimension(:,:), intent(in) :: a
    !
    integer(kind=int32) :: j, k, m, n
    real(kind=dp) :: y, tmp
    m=size(a,1)
    n=size(a,2)
    y=d_maxabs(a)
    if (y==0.0_dp) then
       x=0.0_dp
       return
    end if
    y=(2.0_dp)**(floor(log(y)/log(2.0_dp)))
    x=0.0_dp
    if (y > 1e150_dp .or. y < 1e-150_dp) then
       do j=1,m
          do k=1,n
             tmp = a(j,k)/y
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)*y
    else
       do j=1,m
          do k=1,n
             tmp = a(j,k)
             x=x+tmp*tmp
          end do
       end do
       x=sqrt(x)
    end if
  end function d_normf

  subroutine d_print_matrix(a)
    real(kind=dp), dimension(:,:), intent(in) :: a
    integer(kind=int32) :: j,k,m,n
    m=size(a,1)
    n=size(a,2)
    do j=1,m
       do k=1,n
          write(*,'(ES12.4, ",  ")',advance='no') a(j,k)
       end do
       write(*,*)
    end do
  end subroutine d_print_matrix

  subroutine z_print_matrix(a)
    complex(kind=dp), dimension(:,:), intent(in) :: a
    integer(kind=int32) :: j,k,m,n
    m=size(a,1)
    n=size(a,2)
    do j=1,m
       do k=1,n
          !          write(*,'(ES12.4, A, ES11.4,A)',advance='no') real(a(j,k)), ' +i*',aimag(a(j,k)), '   '
          write(*,'(A, ES12.4, A, ES11.4,A)',advance='no') '(', real(a(j,k)), ', ',aimag(a(j,k)), ' )    '
       end do
       write(*,*)
    end do
  end subroutine z_print_matrix

  subroutine i_print_matrix(a)
    integer(kind=int32), dimension(:,:), intent(in) :: a
    integer(kind=int32) :: j,k,m,n
    m=size(a,1)
    n=size(a,2)
    do j=1,m
       do k=1,n
          write(*,'(i4, "  ")',advance='no') a(j,k)
       end do
       write(*,*)
    end do
  end subroutine i_print_matrix

  function d_random_matrix(m,n) result(a)
    real(kind=dp), dimension(m,n) :: a
    integer(kind=int32), intent(in) :: m,n
    call d_random_matrix_to(a)
  end function d_random_matrix

  function d_random_vector(n) result(a)
    real(kind=dp), dimension(n) :: a
    integer(kind=int32), intent(in) :: n
    call d_v_random_matrix_to(a)
  end function d_random_vector

  function z_random_matrix(m,n) result(a)
    complex(kind=dp), dimension(m,n) :: a
    integer(kind=int32), intent(in) :: m,n
    call z_random_matrix_to(a)
  end function z_random_matrix

  function z_random_vector(n) result(a)
    complex(kind=dp), dimension(n) :: a
    integer(kind=int32), intent(in) :: n
    call z_v_random_matrix_to(a)
  end function z_random_vector

  subroutine d_random_matrix_to(a)
    real(kind=dp), dimension(:,:), intent(out) :: a
    call random_number(a)
    a=d_random_scale*a+d_random_shift
  end subroutine d_random_matrix_to

  subroutine d_v_random_matrix_to(a)
    real(kind=dp), dimension(:), intent(out) :: a
    call random_number(a)
    a=d_random_scale*a+d_random_shift
  end subroutine d_v_random_matrix_to

  subroutine d_s_random_matrix_to(a)
    real(kind=dp), intent(out) :: a
    call random_number(a)
    a=d_random_scale*a+d_random_shift
  end subroutine d_s_random_matrix_to

  subroutine z_random_matrix_to(a)
    complex(kind=dp), dimension(:,:), intent(out) :: a
    real(kind=dp) :: x,y
    integer(kind=int32) :: j, k
    do j=1,size(a,1)
       do k=1,size(a,2)
          call random_number(x)
          call random_number(y)
          a(j,k)=z_random_scale*cmplx(x,y,dp)+z_random_shift
       end do
    end do
  end subroutine z_random_matrix_to

  subroutine z_v_random_matrix_to(a)
    complex(kind=dp), dimension(:), intent(out) :: a
    real(kind=dp) :: x,y
    integer(kind=int32) :: j
    do j=1,size(a)
       call random_number(x)
       call random_number(y)
       a(j)= z_random_scale*cmplx(x,y,dp)+z_random_shift
    end do
  end subroutine z_v_random_matrix_to

  subroutine z_s_random_matrix_to(a)
    complex(kind=dp), intent(out) :: a
    real(kind=dp) :: x,y
    call random_number(x)
    call random_number(y)
    a=z_random_scale*cmplx(x,y,dp)+z_random_shift
  end subroutine z_s_random_matrix_to

  integer(kind=int32) function i_equals_option(j,k) result(i)
    integer(kind=int32) :: j
    integer(kind=int32), optional :: k

    if(present(k)) then
       i=k
    else
       i=j
    end if
  end function i_equals_option

  real(kind=dp) function d_equals_option(x,y) result(z)
    real(kind=dp) :: x
    real(kind=dp), optional :: y

    if(present(y)) then
       z=y
    else
       z=x
    end if
  end function d_equals_option

  complex(kind=dp) function z_equals_option(x,y) result(z)
    complex(kind=dp) :: x
    complex(kind=dp), optional :: y

    if(present(y)) then
       z=y
    else
       z=x
    end if
  end function z_equals_option

  subroutine d_ip_transpose(a)
    real(kind=dp), dimension(:,:), intent(inout) :: a
    real(kind=dp) :: tmp
    integer(kind=int32) :: n, j,k
    n=size(a,1)
    do j=2,n
       do k=1,j-1
          tmp=a(j,k)
          a(j,k)=a(k,j)
          a(k,j)=tmp
       end do
    end do
  end subroutine d_ip_transpose

  subroutine z_ip_transpose(a)
    complex(kind=dp), dimension(:,:), intent(inout) :: a
    complex(kind=dp) :: tmp
    integer(kind=int32) :: n, j,k
    n=size(a,1)
    do j=2,n
       do k=1,j-1
          tmp=a(j,k)
          a(j,k)=conjg(a(k,j))
          a(k,j)=conjg(tmp)
       end do
    end do
    do j=1,n
       a(j,j)=conjg(a(j,j))
    end do
  end subroutine z_ip_transpose

  function dot_no_conjg(x,y) result(xy)
    complex(kind=dp), dimension(:), intent(in) :: x, y
    complex(kind=dp) :: xy
    integer(kind=int32) :: j
    xy=(0.0_dp,0.0_dp)
    do j=1,size(x)
       xy=xy+x(j)*y(j)
    end do
  end function dot_no_conjg

  ! finding zeros in a vector

  integer(kind=int32) function d_first_zero(a,tol) result(d)
    real(kind=dp), dimension(:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j
    d=1
    do j=1,size(a)
       if (abs(a(j)) <= tol) return
       d=d+1
    end do
  end function d_first_zero

  integer(kind=int32) function z_first_zero(a,tol) result(d)
    complex(kind=dp), dimension(:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j
    d=1
    do j=1,size(a)
       if (abs(a(j)) <= tol) return
       d=d+1
    end do
  end function z_first_zero

  integer(kind=int32) function d_reverse_first_zero(a,tol) result(d)
    real(kind=dp), dimension(:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j
    d=size(a)
    do j=d,1,-1
       if (abs(a(j)) <= tol) return
       d=d-1
    end do
  end function d_reverse_first_zero

  integer(kind=int32) function z_reverse_first_zero(a,tol) result(d)
    complex(kind=dp), dimension(:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j
    d=size(a)
    do j=d,1,-1
       if (abs(a(j)) <= tol) return
       d=d-1
    end do
  end function z_reverse_first_zero

  ! finding zeros on the diagonal

  integer(kind=int32) function d_first_zero_diagonal(a,tol) result(d)
    real(kind=dp), dimension(:,:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j, n
    n=min(size(a,1), size(a,2))
    d=1
    do j=1,n
       if (abs(a(j,j)) <= tol) return
       d=d+1
    end do
  end function d_first_zero_diagonal

  integer(kind=int32) function z_first_zero_diagonal(a,tol) result(d)
    complex(kind=dp), dimension(:,:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j, n
    n=min(size(a,1), size(a,2))
    d=1
    do j=1,n
       if (abs(a(j,j)) <= tol) return
       d=d+1
    end do
  end function z_first_zero_diagonal

  ! Return the first zero diagonal from the bottom right.
  integer(kind=int32) function d_reverse_first_zero_diagonal(a,tol) result(d)
    real(kind=dp), dimension(:,:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j, n
    n=min(size(a,1), size(a,2))
    d=n
    do j=n,1,-1
       if (abs(a(j,j)) <= tol) return
       d=d-1
    end do
  end function d_reverse_first_zero_diagonal

  integer(kind=int32) function z_reverse_first_zero_diagonal(a,tol) result(d)
    complex(kind=dp), dimension(:,:), intent(in) :: a
    real(kind=dp), intent(in) :: tol
    !
    integer(kind=int32) :: j, n
    n=min(size(a,1), size(a,2))
    d=n
    do j=n,1,-1
       if (abs(a(j,j)) <= tol) return
       d=d-1
    end do
  end function z_reverse_first_zero_diagonal

end module mod_utility


      subroutine qltri4(p2sq,msq,musq,Ival)
      implicit none
      include 'qlconstants.f'
      double precision p2sq,musq,msq,arg2,omarg2,ddilog
      double complex fac,qllnrat,Ival(-2:0),wlog,wlogm,dilog2
      wlog=qllnrat(msq,msq-p2sq)
      wlogm=qllnrat(musq,msq)
      fac=dcmplx(0.5d0/(p2sq-msq))
      arg2=-p2sq/(msq-p2sq)
      omarg2=1d0-arg2

      if (omarg2 .lt. 0d0) then
      dilog2=dcmplx(pisqo6-ddilog(omarg2))-log(arg2)*wlog
      else
      dilog2=dcmplx(ddilog(arg2))
      endif

      Ival(-2)=fac
      Ival(-1)=Ival(-2)*wlogm+fac*2d0*wlog
      Ival(0) =-Ival(-2)*0.5d0*wlogm**2+Ival(-1)*wlogm
     . +fac*(wlog**2+dcmplx(pisqo6)-2d0*dilog2)

      return
      end


Subroutine hijels(psc1, psc2)
  Implicit Double Precision (D)
  Dimension psc1(5), psc2(5)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /rndf77/nseed
  Save
  cc = 1.0 - hint1(12)/hint1(13)
  rr = (1.0-cc)*hint1(13)/hint1(12)/(1.0-hipr1(33)) - 1.0
  bb = 0.5*(3.0+rr+sqrt(9.0+10.0*rr+rr**2))
  ep = sqrt((psc1(1)-psc2(1))**2+(psc1(2)-psc2(2))**2+(psc1(3)-psc2(3))**2)
  If (ep<=0.1) Return
  els0 = 98.0/ep + 52.0*(1.0+rr)**2
  pcm1 = psc1(1) + psc2(1)
  pcm2 = psc1(2) + psc2(2)
  pcm3 = psc1(3) + psc2(3)
  ecm = psc1(4) + psc2(4)
  am1 = psc1(5)**2
  am2 = psc2(5)**2
  amm = ecm**2 - pcm1**2 - pcm2**2 - pcm3**2
  If (amm<=psc1(5)+psc2(5)) Return
  pmax = (amm**2+am1**2+am2**2-2.0*amm*am1-2.0*amm*am2-2.0*am1*am2)/4.0/amm
  pmax = abs(pmax)
  20 tt = ranart(nseed)*min(pmax, 1.5)
  els = 98.0*exp(-2.8*tt)/ep + 52.0*exp(-9.2*tt)*(1.0+rr*exp(-4.6*(bb-1.0)*tt))**2
  If (ranart(nseed)>els/els0) Goto 20
  phi = 2.0*hipr1(40)*ranart(nseed)
  dbx = dble(pcm1/ecm)
  dby = dble(pcm2/ecm)
  dbz = dble(pcm3/ecm)
  db = dsqrt(dbx**2+dby**2+dbz**2)
  If (db>0.99999999D0) Then
    dbx = dbx*(0.99999999D0/db)
    dby = dby*(0.99999999D0/db)
    dbz = dbz*(0.99999999D0/db)
    db = 0.99999999D0
    Write (6, *) ' (HIJELS) boost vector too large'
  End If
  dga = 1D0/sqrt(1D0-db**2)
  dp1 = dble(sqrt(tt)*sin(phi))
  dp2 = dble(sqrt(tt)*cos(phi))
  dp3 = dble(sqrt(pmax-tt))
  dp4 = dble(sqrt(pmax+am1))
  dbp = dbx*dp1 + dby*dp2 + dbz*dp3
  dgabp = dga*(dga*dbp/(1D0+dga)+dp4)
  psc1(1) = sngl(dp1+dgabp*dbx)
  psc1(2) = sngl(dp2+dgabp*dby)
  psc1(3) = sngl(dp3+dgabp*dbz)
  psc1(4) = sngl(dga*(dp4+dbp))
  dp1 = -dble(sqrt(tt)*sin(phi))
  dp2 = -dble(sqrt(tt)*cos(phi))
  dp3 = -dble(sqrt(pmax-tt))
  dp4 = dble(sqrt(pmax+am2))
  dbp = dbx*dp1 + dby*dp2 + dbz*dp3
  dgabp = dga*(dga*dbp/(1D0+dga)+dp4)
  psc2(1) = sngl(dp1+dgabp*dbx)
  psc2(2) = sngl(dp2+dgabp*dby)
  psc2(3) = sngl(dp3+dgabp*dbz)
  psc2(4) = sngl(dga*(dp4+dbp))
  Return
End Subroutine hijels


REAL (C_DOUBLE) FUNCTION dasum_noblas(N, vecA) BIND(C)
    USE ISO_C_BINDING
    IMPLICIT NONE

    INTEGER (C_LONG), VALUE :: N
    REAL (C_DOUBLE), DIMENSION(N) :: vecA

    dasum_noblas = SUM(ABS(vecA))

END FUNCTION

REAL (C_DOUBLE) FUNCTION dasum_blas(N, vecA) BIND(C)
    USE ISO_C_BINDING
    IMPLICIT NONE

    INTEGER (C_LONG), VALUE :: N
    REAL (C_DOUBLE), DIMENSION(N) :: vecA
    DOUBLE PRECISION DASUM

    dasum_blas = DASUM(N, vecA, 1)

END FUNCTION


! { dg-do run }
! PR 35995 - ifunction.m4 and ifunction_logical.m4 had a bug
! where zero-sized arguments were not handled correctly.
! Test case provided by Dick Hendrickson, amended by
! Thomas Koenig.

      program try_gf0026_etc

      call       gf0026(  0,  1)
      call       foo   (  0,  1)

      end program

      SUBROUTINE GF0026(nf0,nf1)
      LOGICAL LDA(9)
      INTEGER IDA(NF0,9), iii(9)

      lda = (/ (i/2*2 .eq. I, i=1,9) /)
      LDA = ALL ( IDA .NE. -1000,  1)
      if (.not. all(lda)) STOP 1
      if (.not. all(ida .ne. -1000)) STOP 2

      lda = (/ (i/2*2 .eq. I, i=1,9) /)
      LDA = any ( IDA .NE. -1000,  1)
      print *, lda          !expect FALSE
      if (any(lda)) STOP 3
      print *, any(ida .ne. -1000)   !expect FALSE
      if (any(ida .ne. -1000)) STOP 4

      iii = 137
      iii = count ( IDA .NE. -1000,  1)
      if (any(iii /= 0)) STOP 5
      if (count(ida .ne. -1000) /= 0) STOP 6

      END SUBROUTINE

      subroutine foo (nf0, nf1)
      integer, dimension(9):: res, iii
      integer, dimension(nf0,9) :: ida
      res = (/ (-i, i=1,9) /)
      res = product (ida, 1)
      if (any(res /= 1)) STOP 7
      end subroutine foo