! Module for transforming user element for rotations
module uel_trans_mod
use abaqus_utils_mod
implicit none

    private

    public :: get_phi       !function(u) result(phi_rp)
    public :: get_u_prim    !subroutine(coords, u, u_prim)
    public :: get_f_glob    !subroutine(phi_rp, f_prim, f_glob)
    public :: get_k_glob    !subroutine(phi_rp, k_glob)

    contains

    function get_phi(u) result(phi_rp)
    implicit none
        double precision, intent(in)    :: u(:)
        double precision                :: phi_rp(3)

        phi_rp = u(4:6)

    end function get_phi

    subroutine get_u_prim(coords, u, u_prim)
    implicit none
        double precision, intent(in)    :: coords(:,:)      ! Node coordinates(dim, nodenr)
        double precision, intent(in)    :: u(:)             ! Displacements in global coordinates
                                                            ! (rotated)
        double precision, intent(inout) :: u_prim(:)        ! Displacements in unrotated (initial)
                                                            ! coordinates

        integer                         :: num_nodes        ! Number of nodes
        integer                         :: i1, i2, k1       ! Iterators
        double precision                :: rot_mat_t(3,3)   ! Transpose rotation matrix
        double precision                :: xi_minus_x0(3)   ! Vector from current wheel center to
                                                            ! current node position

        num_nodes = (size(u)-3)/3

        rot_mat_t = transpose(get_rotation_matrix(get_phi(u)))

        u_prim(1:6) = 0.0

        do k1=2,num_nodes
            i1 = 3*k1 + 1
            i2 = i1 + 2
            xi_minus_x0 = coords(:, k1) + u(i1:i2) - (coords(:, 1) + u(1:3))
            u_prim(i1:i2) = matmul(rot_mat_t, xi_minus_x0) - (coords(:, k1) - coords(:, 1))
        enddo

    end subroutine get_u_prim

    subroutine get_f_glob(phi_rp, f_prim, f_glob)
    implicit none
        double precision, intent(in)    :: phi_rp(:)
        double precision, intent(in)    :: f_prim(:)
        double precision, intent(inout) :: f_glob(:)

        integer                         :: num_nodes        ! Number of nodes
        integer                         :: i1, i2, k1       ! Iterators
        double precision                :: rot_mat(3,3)     ! Rotation matrix
        double precision                :: xi_minus_x0(3)   ! Vector from current wheel center to
                                                            ! current node position

        num_nodes = (size(f_prim)-3)/3

        rot_mat = get_rotation_matrix(phi_rp)

        do k1=0,num_nodes   ! Torque rotated the same way as forces
            i1 = 3*k1 + 1
            i2 = i1 + 2
            f_glob(i1:i2) = matmul(rot_mat, f_prim(i1:i2))
        enddo

    end subroutine get_f_glob

    subroutine get_k_glob(phi_rp, k_glob)
    use uel_stiff_mod, only : uel_stiffness!, print_uel_time
    implicit none
        double precision, intent(in)                :: phi_rp(:)
        double precision, intent(inout)             :: k_glob(:,:)
        double precision                            :: rot_mat(3,3)         ! Rotation matrix
        double precision                            :: rot_mat_t(3,3)  ! Transpose rotation matrix
        integer                                     :: ndof,nnod
        integer                                     :: i_n,j_n
        integer                                     :: i_d(3),j_d(3)

        rot_mat = get_rotation_matrix(phi_rp)
        rot_mat_t = transpose(rot_mat)
        ndof = size(k_glob,1)
        nnod = ndof/3
        ! Leftmost index change fastest, hence we have that in the inner loop
        do j_n=1,nnod
            j_d = 3*(j_n-1) + [1,2,3]
            do i_n=1,nnod
                i_d = 3*(i_n-1) + [1,2,3]
                !k_d = i_d
                !l_d = j_d
                !k_glob(i_d,j_d) = matmul(matmul(Q(i_d,i_d), uel_stiffness(k_d,l_d)), transpose(Q(j_d, j_d)))
                k_glob(i_d,j_d) = matmul(matmul(rot_mat, uel_stiffness(i_d,j_d)), rot_mat_t)
            enddo
        enddo

        ! Reference with full loop (to help understand code):
        !do i_n=1,nnod
        !    i_d = 3*(i_n-1) + [1,2,3]
        !    do j_n=1,nnod
        !        j_d = 3*(j_n-1) + [1,2,3]
        !        do k_n=1,nnod
        !            k_d = 3*(k_n-1) + [1,2,3]
        !            do l_n=1,nnod
        !                l_d = 3*(l_n-1) + [1,2,3]
        !                ! Q(i_d,k_d) = 0 unless i_n=k_n
        !                ! Q(j_d,l_d) = 0 unless j_n=l_n
        !                k_glob(i_d,j_d) = k_glob(i_d,j_d) + matmul(matmul(Q(i_d,k_d), uel_stiffness(k_d,l_d)), transpose(Q(l_d, j_d)))
        !            enddo
        !        enddo
        !    enddo
        !enddo
    end subroutine get_k_glob

    ! Internal procedures
    function get_rotation_matrix(phi_rp) result(rot_mat)
    implicit none
        double precision, intent(in)    :: phi_rp(:)        ! Rotation (either 1 (2d) or 3 (3d) comp)
        double precision, allocatable   :: rot_mat(:,:)     ! Rotation matrix (2x2 (2d) or 3x3 (3d)
        if (size(phi_rp) == 1) then ! 2d
            allocate(rot_mat(2,2))
            rot_mat(1, :) = [cos(phi_rp(1)), -sin(phi_rp(1))]
            rot_mat(2, :) = [sin(phi_rp(1)), cos(phi_rp(1))]
        elseif (size(phi_rp) == 3) then ! 3d, but account only for rotation around x-axis
            allocate(rot_mat(3,3))
            rot_mat(1, :) = [1.d0, 0.d0, 0.d0]
            rot_mat(2, :) = [0.d0, cos(phi_rp(1)), -sin(phi_rp(1))]
            rot_mat(3, :) = [0.d0, sin(phi_rp(1)), cos(phi_rp(1))]
        else
            write(*,*) 'phi_rp must have length 1 or 3 in "get_rotation_matrix"'
            write(*,*) 'size(phi_rp) = ', size(phi_rp)
            call xit()
        endif

    end function get_rotation_matrix

end module uel_trans_mod

! Unused modules, keep for reference and potentially for testing:
    ! subroutine get_k_glob_slow(phi_rp, k_glob)
    ! use uel_stiff_mod
    ! implicit none
        ! double precision, intent(in)    :: phi_rp(:)
        ! double precision, intent(inout) :: k_glob(:,:)

        ! double precision, allocatable   :: exp_rot_mat(:,:)

        ! ! This a very inefficient procedure for large matrices, as exp_rot_mat is (1) diagonal with
        ! ! band width 2 or 3, and (2) contains a repeated pattern. This could therefore be sped up, but
        ! ! on the other hand this might not be performance critical. It should be evaluated though...
        ! call print_uel_time('get_k_glob start = ')
        ! call get_expanded_rotation_matrix(phi_rp, size(uel_stiffness,1), exp_rot_mat)
        ! call print_uel_time('get_k_glob middle = ')
        ! k_glob = matmul(matmul(exp_rot_mat, uel_stiffness), transpose(exp_rot_mat))
        ! call print_uel_time('get_k_glob end = ')
    ! end subroutine get_k_glob_slow

    ! subroutine get_expanded_rotation_matrix(phi_rp, ndof, exp_rot_mat)
    ! implicit none
        ! double precision, intent(in)                :: phi_rp(:)        ! Rotation (either 1 (2d) or 3
                                                                        ! !(3d) comp)
        ! integer, intent(in)                         :: ndof             ! Number of degrees of freedom
        ! double precision, allocatable, intent(out)  :: exp_rot_mat(:,:) ! Expanded rotation matrix
                                                                        ! ! (ndof x ndof)

        ! integer                                     :: k1               ! Iterator
        ! double precision, allocatable               :: rot_mat(:,:)     ! Rotation matrix
        ! integer                                     :: num_node_dofs    ! Number of dofs per node

        ! allocate(exp_rot_mat(ndof,ndof))
        ! allocate(rot_mat, source=get_rotation_matrix(phi_rp))

        ! num_node_dofs = size(rot_mat,1)

        ! if (num_node_dofs == 2) then     ! 2d, rotation handled as special case
            ! exp_rot_mat(1:num_node_dofs, 1:num_node_dofs) = rot_mat
            ! exp_rot_mat(3,3) = 1.d0
            ! do k1=4,ndof,num_node_dofs
                ! exp_rot_mat(k1:(k1+num_node_dofs), k1:(k1+num_node_dofs)) = rot_mat
            ! enddo
        ! else                            ! 3d, no special treatment required
            ! do k1=1,ndof,num_node_dofs
                ! exp_rot_mat(k1:(k1+num_node_dofs-1), k1:(k1+num_node_dofs-1)) = rot_mat
            ! enddo
        ! endif

    ! end subroutine get_expanded_rotation_matrix


      subroutine ttcoef(k)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes travel time coefficients for routing
!!    along the main channel

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ch_d(:)     |m             |average depth of main channel
!!    ch_l2(:)    |km            |length of main channel
!!    ch_n(2,:)   |none          |Manning's "n" value for the main channel
!!    ch_s(2,:)   |m/m           |average slope of main channel
!!    ch_w(2,:)   |m             |average width of main channel
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    chsslope(:)   |none          |change in horizontal distance per unit
!!                               |change in vertical distance on channel side
!!                               |slopes; always set to 2 (slope=1/2)
!!    phi(1,:)    |m^2           |cross-sectional area of flow at bankfull
!!                               |depth
!!    phi(2,:)    |none          |
!!    phi(3,:)    |none          |
!!    phi(4,:)    |none          |
!!    phi(5,:)    |m^3/s         |flow rate when reach is at bankfull depth
!!    phi(6,:)    |m             |bottom width of main channel
!!    phi(7,:)    |m             |depth of water when reach is at bankfull
!!                               |depth
!!    phi(8,:)    |m/s           |average velocity when reach is at
!!                               |bankfull depth
!!    phi(9,:)    |m/s           |wave celerity when reach is at
!!                               |bankfull depth
!!    phi(10,:)   |hr            |storage time constant for reach at
!!                               |bankfull depth (ratio of storage to
!!                               |discharge)
!!    phi(11,:)   |m/s           |average velocity when reach is at
!!                               |0.1 bankfull depth (low flow)
!!    phi(12,:)   |m/s           |wave celerity when reach is at
!!                               |0.1 bankfull depth (low flow)
!!    phi(13,:)   |hr            |storage time constant for reach at
!!                               |0.1 bankfull depth (low flow) (ratio
!!                               |of storage to discharge)
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    aa          |none          |area/area=1 (used to calculate velocity with
!!                               |Manning's equation)
!!    a           |m^2           |cross-sectional area of channel
!!    b           |m             |bottom width of channel
!!    d           |m             |depth of flow
!!    fps         |none          |change in horizontal distance per unit
!!                               |change in vertical distance on floodplain side
!!                               |slopes; always set to 4 (slope=1/4)
!!    jj          |none          |counter
!!    k           |none          |dummy argument (HRU number)
!!    p           |m             |wetting perimeter
!!    qq1         |m^3/s         |flow rate for a specified depth
!!    rh          |m             |hydraulic radius of channel
!!    tt1         |km s/m        |time coefficient for specified depth
!!    tt2         |km s/m        |time coefficient for bankfull depth
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sqrt
!!    SWAT: Qman

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~
      use parm

      integer, intent (in) :: k
      integer :: jj
      real :: fps, d, b, p, a, qq1, rh, tt1, tt2, aa

      do jj = 1, 13
        phi(jj,k) = 0.
      end do

      aa = 1.
      b = 0.
      d = 0.
!!    If side slope is not set in .rte file then assume this default
!!    If it is main reach default side slope to 2:1 if it is a waterway default to 8:1
      if (chside(k) <= 1.e-6) then
         chsslope = 2.
      else
         chsslope = chside(k)
      end if

      fps = 4.
      d = ch_d(k)
      b = ch_w(2,k) - 2. * d * chsslope

!!    check if bottom width (b) is < 0
      if (b <= 0.) then
        b = 0.
        chsslope = 0.
        b = .5 * ch_w(2,k)
        chsslope = (ch_w(2,k) - b) / (2. * d)
      end if
      phi(6,k) = b
      phi(7,k) = d

!!    compute flow and travel time at bankfull depth
      p = 0.
      a = 0.
      rh = 0.
      tt2 = 0.
      p = b + 2. * d * Sqrt(chsslope * chsslope + 1.)
      a = b * d + chsslope * d * d
      rh = a / p
      phi(1,k) = a
      phi(5,k) = Qman(a, rh, ch_n(2,k), ch_s(2,k))
      phi(8,k) = Qman(aa, rh, ch_n(2,k), ch_s(2,k))
      phi(9,k) = phi(8,k) * 5. / 3.
      phi(10,k) = ch_l2(k) / phi(9,k) / 3.6
      tt2 = ch_l2(k) * a / phi(5,k)

!!    compute flow and travel time at 1.2 bankfull depth
      d = 0.
      rh = 0.
      qq1 = 0.
      tt1 = 0.
      d = 1.2 * ch_d(k)
      a = a + (ch_w(2,k) * ch_d(k) + fps * (d - ch_d(k)) ** 2)
      p = p + 4. * ch_w(2,k) + (0.4 * ch_d(k) * Sqrt(fps * fps + 1.))
      rh = a / p
      qq1 = Qman(a, rh, ch_n(2,k), ch_s(2,k))
      tt1 = ch_l2(k) * a / qq1

!!    compute flow and travel time at 0.1 bankfull depth
      a = 0.
      d = 0.
      p = 0.
      rh = 0.
      qq1 = 0.
      tt1 = 0.
      d = 0.1 * ch_d(k)
      p = b + 2. * d * Sqrt(chsslope * chsslope + 1.)
      a = b * d + chsslope * d * d
      rh = a / p
      qq1 = Qman(a, rh, ch_n(2,k), ch_s(2,k))
      tt1 = ch_l2(k) * a / qq1
      phi(11,k) = Qman(aa, rh, ch_n(2,k), ch_s(2,k))
      phi(12,k) = phi(11,k) * 5. / 3.
      phi(13,k) = ch_l2(k) / phi(12,k) / 3.6

      return
      end


!
! rhOver - a FORTRAN program to determine magnetic anisotropy and related
! properties for dysprosium(III) single-ion magnets by semi-empirical approaches
! Copyright (C) 2014-2019 Michael Böhme <boehme.mic@gmail.com>
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!

! *************************************************************************
! * rotation about Euler angles alpha, beta, gamma
! *************************************************************************
subroutine rotate_euler_3d(alpha, beta, gamma, srcX, srcY, srcZ, destX, destY, destZ)
	implicit none
!
	double precision, intent(in) :: alpha, beta, gamma, srcX, srcY, srcZ
	double precision, intent(out) :: destX, destY, destZ
!
	destX = srcZ*dsin(alpha)*dsin(beta) + srcY*(-(dcos(beta)*dcos(gamma)*dsin(alpha)) - dcos(alpha)*dsin(gamma)) + &
		srcX*(dcos(alpha)*dcos(gamma) - dcos(beta)*dsin(alpha)*dsin(gamma))
	destY = -(srcZ*dcos(alpha)*dsin(beta)) + srcX*(dcos(gamma)*dsin(alpha) + dcos(alpha)*dcos(beta)*dsin(gamma)) + &
		srcY*(dcos(alpha)*dcos(beta)*dcos(gamma) - dsin(alpha)*dsin(gamma))
	destZ = srcZ*dcos(beta) + srcY*dcos(gamma)*dsin(beta) + srcX*dsin(beta)*dsin(gamma)

end subroutine

! *************************************************************************
! * inverse rotation about Euler angles alpha, beta, gamma
! *************************************************************************
subroutine rotate_euler_3d_inv(alpha, beta, gamma, srcX, srcY, srcZ, destX, destY, destZ)
	implicit none
!
	double precision, intent(in) :: alpha, beta, gamma, srcX, srcY, srcZ
	double precision, intent(out) :: destX, destY, destZ
!
	destX = srcZ*dsin(beta)*dsin(gamma) + srcY*(dcos(gamma)*dsin(alpha) + dcos(alpha)*dcos(beta)*dsin(gamma)) + &
		srcX*(dcos(alpha)*dcos(gamma) - dcos(beta)*dsin(alpha)*dsin(gamma))
	destY = srcZ*dcos(gamma)*dsin(beta) + srcX*(-(dcos(beta)*dcos(gamma)*dsin(alpha)) - dcos(alpha)*dsin(gamma)) + &
		srcY*(dcos(alpha)*dcos(beta)*dcos(gamma) - dsin(alpha)*dsin(gamma))
	destZ = srcZ*dcos(beta) - srcY*dcos(alpha)*dsin(beta) + srcX*dsin(alpha)*dsin(beta)

end subroutine

! *************************************************************************
! * calculates the angle between two vectors
! *************************************************************************
function calc_vec_angle(vax, vay, vaz, vbx, vby, vbz) result(res)
	use global_c
	implicit none
!
	double precision, intent(in) :: vax, vay, vaz, vbx, vby, vbz
	double precision :: res
!
	res = 180d0/pi * dacos( (vax*vbx+vay*vby+vaz*vbz) / &
		( dsqrt(vax**2 + vay**2 + vaz**2) * dsqrt(vbx**2 + vby**2 + vbz**2)) )
	if ( res .gt. 90d0 ) then
		res= 180d0 - res
	end if

end function


!******************************************************************************
!******************************************************************************
MODULE evaluate_auxiliary

	!/*	external modules	  */

    USE shared_constants

    USE shared_auxiliary

	!/*	setup	*/

    IMPLICIT NONE

    PUBLIC

CONTAINS
!******************************************************************************
!******************************************************************************
FUNCTION get_smoothed_probability(total_payoffs, idx, tau)

    !/* external objects        */

    INTEGER(our_int), INTENT(IN)    :: idx

    REAL(our_dble), INTENT(IN)      :: total_payoffs(4)
    REAL(our_dble), INTENT(IN)      :: tau

    !/*  internal objects       */

    INTEGER(our_int), ALLOCATABLE   :: infos(:)

    REAL(our_dble)                  :: get_smoothed_probability
    REAL(our_dble)                  :: smoot_payoff(4)
    REAL(our_dble)                  :: maxim_payoff(4)

!------------------------------------------------------------------------------
! Algorithm
!------------------------------------------------------------------------------

    maxim_payoff = MAXVAL(total_payoffs)

    CALL clip_value(smoot_payoff, EXP((total_payoffs - maxim_payoff)/tau), zero_dble, HUGE_FLOAT, infos)

    get_smoothed_probability = smoot_payoff(idx) / SUM(smoot_payoff)

END FUNCTION
!******************************************************************************
!******************************************************************************
PURE FUNCTION normal_pdf(x, mean, sd)

    !/* external objects        */

    REAL(our_dble), INTENT(IN)      :: mean
    REAL(our_dble), INTENT(IN)      :: sd
    REAL(our_dble), INTENT(IN)      :: x

    !/*  internal objects       */

    REAL(our_dble)                  :: normal_pdf
    REAL(our_dble)                  :: std

!------------------------------------------------------------------------------
! Algorithm
!------------------------------------------------------------------------------

    std = ((x - mean) / sd)

    normal_pdf = (one_dble / sd) * (one_dble / sqrt(two_dble * pi))

    normal_pdf = normal_pdf * exp( -(std * std) / two_dble)

END FUNCTION
!******************************************************************************
!******************************************************************************
END MODULE


*> \brief \b DLAMCH
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DLAMCH determines double precision machine parameters.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] CMACH
*> \verbatim
*>          Specifies the value to be returned by DLAMCH:
*>          = 'E' or 'e',   DLAMCH := eps
*>          = 'S' or 's ,   DLAMCH := sfmin
*>          = 'B' or 'b',   DLAMCH := base
*>          = 'P' or 'p',   DLAMCH := eps*base
*>          = 'N' or 'n',   DLAMCH := t
*>          = 'R' or 'r',   DLAMCH := rnd
*>          = 'M' or 'm',   DLAMCH := emin
*>          = 'U' or 'u',   DLAMCH := rmin
*>          = 'L' or 'l',   DLAMCH := emax
*>          = 'O' or 'o',   DLAMCH := rmax
*>          where
*>          eps   = relative machine precision
*>          sfmin = safe minimum, such that 1/sfmin does not overflow
*>          base  = base of the machine
*>          prec  = eps*base
*>          t     = number of (base) digits in the mantissa
*>          rnd   = 1.0 when rounding occurs in addition, 0.0 otherwise
*>          emin  = minimum exponent before (gradual) underflow
*>          rmin  = underflow threshold - base**(emin-1)
*>          emax  = largest exponent before overflow
*>          rmax  = overflow threshold  - (base**emax)*(1-eps)
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERauxiliary
*
*  =====================================================================
      DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          CMACH
*     ..
*
* =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   RND, EPS, SFMIN, SMALL, RMACH
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. Intrinsic Functions ..
      EXTERNAL           DIGITS, EPSILON, HUGE, MAXEXPONENT,
     $                   MINEXPONENT, RADIX, TINY
*     ..
*     .. Executable Statements ..
*
*
*     Assume rounding, not chopping. Always.
*
      RND = ONE
*
      IF( ONE.EQ.RND ) THEN
         EPS = EPSILON(ZERO) * 0.5
      ELSE
         EPS = EPSILON(ZERO)
      END IF
*
      IF( LSAME( CMACH, 'E' ) ) THEN
         RMACH = EPS
      ELSE IF( LSAME( CMACH, 'S' ) ) THEN
         SFMIN = TINY(ZERO)
         SMALL = ONE / HUGE(ZERO)
         IF( SMALL.GE.SFMIN ) THEN
*
*           Use SMALL plus a bit, to avoid the possibility of rounding
*           causing overflow when computing  1/sfmin.
*
            SFMIN = SMALL*( ONE+EPS )
         END IF
         RMACH = SFMIN
      ELSE IF( LSAME( CMACH, 'B' ) ) THEN
         RMACH = RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'P' ) ) THEN
         RMACH = EPS * RADIX(ZERO)
      ELSE IF( LSAME( CMACH, 'N' ) ) THEN
         RMACH = DIGITS(ZERO)
      ELSE IF( LSAME( CMACH, 'R' ) ) THEN
         RMACH = RND
      ELSE IF( LSAME( CMACH, 'M' ) ) THEN
         RMACH = MINEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'U' ) ) THEN
         RMACH = tiny(zero)
      ELSE IF( LSAME( CMACH, 'L' ) ) THEN
         RMACH = MAXEXPONENT(ZERO)
      ELSE IF( LSAME( CMACH, 'O' ) ) THEN
         RMACH = HUGE(ZERO)
      ELSE
         RMACH = ZERO
      END IF
*
      DLAMCH = RMACH
      RETURN
*
*     End of DLAMCH
*
      END
************************************************************************
*> \brief \b DLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> DLAMC3  is intended to force  A  and  B  to be stored prior to doing
*> the addition of  A  and  B ,  for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date December 2016
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*>          A is a DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is a DOUBLE PRECISION
*>          The values A and B.
*> \endverbatim
*>
      DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
*  -- LAPACK auxiliary routine (version 3.7.0) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2010
*
*     .. Scalar Arguments ..
      DOUBLE PRECISION   A, B
*     ..
* =====================================================================
*
*     .. Executable Statements ..
*
      DLAMC3 = A + B
*
      RETURN
*
*     End of DLAMC3
*
      END
*
************************************************************************


!< Jiang-Shu and Gerolymos-Senechal-Vallet kappa coefficients for reconstruction.
module wenoof_kappa_rec_js
!< Jiang-Shu and Gerolymos-Senechal-Vallet kappa coefficients for reconstruction.
!<
!< @note The provided WENO kappa implements the linear weights defined in *Efficient Implementation of Weighted ENO
!< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
!< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
!< doi:10.1016/j.jcp.2009.07.039

use penf, only : I_P, R_P, str
use wenoof_base_object, only : base_object, base_object_constructor
use wenoof_kappa_object, only : kappa_object, kappa_object_constructor

implicit none
private
public :: kappa_rec_js
public :: kappa_rec_js_constructor

type, extends(kappa_object_constructor) :: kappa_rec_js_constructor
  !< Jiang-Shu and Gerolymos-Senechal-Vallet optimal kappa object constructor.
  contains
    ! public deferred methods
    procedure, pass(lhs) :: constr_assign_constr !< `=` operator.
endtype kappa_rec_js_constructor

type, extends(kappa_object):: kappa_rec_js
  !< Jiang-Shu and Gerolymos-Senechal-Vallet kappa object.
  !<
  !< @note The provided WENO kappa implements the weights defined in *Efficient Implementation of Weighted ENO
  !< Schemes*, Guang-Shan Jiang, Chi-Wang Shu, JCP, 1996, vol. 126, pp. 202--228, doi:10.1006/jcph.1996.0130 and
  !< *Very-high-order weno schemes*, G. A. Gerolymos, D. Senechal, I. Vallet, JCP, 2009, vol. 228, pp. 8481-8524,
  !< doi:10.1016/j.jcp.2009.07.039
  real(R_P), allocatable :: values(:,:) !< Kappa coefficients values [1:2,0:S-1].
  contains
    ! public deferred methods
    procedure, pass(self) :: create               !< Create kappa.
    procedure, pass(self) :: compute_int          !< Compute kappa (interpolate).
    procedure, pass(self) :: compute_rec          !< Compute kappa (reconstruct).
    procedure, pass(self) :: description          !< Return object string-description.
    procedure, pass(self) :: destroy              !< Destroy kappa.
    procedure, pass(lhs)  :: object_assign_object !< `=` operator.
endtype kappa_rec_js

contains
  ! constructor

  ! deferred public methods
  subroutine constr_assign_constr(lhs, rhs)
  !< `=` operator.
  class(kappa_rec_js_constructor), intent(inout) :: lhs !< Left hand side.
  class(base_object_constructor),  intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  endsubroutine constr_assign_constr

  ! deferred public methods
  subroutine create(self, constructor)
  !< Create kappa.
  !<
  !< @note The kappa coefficients are also computed, they being constants.
  class(kappa_rec_js),            intent(inout) :: self        !< Kappa.
  class(base_object_constructor), intent(in)    :: constructor !< Kappa constructor.

  call self%destroy
  call self%create_(constructor=constructor)
  allocate(self%values(1:2, 0:self%S - 1))
  call self%compute_rec(values=self%values)
  endsubroutine create

  pure subroutine compute_int(self, x_target, values)
  !< Compute kappa (interpolate).
  class(kappa_rec_js), intent(in)  :: self               !< Kappa.
  real(R_P),           intent(in)  :: x_target           !< Coordinate of the interpolation point.
  real(R_P),           intent(out) :: values(0:)         !< Kappa values.
  ! empty procedure
  endsubroutine compute_int

  pure subroutine compute_rec(self, values)
  !< Compute kappa (reconstruct).
  class(kappa_rec_js), intent(in)  :: self          !< Kappa.
  real(R_P),           intent(out) :: values(1:,0:) !< Kappa values.

  select case(self%S)
    case(2) ! 3rd order
      ! 1 => left interface (i-1/2)
      values(1, 0) = 2._R_P/3._R_P ! stencil 0
      values(1, 1) = 1._R_P/3._R_P ! stencil 1
      ! 2 => right interface (i+1/2)
      values(2, 0) = 1._R_P/3._R_P ! stencil 0
      values(2, 1) = 2._R_P/3._R_P ! stencil 1
    case(3) ! 5th order
      ! 1 => left interface (i-1/2)
      values(1, 0) = 0.3_R_P ! stencil 0
      values(1, 1) = 0.6_R_P ! stencil 1
      values(1, 2) = 0.1_R_P ! stencil 2
      ! 2 => right interface (i+1/2)
      values(2, 0) = 0.1_R_P ! stencil 0
      values(2, 1) = 0.6_R_P ! stencil 1
      values(2, 2) = 0.3_R_P ! stencil 2
    case(4) ! 7th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =  4._R_P/35._R_P ! stencil 0
      values(1, 1) = 18._R_P/35._R_P ! stencil 1
      values(1, 2) = 12._R_P/35._R_P ! stencil 2
      values(1, 3) =  1._R_P/35._R_P ! stencil 3
      ! 2 => right interface (i+1/2)
      values(2, 0) =  1._R_P/35._R_P ! stencil 0
      values(2, 1) = 12._R_P/35._R_P ! stencil 1
      values(2, 2) = 18._R_P/35._R_P ! stencil 2
      values(2, 3) =  4._R_P/35._R_P ! stencil 3
    case(5) ! 9th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =  5._R_P/126._R_P ! stencil 0
      values(1, 1) = 20._R_P/63._R_P  ! stencil 1
      values(1, 2) = 10._R_P/21._R_P  ! stencil 2
      values(1, 3) = 10._R_P/63._R_P  ! stencil 3
      values(1, 4) =  1._R_P/126._R_P ! stencil 4
      ! 2 => right interface (i+1/2)
      values(2, 0) =  1._R_P/126._R_P ! stencil 0
      values(2, 1) = 10._R_P/63._R_P  ! stencil 1
      values(2, 2) = 10._R_P/21._R_P  ! stencil 2
      values(2, 3) = 20._R_P/63._R_P  ! stencil 3
      values(2, 4) =  5._R_P/126._R_P ! stencil 4
    case(6) ! 11th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =   1._R_P/77._R_P  ! stencil 0
      values(1, 1) =  25._R_P/154._R_P ! stencil 1
      values(1, 2) = 100._R_P/231._R_P ! stencil 2
      values(1, 3) =  25._R_P/77._R_P  ! stencil 3
      values(1, 4) =   5._R_P/77._R_P  ! stencil 4
      values(1, 5) =   1._R_P/462._R_P ! stencil 5
      ! 2 => right interface (i+1/2)
      values(2, 0) =   1._R_P/462._R_P ! stencil 0
      values(2, 1) =   5._R_P/77._R_P  ! stencil 1
      values(2, 2) =  25._R_P/77._R_P  ! stencil 2
      values(2, 3) = 100._R_P/231._R_P ! stencil 3
      values(2, 4) =  25._R_P/154._R_P ! stencil 4
      values(2, 5) =   1._R_P/77._R_P  ! stencil 5
    case(7) ! 13th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =   7._R_P/1716._R_P ! stencil 0
      values(1, 1) =  21._R_P/286._R_P  ! stencil 1
      values(1, 2) = 175._R_P/572._R_P  ! stencil 2
      values(1, 3) = 175._R_P/429._R_P  ! stencil 3
      values(1, 4) = 105._R_P/572._R_P  ! stencil 4
      values(1, 5) =   7._R_P/286._R_P  ! stencil 5
      values(1, 6) =   1._R_P/1716._R_P ! stencil 6
      ! 2 => right interface (i+1/2)
      values(2, 0) =   1._R_P/1716._R_P ! stencil 0
      values(2, 1) =   7._R_P/286._R_P  ! stencil 1
      values(2, 2) = 105._R_P/572._R_P  ! stencil 2
      values(2, 3) = 175._R_P/429._R_P  ! stencil 3
      values(2, 4) = 175._R_P/572._R_P  ! stencil 4
      values(2, 5) =  21._R_P/286._R_P  ! stencil 5
      values(2, 6) =   7._R_P/1716._R_P ! stencil 6
    case(8) ! 15th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =   8._R_P/6435._R_P ! stencil 0
      values(1, 1) = 196._R_P/6435._R_P ! stencil 1
      values(1, 2) = 392._R_P/2145._R_P ! stencil 2
      values(1, 3) = 490._R_P/1287._R_P ! stencil 3
      values(1, 4) = 392._R_P/1287._R_P ! stencil 4
      values(1, 5) = 196._R_P/2145._R_P ! stencil 5
      values(1, 6) =  56._R_P/6435._R_P ! stencil 6
      values(1, 7) =   1._R_P/6435._R_P ! stencil 7
      ! 2 => right interface (i+1/2)
      values(2, 0) =   1._R_P/6435._R_P ! stencil 0
      values(2, 1) =  56._R_P/6435._R_P ! stencil 1
      values(2, 2) = 196._R_P/2145._R_P ! stencil 2
      values(2, 3) = 392._R_P/1287._R_P ! stencil 3
      values(2, 4) = 490._R_P/1287._R_P ! stencil 4
      values(2, 5) = 392._R_P/2145._R_P ! stencil 5
      values(2, 6) = 196._R_P/6435._R_P ! stencil 6
      values(2, 7) =   8._R_P/6435._R_P ! stencil 7
    case(9) ! 17th order
      ! 1 => left interface (i-1/2)
      values(1, 0) =    9._R_P/24310._R_P ! stencil 0
      values(1, 1) =  144._R_P/12155._R_P ! stencil 1
      values(1, 2) = 1176._R_P/12155._R_P ! stencil 2
      values(1, 3) = 3528._R_P/12155._R_P ! stencil 3
      values(1, 4) =  882._R_P/2431._R_P  ! stencil 4
      values(1, 5) = 2352._R_P/12155._R_P ! stencil 5
      values(1, 6) =  504._R_P/12155._R_P ! stencil 6
      values(1, 7) =   36._R_P/12155._R_P ! stencil 7
      values(1, 8) =    1._R_P/24310._R_P ! stencil 8
      ! 2 => right interface (i+1/2)
      values(2, 0) =    1._R_P/24310._R_P ! stencil 0
      values(2, 1) =   36._R_P/12155._R_P ! stencil 1
      values(2, 2) =  504._R_P/12155._R_P ! stencil 2
      values(2, 3) = 2352._R_P/12155._R_P ! stencil 3
      values(2, 4) =  882._R_P/2431._R_P  ! stencil 4
      values(2, 5) = 3528._R_P/12155._R_P ! stencil 5
      values(2, 6) = 1176._R_P/12155._R_P ! stencil 6
      values(2, 7) =  144._R_P/12155._R_P ! stencil 7
      values(2, 8) =    9._R_P/24310._R_P ! stencil 8
  endselect
  endsubroutine compute_rec

  pure function description(self, prefix) result(string)
  !< Return object string-descripition.
  class(kappa_rec_js), intent(in)           :: self             !< Kappa coefficient.
  character(len=*),    intent(in), optional :: prefix           !< Prefixing string.
  character(len=:), allocatable             :: string           !< String-description.
  character(len=:), allocatable             :: prefix_          !< Prefixing string, local variable.
  character(len=1), parameter               :: NL=new_line('a') !< New line char.

  prefix_ = '' ; if (present(prefix)) prefix_ = prefix
  string = prefix_//'Jiang-Shu kappa coefficients object for reconstruction:'//NL
  string = string//prefix_//'  - S   = '//trim(str(self%S))
  endfunction description

  elemental subroutine destroy(self)
  !< Destroy kappa.
  class(kappa_rec_js), intent(inout) :: self !< Kappa.

  call self%destroy_
  if (allocated(self%values)) deallocate(self%values)
  endsubroutine destroy

  pure subroutine object_assign_object(lhs, rhs)
  !< `=` operator.
  class(kappa_rec_js), intent(inout) :: lhs !< Left hand side.
  class(base_object),  intent(in)    :: rhs !< Right hand side.

  call lhs%assign_(rhs=rhs)
  select type(rhs)
  type is(kappa_rec_js)
     if (allocated(rhs%values)) then
        lhs%values = rhs%values
     else
        if (allocated(lhs%values)) deallocate(lhs%values)
     endif
  endselect
  endsubroutine object_assign_object
endmodule wenoof_kappa_rec_js


! Test cshift0 for character arrays.
! { dg-do run }
program main
  implicit none
  integer, parameter :: n1 = 2, n2 = 3, n3 = 4, slen = 3
  character (len = slen), dimension (n1, n2, n3) :: a
  integer (kind = 1) :: shift1 = 3
  integer (kind = 2) :: shift2 = 4
  integer (kind = 4) :: shift3 = 5
  integer (kind = 8) :: shift4 = 6
  integer :: i1, i2, i3

  do i3 = 1, n3
    do i2 = 1, n2
      do i1 = 1, n1
        a (i1, i2, i3) = 'ab'(i1:i1) // 'cde'(i2:i2) // 'fghi'(i3:i3)
      end do
    end do
  end do

  call test (cshift (a, shift1, 1), int (shift1), 0, 0)
  call test (cshift (a, shift2, 2), 0, int (shift2), 0)
  call test (cshift (a, shift3, 3), 0, 0, int (shift3))
  call test (cshift (a, shift4, 3), 0, 0, int (shift4))
contains
  subroutine test (b, d1, d2, d3)
    character (len = slen), dimension (n1, n2, n3) :: b
    integer :: d1, d2, d3

    do i3 = 1, n3
      do i2 = 1, n2
        do i1 = 1, n1
          if (b (i1, i2, i3) .ne. a (mod (d1 + i1 - 1, n1) + 1, &
                                     mod (d2 + i2 - 1, n2) + 1, &
                                     mod (d3 + i3 - 1, n3) + 1)) call abort
        end do
      end do
    end do
  end subroutine test
end program main


! { dg-do run }

if (modulo (-8., -5.) .ne. -3.) STOP 1

end


! -------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!

      module m_eigen
!
!  Call sequence of routines to compute ordered, normalized, modified
!  EOFs and associated eigenvalues.  Also, for symmetric matrices allows
!  for computation of inverse.
!
      use precision

      implicit none

      Private

      public eigen_main

      real(r8), parameter  :: zero=0.d0
      real(r8), parameter  :: one=1.d0
      real(r8), parameter  :: two=2.d0
      real(r8), parameter  :: three=3.d0

! !REVISION HISTORY:
!
!  04Jun2003  R. Errico  Initial algorithm

      CONTAINS

! -------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------

      subroutine eigen_main (evectrs, evalues, matrix, weights, nk, &
                            testvalue, purpose, name, matrixR)

      external ssyev
      external dsyev

      character(len=*), intent(in) :: purpose
      character(len=*), intent(in) :: name
      integer,  intent(in)   :: nk
      real(r8), intent(in)   :: matrix(nk,nk)
      real(r8), intent(in)   :: weights(nk)
      real(r8), intent(in)   :: testvalue
      real(r8), intent(out)  :: evectrs(nk,nk)
      real(r8), intent(out)  :: evalues(nk)
      real(r8), intent(out)  :: matrixR(nk,nk)

!
      integer     :: nwork1
      integer     :: info
      real(r8)    :: mcopy(nk,nk)
      real(r8)    :: work1(nk*nk*2)

      nwork1=nk*nk*2

      if (purpose(2:2) == 'S') then ! symmetric input matrix
        evectrs=matrix
        if (r8 == 4) then
          call ssyev ( purpose(1:1), 'U', nk, evectrs, nk, evalues, &
                        work1, nwork1, info )
        elseif (r8 == 8) then
          call dsyev ( purpose(1:1), 'U', nk, evectrs, nk, evalues, &
                        work1, nwork1, info )
        else
          print *,'Invalid precision specified in EigenMain; r8=',r8
          stop
        endif
      else
        print *,'Invalid purpose in EigenMain; purpose=',purpose
        stop
      endif

      call Reorder (evectrs, evalues, nk, purpose(1:1) )

      call Normalize (evectrs, weights, nk)

      if (testvalue > 0.d0) then
         call CheckEigen (matrix, evectrs, evalues, nk, name, testvalue )
         if ( purpose(2:2) == 'S' ) then
           call CheckOrtho (evectrs, weights, nk, name, testvalue)
         endif
      endif

      if ( ( purpose(2:2) == 'S') .and. (purpose(3:3) == 'I' ) ) then
        call Inverse ( matrixR, evectrs, evalues, nk, name )
        if (testvalue > 0.d0) then
          call CheckInverse (matrixR, matrix, nk, name, testvalue)
        endif
      endif
!

      end subroutine eigen_main
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine Reorder (evectrs,evalues,nk,cv)
!
!  Reorder eigenvalues and corresponding eigenvectors from largest
!  eigenvalue to smallest.
!
      character(len=*), intent(in)  :: cv
      integer, intent(in)  :: nk
      real(r8), intent(inout)  :: evectrs(nk,nk)
      real(r8), intent(inout)  :: evalues(nk)
!
      integer  :: k, kx,i
      real(r8) :: copy, emax
!
      do k=1,nk-1
        emax=-1.e-30
        do i=k,nk
          if (evalues(i).gt.emax) then
            emax=evalues(i)
            kx=i
          endif
        enddo
        copy=evalues(kx)
        evalues(kx)=evalues(k)
        evalues(k)=copy
        if (cv(1:1) == 'V') then
          do i=1,nk
            copy=evectrs(i,kx)
            evectrs(i,kx)=evectrs(i,k)
            evectrs(i,k)=copy
          enddo
        endif
      enddo
!
      end subroutine reorder

!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine CheckOrtho (evectrs, weights, nk, name, testvalue )
!
! Check whether vectors are orthogonal
!
      character(len=*), intent(in) :: name
      integer,  intent(in) :: nk
      real(r8), intent(in) :: evectrs(nk,nk)
      real(r8), intent(in) :: weights(nk)
      real(r8), intent(in) :: testvalue
!
      integer   :: i, j, k
      real(r8)  :: sum
!
      do i=1,nk
        do j=1,nk
          sum=0.d0
          if ( i==j ) sum=-1.d0
          do k=1,nk
            sum=sum+evectrs(k,i)*evectrs(k,j)*weights(k)
          enddo
          if ( abs(sum) > testvalue ) then
              print *,' CheckOrtho fails for ',name,' i,j,sum = ',i,j,sum
          endif
        enddo
      enddo

      end subroutine CheckOrtho
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine Normalize (evectrs, weights, nk)
!
!  Normalize each eigenvector such that the sum of its squared
!  components times corresonding weight is 1
!
      integer,  intent(in)    :: nk
      real(r8), intent(in)    :: weights(nk)
      real(r8), intent(inout) :: evectrs(nk,nk)
!
      integer  :: k, i
      real(r8) :: sum

      do k=1,nk
        sum=0.d0
        do i=1,nk
          sum=sum+evectrs(i,k)*evectrs(i,k)
        enddo
        sum=1./sqrt(sum)
        evectrs(:,k)=evectrs(:,k)*sum
      enddo
!
      end subroutine normalize
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine CheckEigen (matrix, evectrs, evalues, nk, name, &
                             testvalue)

      character(len=*), intent(in) :: name
      integer,  intent(in) :: nk
      real(r8), intent(in) :: matrix(nk,nk)
      real(r8), intent(in) :: evectrs(nk,nk)
      real(r8), intent(in) :: evalues(nk)
      real(r8), intent(in) :: testvalue
!
      integer  :: i, j, k
      real(r8) :: vmax, dmax, work

!
      do k=1,nk
        vmax=0.
        dmax=0.
        do j=1,nk
          work=-evectrs(j,k)*evalues(k)
          if (abs(work).gt.vmax) vmax=abs(work)
          do i=1,nk
            work=work+matrix(j,i)*evectrs(i,k)
          enddo
          if (abs(work).gt.dmax) dmax=abs(work)
        enddo
        if (dmax.gt.vmax*testvalue) print *,'CheckEigen', &
                                    name,' ',k,dmax,vmax
      enddo
!
      end subroutine CheckEigen
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine Inverse ( matrixR, evectrs, evalues, nk, name )

      character(len=*), intent(in) :: name
      integer,  intent(in)  :: nk
      real(r8), intent(in)  :: evectrs(nk,nk)
      real(r8), intent(in)  :: evalues(nk)
      real(r8), intent(out) :: matrixR(nk,nk)

      integer               :: i, j, k
      real                  :: minvalue
!
! Invert symmetric matrix using eigenvalues
!

      minvalue=1.e30
      do i=1,nk
        if (abs(evalues(i)) < minvalue) minvalue=abs(evalues(i))
      enddo
      if (minvalue < 1.d-30) then
        print *,'matrix has eigenvalues as abs values as low as ',minvalue
        print *,'inverse not computed'
        stop
      endif

      do k=1,nk
        do j=1,nk
          matrixR(k,j)=0.d0
          do i=1,nk
            matrixR(k,j)=matrixR(k,j)+evectrs(k,i)*evectrs(j,i) &
                         /evalues(i)
          enddo
        enddo
      enddo
!
      end subroutine Inverse
!
!  X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X X
!
      Subroutine CheckInverse (matrixR, matrix, nk, name, testvalue)
      character(len=*), intent(in) :: name
      integer,  intent(in)  :: nk
      real(r8), intent(in)  :: testvalue
      real(r8), intent(in)  :: matrixR(nk,nk)
      real(r8), intent(in)  :: matrix(nk,nk)

      integer               :: i, j, k
      real(r8)              :: cmax1, cmax2, cmax, s
!
! check inverse of matrix
!
      cmax1=0.
      cmax2=0.
      do k=1,nk
        do j=1,nk
          if (cmax1.lt.abs( matrix(j,k))) cmax1=abs( matrix(j,k))
          if (cmax2.lt.abs(matrixR(j,k))) cmax2=abs(matrixR(j,k))
        enddo
      enddo
      cmax=cmax1*cmax2*nk*testvalue
!
      do k=1,nk
        do j=1,nk
          if (k.eq.j) then
            s=-1.d0
          else
            s=0.d0
          endif
          do i=1,nk
            s=s+matrixR(k,i)*matrix(i,j)
          enddo
          if (abs(s) > cmax) print *,'CheckInverse Failed ',name,' ' &
                            ,k,j,s,cmax
        enddo
      enddo
!
      end subroutine CheckInverse

      end module m_eigen


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

program optimization

  use forlab, only: IPRE, RPRE, CLEN, split_argument, num2str, rng
  use benchmark_functions, only: BenchmarkFunction
  use stochoptim, only: Evolutionary
#ifdef do_mpi
  use mpi
#endif

  implicit none

  ! Inputs
  integer(kind = IPRE) :: n_dim, popsize, max_iter, seed, verbose
  real(kind = RPRE) :: w, c1, c2, gamma, F, CR, sigma, mu_perc
  character(len = :), allocatable :: solver, strategy, func

  ! Local variables
  character(len = 18) :: attributes
  type(Evolutionary) :: ea
  type(BenchmarkFunction) :: bf

  ! MPI variables
  integer(kind = IPRE) :: master = 0, rank, ierr, iprv

  ! Initialize MPI
#ifdef do_mpi
  call mpi_init_thread(mpi_thread_funneled, iprv, ierr)
  call mpi_comm_rank(mpi_comm_world, rank, ierr)
#else
  rank = 0
#endif

  ! Read command line arguments
  call command_arguments()

  ! Initialize random number generator
  if ( seed .ge. 0 ) then
    call rng(seed)
  else
    call rng()
  end if

  ! Optimize
  bf = BenchmarkFunction(func, n_dim)
  ea = Evolutionary(bf % func, bf % lower, bf % upper, &
                    popsize = popsize, max_iter = max_iter, &
                    constrain = .true., snap = .false., verbose = verbose)

  call ea % optimize(&
    solver = solver, &
    w = w, &
    c1 = c1, &
    c2 = c2, &
    gamma = gamma, &
    F = F, &
    CR = CR, &
    strategy = strategy, &
    sigma = sigma, &
    mu_perc = mu_perc)

  ! Display results
  if ( rank .eq. master ) then
    print *
    attributes = "function:"
    print *, adjustr(attributes) // " '" // trim(func) // "'"
    call ea % print()
    print *
  end if

#ifdef do_mpi
  call mpi_finalize(ierr)
#endif

contains

  subroutine command_arguments()
    integer(kind = IPRE) :: i, n_argin
    character(len = CLEN) :: argin
    character(len = :), allocatable :: argname, argval

    solver = "cpso"
    func = "sphere"
    n_dim = 2
    popsize = 16
    w = 0.7298
    c1 = 1.49618
    c2 = 1.49618
    gamma = 1.
    F = 0.5
    CR = 0.1
    strategy = "rand1"
    sigma = 0.5
    mu_perc = 0.5
    max_iter = 200
    seed = -1
    verbose = 0

    n_argin = command_argument_count()
    do i = 1, n_argin
      call get_command_argument(i, argin)
      call split_argument(argin, argname, argval)

      select case(argname)
      ! Number of dimensions
      case("n_dim")
        read(argval, *) n_dim

      ! Solver
      case("solver")
        solver = argval

      ! Function
      case("func")
        func = argval

      ! Population size
      case("popsize")
        read(argval, *) popsize

      ! Inertia weight
      case("w")
        read(argval, *) w

      ! Cognition parameter
      case("c1")
        read(argval, *) c1

      ! Sociability parameter
      case("c2")
        read(argval, *) c2

      ! Competitivity parameter
      case("gamma")
        read(argval, *) gamma

      ! Differential weight
      case("F")
        read(argval, *) F

      ! Crossover probability
      case("CR")
        read(argval, *) CR

      ! Strategy
      case("strategy")
        strategy = argval

      ! Step size
      case("sigma")
        read(argval, *) sigma

      ! Percentage of offsprings
      case("mu_perc")
        read(argval, *) mu_perc

      ! Maximum number of iterations
      case("max_iter")
        read(argval, *) max_iter

      ! Random number seed
      case("seed")
        read(argval, *) seed

      ! Verbosity
      case("verbose")
        read(argval, *) verbose

      case default
        print *, "Error: unknown argument '" // trim(argname) // "'"
        stop
      end select
    end do
    return
  end subroutine command_arguments

end program optimization


*DECK DGEFA
      SUBROUTINE DGEFA (A, LDA, N, IPVT, INFO)
C***BEGIN PROLOGUE  DGEFA
C***PURPOSE  Factor a matrix using Gaussian elimination.
C***CATEGORY  D2A1
C***TYPE      DOUBLE PRECISION (SGEFA-S, DGEFA-D, CGEFA-C)
C***KEYWORDS  GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGEFA factors a double precision matrix by Gaussian elimination.
C
C     DGEFA is usually called by DGECO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for DGECO) = (1 + 9/N)*(Time for DGEFA) .
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DGESL or DGEDI will divide by zero
C                     if called.  Use  RCOND  in DGECO for a reliable
C                     indication of singularity.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL, IDAMAX
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGEFA
      INTEGER LDA,N,IPVT(*),INFO
      DOUBLE PRECISION A(LDA,*)
C
      DOUBLE PRECISION T
      INTEGER IDAMAX,J,K,KP1,L,NM1
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
C***FIRST EXECUTABLE STATEMENT  DGEFA
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = IDAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (A(L,K) .EQ. 0.0D0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/A(K,K)
            CALL DSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL DAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
*DECK DGESL
      SUBROUTINE DGESL (A, LDA, N, IPVT, B, JOB)
C***BEGIN PROLOGUE  DGESL
C***PURPOSE  Solve the real system A*X=B or TRANS(A)*X=B using the
C            factors computed by DGECO or DGEFA.
C***CATEGORY  D2A1
C***TYPE      DOUBLE PRECISION (SGESL-S, DGESL-D, CGESL-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGESL solves the double precision system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by DGECO or DGEFA.
C
C     On Entry
C
C        A       DOUBLE PRECISION(LDA, N)
C                the output from DGECO or DGEFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C        IPVT    INTEGER(N)
C                the pivot vector from DGECO or DGEFA.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B  where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically this indicates singularity
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if DGECO has set RCOND .GT. 0.0
C        or DGEFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL DGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGESL
      INTEGER LDA,N,IPVT(*),JOB
      DOUBLE PRECISION A(LDA,*),B(*)
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,NM1
C***FIRST EXECUTABLE STATEMENT  DGESL
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE  L*Y = B
C
         IF (NM1 .LT. 1) GO TO 30
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .EQ. K) GO TO 10
               B(L) = B(K)
               B(K) = T
   10       CONTINUE
            CALL DAXPY(N-K,T,A(K+1,K),1,B(K+1),1)
   20    CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/A(K,K)
            T = -B(K)
            CALL DAXPY(K-1,T,A(1,K),1,B(1),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            T = DDOT(K-1,A(1,K),1,B(1),1)
            B(K) = (B(K) - T)/A(K,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (NM1 .LT. 1) GO TO 90
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + DDOT(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
*DECK DGBFA
      SUBROUTINE DGBFA (ABD, LDA, N, ML, MU, IPVT, INFO)
C***BEGIN PROLOGUE  DGBFA
C***PURPOSE  Factor a band matrix using Gaussian elimination.
C***CATEGORY  D2A2
C***TYPE      DOUBLE PRECISION (SGBFA-S, DGBFA-D, CGBFA-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGBFA factors a double precision band matrix by elimination.
C
C     DGBFA is usually called by DGBCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                contains the matrix in band storage.  The columns
C                of the matrix are stored in the columns of  ABD  and
C                the diagonals of the matrix are stored in rows
C                ML+1 through 2*ML+MU+1 of  ABD .
C                See the comments below for details.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C                LDA must be .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C                0 .LE. ML .LT.  N .
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C                0 .LE. MU .LT.  N .
C                More efficient if  ML .LE. MU .
C     On Return
C
C        ABD     an upper triangular matrix in band storage and
C                the multipliers which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that DGBSL will divide by zero if
C                     called.  Use  RCOND  in DGBCO for a reliable
C                     indication of singularity.
C
C     Band Storage
C
C           If  A  is a band matrix, the following program segment
C           will set up the input.
C
C                   ML = (band width below the diagonal)
C                   MU = (band width above the diagonal)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX(1, J-MU)
C                      I2 = MIN(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           This uses rows  ML+1  through  2*ML+MU+1  of  ABD .
C           In addition, the first  ML  rows in  ABD  are used for
C           elements generated during the triangularization.
C           The total number of rows needed in  ABD  is  2*ML+MU+1 .
C           The  ML+MU by ML+MU  upper left triangle and the
C           ML by ML  lower right triangle are not referenced.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DSCAL, IDAMAX
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGBFA
      INTEGER LDA,N,ML,MU,IPVT(*),INFO
      DOUBLE PRECISION ABD(LDA,*)
C
      DOUBLE PRECISION T
      INTEGER I,IDAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
C***FIRST EXECUTABLE STATEMENT  DGBFA
      M = ML + MU + 1
      INFO = 0
C
C     ZERO INITIAL FILL-IN COLUMNS
C
      J0 = MU + 2
      J1 = MIN(N,M) - 1
      IF (J1 .LT. J0) GO TO 30
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0D0
   10    CONTINUE
   20 CONTINUE
   30 CONTINUE
      JZ = J1
      JU = 0
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 130
      DO 120 K = 1, NM1
         KP1 = K + 1
C
C        ZERO NEXT FILL-IN COLUMN
C
         JZ = JZ + 1
         IF (JZ .GT. N) GO TO 50
         IF (ML .LT. 1) GO TO 50
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0D0
   40       CONTINUE
   50    CONTINUE
C
C        FIND L = PIVOT INDEX
C
         LM = MIN(ML,N-K)
         L = IDAMAX(LM+1,ABD(M,K),1) + M - 1
         IPVT(K) = L + K - M
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (ABD(L,K) .EQ. 0.0D0) GO TO 100
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. M) GO TO 60
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
   60       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -1.0D0/ABD(M,K)
            CALL DSCAL(LM,T,ABD(M+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN(MAX(JU,MU+IPVT(K)),N)
            MM = M
            IF (JU .LT. KP1) GO TO 90
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .EQ. MM) GO TO 70
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
   70          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,ABD(MM+1,J),1)
   80       CONTINUE
   90       CONTINUE
         GO TO 110
  100    CONTINUE
            INFO = K
  110    CONTINUE
  120 CONTINUE
  130 CONTINUE
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0D0) INFO = N
      RETURN
      END
*DECK DGBSL
      SUBROUTINE DGBSL (ABD, LDA, N, ML, MU, IPVT, B, JOB)
C***BEGIN PROLOGUE  DGBSL
C***PURPOSE  Solve the real band system A*X=B or TRANS(A)*X=B using
C            the factors computed by DGBCO or DGBFA.
C***CATEGORY  D2A2
C***TYPE      DOUBLE PRECISION (SGBSL-S, DGBSL-D, CGBSL-C)
C***KEYWORDS  BANDED, LINEAR ALGEBRA, LINPACK, MATRIX, SOLVE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DGBSL solves the double precision band system
C     A * X = B  or  TRANS(A) * X = B
C     using the factors computed by DGBCO or DGBFA.
C
C     On Entry
C
C        ABD     DOUBLE PRECISION(LDA, N)
C                the output from DGBCO or DGBFA.
C
C        LDA     INTEGER
C                the leading dimension of the array  ABD .
C
C        N       INTEGER
C                the order of the original matrix.
C
C        ML      INTEGER
C                number of diagonals below the main diagonal.
C
C        MU      INTEGER
C                number of diagonals above the main diagonal.
C
C        IPVT    INTEGER(N)
C                the pivot vector from DGBCO or DGBFA.
C
C        B       DOUBLE PRECISION(N)
C                the right hand side vector.
C
C        JOB     INTEGER
C                = 0         to solve  A*X = B ,
C                = nonzero   to solve  TRANS(A)*X = B , where
C                            TRANS(A)  is the transpose.
C
C     On Return
C
C        B       the solution vector  X .
C
C     Error Condition
C
C        A division by zero will occur if the input factor contains a
C        zero on the diagonal.  Technically this indicates singularity
C        but it is often caused by improper arguments or improper
C        setting of LDA .  It will not occur if the subroutines are
C        called correctly and if DGBCO has set RCOND .GT. 0.0
C        or DGBFA has set INFO .EQ. 0 .
C
C     To compute  INVERSE(A) * C  where  C  is a matrix
C     with  P  columns
C           CALL DGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND is too small) GO TO ...
C           DO 10 J = 1, P
C              CALL DGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DAXPY, DDOT
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DGBSL
      INTEGER LDA,N,ML,MU,IPVT(*),JOB
      DOUBLE PRECISION ABD(LDA,*),B(*)
C
      DOUBLE PRECISION DDOT,T
      INTEGER K,KB,L,LA,LB,LM,M,NM1
C***FIRST EXECUTABLE STATEMENT  DGBSL
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .NE. 0) GO TO 50
C
C        JOB = 0 , SOLVE  A * X = B
C        FIRST SOLVE L*Y = B
C
         IF (ML .EQ. 0) GO TO 30
         IF (NM1 .LT. 1) GO TO 30
            DO 20 K = 1, NM1
               LM = MIN(ML,N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .EQ. K) GO TO 10
                  B(L) = B(K)
                  B(K) = T
   10          CONTINUE
               CALL DAXPY(LM,T,ABD(M+1,K),1,B(K+1),1)
   20       CONTINUE
   30    CONTINUE
C
C        NOW SOLVE  U*X = Y
C
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K)/ABD(M,K)
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL DAXPY(LM,T,ABD(LA,K),1,B(LB),1)
   40    CONTINUE
      GO TO 100
   50 CONTINUE
C
C        JOB = NONZERO, SOLVE  TRANS(A) * X = B
C        FIRST SOLVE  TRANS(U)*Y = B
C
         DO 60 K = 1, N
            LM = MIN(K,M) - 1
            LA = M - LM
            LB = K - LM
            T = DDOT(LM,ABD(LA,K),1,B(LB),1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C
C        NOW SOLVE TRANS(L)*X = Y
C
         IF (ML .EQ. 0) GO TO 90
         IF (NM1 .LT. 1) GO TO 90
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN(ML,N-K)
               B(K) = B(K) + DDOT(LM,ABD(M+1,K),1,B(K+1),1)
               L = IPVT(K)
               IF (L .EQ. K) GO TO 70
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
   70          CONTINUE
   80       CONTINUE
   90    CONTINUE
  100 CONTINUE
      RETURN
      END
*DECK XERRWD
      SUBROUTINE XERRWD (MSG, NMES, NERR, LEVEL, NI, I1, I2, NR, R1, R2)
C***BEGIN PROLOGUE  XERRWD
C***SUBSIDIARY
C***PURPOSE  Write error message with values.
C***CATEGORY  R3C
C***TYPE      DOUBLE PRECISION (XERRWV-S, XERRWD-D)
C***AUTHOR  Hindmarsh, Alan C., (LLNL)
C***DESCRIPTION
C
C  Subroutines XERRWD, XSETF, XSETUN, and the function routine IXSAV,
C  as given here, constitute a simplified version of the SLATEC error
C  handling package.
C
C  All arguments are input arguments.
C
C  MSG    = The message (character array).
C  NMES   = The length of MSG (number of characters).
C  NERR   = The error number (not used).
C  LEVEL  = The error level..
C           0 or 1 means recoverable (control returns to caller).
C           2 means fatal (run is aborted--see note below).
C  NI     = Number of integers (0, 1, or 2) to be printed with message.
C  I1,I2  = Integers to be printed, depending on NI.
C  NR     = Number of reals (0, 1, or 2) to be printed with message.
C  R1,R2  = Reals to be printed, depending on NR.
C
C  Note..  this routine is machine-dependent and specialized for use
C  in limited context, in the following ways..
C  1. The argument MSG is assumed to be of type CHARACTER, and
C     the message is printed with a format of (1X,A).
C  2. The message is assumed to take only one line.
C     Multi-line messages are generated by repeated calls.
C  3. If LEVEL = 2, control passes to the statement   STOP
C     to abort the run.  This statement may be machine-dependent.
C  4. R1 and R2 are assumed to be in double precision and are printed
C     in D21.13 format.
C
C***ROUTINES CALLED  IXSAV
C***REVISION HISTORY  (YYMMDD)
C   920831  DATE WRITTEN
C   921118  Replaced MFLGSV/LUNSAV by IXSAV. (ACH)
C   930329  Modified prologue to SLATEC format. (FNF)
C   930407  Changed MSG from CHARACTER*1 array to variable. (FNF)
C   930922  Minor cosmetic change. (FNF)
C***END PROLOGUE  XERRWD
C
C*Internal Notes:
C
C For a different default logical unit number, IXSAV (or a subsidiary
C routine that it calls) will need to be modified.
C For a different run-abort command, change the statement following
C statement 100 at the end.
C-----------------------------------------------------------------------
C Subroutines called by XERRWD.. None
C Function routine called by XERRWD.. IXSAV
C-----------------------------------------------------------------------
C**End
C
C  Declare arguments.
C
      DOUBLE PRECISION R1, R2
      INTEGER NMES, NERR, LEVEL, NI, I1, I2, NR
      CHARACTER*(*) MSG
C      CHARACTER(LEN=255) RMSG
C
C  Declare local variables.
C
C      INTEGER LUNIT, IXSAV, MESFLG
C
C  Get logical unit number and message print flag.
C
C***FIRST EXECUTABLE STATEMENT  XERRWD
C RJ 2011 - Write to R
C      LUNIT = IXSAV (1, 0, .FALSE.)
C      MESFLG = IXSAV (2, 0, .FALSE.)
C      IF (MESFLG .EQ. 0) GO TO 100
C
C  Write the message.
C
C      WRITE (LUNIT,10)  MSG
C 10   FORMAT(1X,A)
C      CALL DBLEPR(MSG,-1,0,0)
C      IF (NI .EQ. 1) THEN
C         WRITE (RMSG, 20) I1
C 20      FORMAT(6X,'In above message,  I1 =',I10)
C         CALL DBLEPR(RMSG,-1,0,0)
C      END IF
C      IF (NI .EQ. 2) THEN
C         WRITE (RMSG, 30) I1,I2
C 30      FORMAT(6X,'In above message,  I1 =',I10,3X,'I2 =',I10)
C         CALL DBLEPR(RMSG,-1,0,0)
C      END IF
C      IF (NR .EQ. 1) THEN
C         WRITE (RMSG, 40) R1
C 40      FORMAT(6X,'In above message,  R1 =',D21.13)
C         CALL DBLEPR(RMSG,-1,0,0)
C      END IF
C      IF (NR .EQ. 2) THEN
C         WRITE (RMSG, 50) R1,R2
C 50      FORMAT(6X,'In above,  R1 =',D21.13,3X,'R2 =',D21.13)
C         CALL DBLEPR(RMSG,-1,0,0)
C      END IF
C
C  Abort the run if LEVEL = 2.
C
 100  IF (LEVEL .NE. 2) RETURN
C      STOP
C----------------------- End of Subroutine XERRWD ----------------------
      END


!> Creates a `.w` file with hydrogenic wavefunctions.
program exporthydrogenic
    use, intrinsic :: iso_fortran_env, only: real64, dp => real64
    use grasptest_lib9290_setup
    use grasptest_lib9290_hydrogenic
    use orbout_I
    implicit none

    type(orbital_definition), parameter, dimension(*) :: orbitals = (/ &
        orbital_definition(1, -1), & ! 1s

        orbital_definition(2, -1), & ! 2s
        orbital_definition(2,  1), & ! 2p-
        orbital_definition(2, -2), & ! 2p

        orbital_definition(3, -1), & ! 3s
        orbital_definition(3,  1), & ! 3p-
        orbital_definition(3, -2), & ! 3p
        orbital_definition(3,  2), & ! 3d-
        orbital_definition(3, -3), & ! 3d

        orbital_definition(4, -1), & ! 4s
        orbital_definition(4,  1), & ! 4p-
        orbital_definition(4, -2), & ! 4p
        orbital_definition(4,  2), & ! 4d-
        orbital_definition(4, -3), & ! 4d
        orbital_definition(4,  3), & ! 4f-
        orbital_definition(4, -4), & ! 4f

        orbital_definition(5, -1), & ! 5s
        orbital_definition(5,  1), & ! 5p-
        orbital_definition(5, -2), & ! 5p
        orbital_definition(5,  2), & ! 5d-
        orbital_definition(5, -3), & ! 5d

        orbital_definition(6, -1)  & ! 6s
    /)

    logical :: tests_passed = .true.
    integer :: n, k, l, tmpk, tmpl
    real(real64) :: vp_value

    call setup(74.0_dp, 183.91033628717801_dp)
    call allocate_hydrogenic_orbitals(orbitals)
    call orbout("hydrogenic.w")

end program exporthydrogenic


! { dg-do run }
program nint_1
  if (int(anint(8388609.0)) /= 8388609) STOP 1
  if (int(anint(0.49999997)) /= 0) STOP 2
  if (nint(8388609.0) /= 8388609) STOP 3
  if (nint(0.49999997) /= 0) STOP 4
  if (int(dnint(4503599627370497.0d0),8) /= 4503599627370497_8) STOP 5
  if (int(dnint(0.49999999999999994d0)) /= 0) STOP 6
  if (int(anint(-8388609.0)) /= -8388609) STOP 7
  if (int(anint(-0.49999997)) /= 0) STOP 8
  if (nint(-8388609.0) /= -8388609) STOP 9
  if (nint(-0.49999997) /= 0) STOP 10
  if (int(dnint(-4503599627370497.0d0),8) /= -4503599627370497_8) STOP 11
  if (int(dnint(-0.49999999999999994d0)) /= 0) STOP 12
end program nint_1


! { dg-do  run }
! { dg-options "-fdump-tree-original" }
! Test that minloc and maxloc using KINDs return the right
! kind, by using unformatted I/O for a specific kind.
program main
  implicit none
  real, dimension(3) :: a
  integer :: r1, r2, r4, r8
  integer :: k
  character(len=30) :: l1, l2

  ! Check via I/O if the KIND is used correctly
  a = [ 1.0, 3.0, 2.0]
  write (unit=l1,fmt=*) 2_1
  write (unit=l2,fmt=*) maxloc(a,kind=1)
  if (l1 /= l2) STOP 1

  write (unit=l1,fmt=*) 2_2
  write (unit=l2,fmt=*) maxloc(a,kind=2)
  if (l1 /= l2) STOP 2

  write (unit=l1,fmt=*) 2_4
  write (unit=l2,fmt=*) maxloc(a,kind=4)
  if (l1 /= l2) STOP 3

  write (unit=l1,fmt=*) 2_8
  write (unit=l2,fmt=*) maxloc(a,kind=8)
  if (l1 /= l2) STOP 4

  a = [ 3.0, -1.0, 2.0]

  write (unit=l1,fmt=*) 2_1
  write (unit=l2,fmt=*) minloc(a,kind=1)
  if (l1 /= l2) STOP 5

  write (unit=l1,fmt=*) 2_2
  write (unit=l2,fmt=*) minloc(a,kind=2)
  if (l1 /= l2) STOP 6

  write (unit=l1,fmt=*) 2_4
  write (unit=l2,fmt=*) minloc(a,kind=4)
  if (l1 /= l2) STOP 7

  write (unit=l1,fmt=*) 2_8
  write (unit=l2,fmt=*) minloc(a,kind=8)
  if (l1 /= l2) STOP 8

end program main


!A class example showing passing different types to a subroutine
module bonk
    contains
    subroutine sumit(p)
        real(kind(0.0)), pointer :: r4(:,:),r3(:,:,:)
        complex(kind(0.0d0)), pointer :: r8(:,:)
        class(*), target :: p(:,:)
        select type (p)
            type is (real(kind(0.)))
                r4=>p
                write(*,'(f10.2)') p
                write(*,*)
                write(*,'(f10.2)') r4
            type is (complex(kind(0d0)))
                r8=>p
                write(*,'(2f10.2)') r8
                allocate(r3(2,4,4))
                do j=1,4
                    do i=1,4
                    ! if you use the normal real and imag conversions
                    ! the values will get truncated
                    r3(1,i,j)=dble(r8(i,j))
                    r3(2,i,j)=dimag(r8(i,j))
                    !write(*,'(2f10.2)') r3(:,i,j)
                    enddo
                enddo
                write(*,*)
                write(*,'(2f10.2)')r3
                deallocate(r3)
        end select
    end subroutine
end module

program test_ptr
    use bonk
    implicit none
    integer i,j,k
    real(kind(0.0)), target :: r4(4,4)
    ! note the complex in this case is 2 - 8 byte reals
    complex(kind(0.0d0)), target :: r8(4,4)
    class(*), pointer :: p(:,:)

    ! some assignments, etc.
    k=0
    do j=1,4
        do i=1,4
            k=k+1
            r4(i,j)=k
            r8(i,j)=dcmplx(k,-k)
        enddo
    enddo
    read(*,*)i
    do while (i > 0)
        if (i == 4) then
            p => r4
        else
            p => r8
        end if
    call sumit(p)
    read(*,*)i
    end do
end program


*DECK FIGI2
      SUBROUTINE FIGI2 (NM, N, T, D, E, Z, IERR)
C***BEGIN PROLOGUE  FIGI2
C***PURPOSE  Transforms certain real non-symmetric tridiagonal matrix
C            to symmetric tridiagonal matrix.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4C1C
C***TYPE      SINGLE PRECISION (FIGI2-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     Given a NONSYMMETRIC TRIDIAGONAL matrix such that the products
C     of corresponding pairs of off-diagonal elements are all
C     non-negative, and zero only when both factors are zero, this
C     subroutine reduces it to a SYMMETRIC TRIDIAGONAL matrix
C     using and accumulating diagonal similarity transformations.
C
C     On INPUT
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, T and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrix T.  N is an INTEGER variable.
C          N must be less than or equal to NM.
C
C        T contains the nonsymmetric matrix.  Its subdiagonal is
C          stored in the last N-1 positions of the first column,
C          its diagonal in the N positions of the second column,
C          and its superdiagonal in the first N-1 positions of
C          the third column.  T(1,1) and T(N,3) are arbitrary.
C          T is a two-dimensional REAL array, dimensioned T(NM,3).
C
C     On OUTPUT
C
C        T is unaltered.
C
C        D contains the diagonal elements of the tridiagonal symmetric
C          matrix.  D is a one-dimensional REAL array, dimensioned D(N).
C
C        E contains the subdiagonal elements of the tridiagonal
C          symmetric matrix in its last N-1 positions.  E(1) is not set.
C          E is a one-dimensional REAL array, dimensioned E(N).
C
C        Z contains the diagonal transformation matrix produced in the
C          symmetrization.  Z is a two-dimensional REAL array,
C          dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          N+I        if T(I,1)*T(I-1,3) is negative,
C          2*N+I      if T(I,1)*T(I-1,3) is zero with one factor
C                     non-zero.  In these cases, there does not exist
C                     a symmetrizing similarity transformation which
C                     is essential for the validity of the later
C                     eigenvector computation.
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  FIGI2
C
      INTEGER I,J,N,NM,IERR
      REAL T(NM,3),D(*),E(*),Z(NM,*)
      REAL H
C
C***FIRST EXECUTABLE STATEMENT  FIGI2
      IERR = 0
C
      DO 100 I = 1, N
C
         DO 50 J = 1, N
   50    Z(I,J) = 0.0E0
C
         IF (I .EQ. 1) GO TO 70
         H = T(I,1) * T(I-1,3)
         IF (H) 900, 60, 80
   60    IF (T(I,1) .NE. 0.0E0 .OR. T(I-1,3) .NE. 0.0E0) GO TO 1000
         E(I) = 0.0E0
   70    Z(I,I) = 1.0E0
         GO TO 90
   80    E(I) = SQRT(H)
         Z(I,I) = Z(I-1,I-1) * E(I) / T(I-1,3)
   90    D(I) = T(I,2)
  100 CONTINUE
C
      GO TO 1001
C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
C                ELEMENTS IS NEGATIVE ..........
  900 IERR = N + I
      GO TO 1001
C     .......... SET ERROR -- PRODUCT OF SOME PAIR OF OFF-DIAGONAL
C                ELEMENTS IS ZERO WITH ONE MEMBER NON-ZERO ..........
 1000 IERR = 2 * N + I
 1001 RETURN
      END


	PROGRAM MHD
C
C	DATA VS,VA /1.76,1.00/		! cs>va for nice, ratio to Va
	DATA VS,VA /0.80,1.00/		! va>cs for nice, ratio to Va
C
C	THE FOLLOWING MAKES A TABLE FOR PLOTTING USING MHD.MGO
C
	XMAX = 0.
	YMAX = 0.
	DO N = 1,91
	  THETA = N-1
	  COSTH = COSD(THETA)
	  CALL MHDDISPER(VS,VA,COSTH,XN12,XN22,XN32,V1,V2,V3)
	  X1 = V1*SIND(THETA)
	  Y1 = V1*COSD(THETA)
	  X2 = V2*SIND(THETA)
	  Y2 = V2*COSD(THETA)
	  X3 = V3*SIND(THETA)
	  Y3 = V3*COSD(THETA)
	  XMAX = AMAX1(XMAX,X1,X2,X3)
	  YMAX = AMAX1(YMAX,Y1,Y2,Y3)
	  WRITE(77,1077) X1,Y1,X2,Y2,X3,Y3
 1077	  FORMAT(6E12.4)
	ENDDO
	PRINT*,'XMAX,YMAX',XMAX,YMAX
C
	STOP
	END
	SUBROUTINE MHDDISPER(VS,VA,COSTH,XN12,XN22,XN32,V1,V2,V3)
C
C	I GOT THIS FROM EQ. 3-33, PAGE 66, OF SPITZER, PHYSICS OF FULLY
C		IONIZED GASES, 2ND ED.
C	XN1 IS INDEX OF REFRACTION OF ALFVEN WAVE.
C	XN2
C	XN3
C
	IF(COSTH.NE.0.) THEN
	  V1 = VA*COSTH
	  XN12 = 1./V1**2
	  COMMONF = (VA**2 + VS**2)/(VA*VS)**2/COSTH**2
	  DISC = 1.- 4.*(VA*VS*COSTH)**2/(VA**2 + VS**2)*2
	  IF(DISC.GE.0.) THEN
	    DISC = SQRT(DISC)
	  ELSE
	    DISC = 0.
	  ENDIF
	  XN22 = COMMONF*(1. + DISC)
	  XN32 = COMMONF*(1. - DISC)
	ELSE
	  V1 = 0.
	ENDIF
C
C	I GOT THIS FROM EQS 22 AND 23, P 38 OF WEITZNER'S ARTICLE IN
C		BASIC PLASMA PHYSICS, SELECTED CHAPTERS
C	V1 IS THE SPEED OF THE ALFVEN WAVE.
C	V2 IS THE SLOW MODE
C	V3 IS THE FAST MODE
C
	IF(COSTH.NE.0.) THEN
	  V1 = VA*COSTH
	  XN12 = 1./V1**2
	  COMMONF = (VA**2 + VS**2)
	  DISC = COMMONF**2 - 4.*(VA*VS*COSTH)**2
	  IF(DISC.GE.0.) THEN
	    DISC = SQRT(DISC)
	  ELSE
	    DISC = 0.
	  ENDIF
	  V22 = .5*(COMMONF - DISC)
	  V2 = SQRT(AMAX1(V22,0.))
	  V32 = .5*(COMMONF + DISC)
	  V3 = SQRT(AMAX1(V32,0.))
	ELSE
	  V1 = 0.
	  V2 = 0.
	  V3 = SQRT(VA**2 + VS**2)
	ENDIF
	RETURN
	END


program example1

  implicit none

  real :: d
  real :: x1
  real :: x2
  real :: t1
  real :: t2
  real :: v1, v2, s1, s2, x
  equivalence (v1, s1)
  equivalence (v2, s2)

  common x1, x2

  d = 1.0
  x1 = 0.0
  x2 = 0.4
  t1 = 20.0
  t2 = 10.0

  v1 = (d - x1) / t1
  v2 = (d - x2) / t2

  call intersect (s1, s2, x)

  !write (*,'(F8.3, A, F8.3, A, F8.3)'), v1, ' ', v2, ' ', x
  print *, v1, ' ', v2, ' ', x

  contains

   subroutine intersect(s1, s2, x)

      real :: s1, s2
      real :: y1
      real :: y2
      real :: t_i, x

      common y1, y2

      t_i = (y1 - y2)/(s2 - s1)

      x = s1 * t_i
   end subroutine

end program


SUBROUTINE p116(input_file,output_file)
!-------------------------------------------------------------------------
! Program 11.6 Forced vibration analysis of an elastic solid in plane
!              strain using rectangular uniform size 4-node quadrilaterals.
!              Mesh numbered in the x- or y-direction. Lumped and/or
!              consistent mass. Mixed explicit/implicit time integration.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=60),INTENT(IN) :: input_file
 CHARACTER(len=60),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,j,iel,k,ndim=2,ndof=8,nels,neq,nip=4,nlen,nn,nod=4,nodof=2,   &
   npri,nprops=3,np_types,nr,nres,nstep,nxe,nye
 REAL(iwp)::area,beta,c1,det,dtim,gamma,one=1.0_iwp,pt5=0.5_iwp,time,     &
   two=2.0_iwp,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag_l(:),       &
   kdiag_r(:),nf(:,:),num(:)
 REAL(iwp),ALLOCATABLE::coord(:,:),der(:,:),d1x0(:),d1x1(:),d2x0(:),      &
   d2x1(:),ecm(:,:),fun(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),mm(:,:),   &
   mv(:),points(:,:),prop(:,:),weights(:),x0(:),x1(:),x_coords(:),        &
   y_coords(:)
   CHARACTER(LEN=1),ALLOCATABLE::mtype(:)
!-----------------------input and initialisation--------------------------
 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nxe,nye,np_types
 CALL mesh_size(element,nod,nels,nn,nxe,nye)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof),g_coord(ndim,nn),         &
   coord(nod,ndim),jac(ndim,ndim),weights(nip),der(ndim,nod),             &
   km(ndof,ndof),num(nod),g_num(nod,nels),g_g(ndof,nels),mtype(nels),     &
   mm(ndof,ndof),ecm(ndof,ndof),fun(nod),prop(nprops,np_types),           &
   x_coords(nxe+1),y_coords(nye+1),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)READ(10,*)etype
 READ(10,*)x_coords,y_coords,dtim,nstep,beta,gamma,npri,nres
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag_l(neq),kdiag_r(neq),x0(0:neq),d1x0(0:neq),x1(0:neq),      &
   d2x0(0:neq),d1x1(0:neq),d2x1(0:neq))
 READ(10,*)mtype
 CALL sample(element,points,weights)
 kdiag_l=0
 kdiag_r=0
!-----------------------loop the elements to find global array sizes------
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,x_coords,y_coords,coord,num,'y')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag_r,g)
   IF(mtype(iel)=='c')CALL fkdiag(kdiag_l,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 WHERE(kdiag_l==0)
   kdiag_l=1
 END WHERE
 DO i=2,neq
   kdiag_l(i)=kdiag_l(i)+kdiag_l(i-1)
   kdiag_r(i)=kdiag_r(i)+kdiag_r(i-1)
 END DO
 ALLOCATE(kv(kdiag_l(neq)),mv(kdiag_r(neq)))
 WRITE(11,'(A,I5,A,/,2(A,I5),A)')                                         &
   " There are",neq," equations."," Skyline storage is",kdiag_l(neq),     &
   " to the left, and",kdiag_r(neq)," to the right."
 c1=one/dtim/dtim/beta
 kv=zero
 mv=zero
!-----------------------global stiffness and mass matrix assembly---------
 elements_2: DO iel=1,nels
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   CALL stiff4(km,coord,prop(1,etype(iel)),prop(2,etype(iel)))
   g=g_g(:,iel)
   area=zero
   mm=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     area=area+det*weights(i)
     CALL shape_fun(fun,points,i)
     IF(mtype(iel)=='c')THEN
       CALL ecmat(ecm,fun,ndof,nodof)
       mm=mm+ecm*det*weights(i)*c1*prop(3,etype(iel))
     END IF
   END DO gauss_pts_1
   IF(mtype(iel)=='l')THEN
     CALL elmat(area,c1*prop(3,etype(iel)),mm)
     CALL fsparv(kv,mm,g,kdiag_l)
     CALL fsparv(mv,mm-km,g,kdiag_r)
   ELSE
     CALL fsparv(kv,km+mm,g,kdiag_l)
     CALL fsparv(mv,mm,g,kdiag_r)
   END IF
 END DO elements_2
!-----------------------initial conditions and factorise equations--------
 x0=zero
 d1x0=one
 d2x0=zero
 CALL sparin(kv,kdiag_l)
 time=zero
!-----------------------time stepping loop--------------------------------
 WRITE(11,'(/A,I5)')" Result at node",nres
 WRITE(11,'(A)')"    time        x-disp      y-disp"
 WRITE(11,'(4E12.4)')time,x0(nf(:,nres))
 timesteps: DO j=1,nstep
   time=time+dtim
   d1x1=x0+d1x0*dtim+d2x0*pt5*dtim*dtim*(one-two*beta)
   CALL linmul_sky(mv,d1x1,x1,kdiag_r)
   CALL spabac(kv,x1,kdiag_l)
   d2x1=(x1-d1x1)/dtim/dtim/beta
   d1x1=d1x0+d2x0*dtim*(one-gamma)+d2x1*dtim*gamma
   x0=x1
   d1x0=d1x1
   d2x0=d2x1
   IF(j/npri*npri==j)WRITE(11,'(4E12.4)')time,x0(nf(:,nres))
 END DO timesteps

END SUBROUTINE p116