PROGRAM test_smplx
!     Test the F90 version of the NSWC routine SMPLX.

USE constants_NSWC
IMPLICIT NONE
INTEGER                :: n, pos, i, constr_type(9), m, ind, ibasis(9), iter, &
                          mxiter = 25, numle, numge, j
CHARACTER (LEN=79)     :: text, in_text
REAL (dp)              :: a(9,9), b(9), c(9), x(9), z, temp(9), rerr
REAL (dp), ALLOCATABLE :: bi(:,:)

INTERFACE
  SUBROUTINE smplx (a, b0, c, ka, m, n0, ind, ibasis, x, z, iter, mxiter,   &
                    numle, numge, bi, rerr)
    USE constants_NSWC
    IMPLICIT NONE
    INTEGER, INTENT(IN)                    :: ka, m, n0, mxiter, numle, numge
    INTEGER, INTENT(IN OUT)                :: ind
    INTEGER, DIMENSION(:), INTENT(IN OUT)  :: ibasis
    INTEGER, INTENT(OUT)                   :: iter
    REAL (dp), DIMENSION(:,:), INTENT(IN)  :: a
    REAL (dp), DIMENSION(:), INTENT(IN)    :: b0, c
    REAL (dp), INTENT(OUT)                 :: z, rerr
    REAL (dp), DIMENSION(:), INTENT(OUT)   :: x
    REAL (dp), DIMENSION(:,:), INTENT(OUT) :: bi
  END SUBROUTINE smplx
END INTERFACE

WRITE(*, *) 'How many variables? (<=9): '
READ(*, *) n
IF (n > 9) STOP 'Too many!'

WRITE(*, *) 'Enter constraint coefficients incl. constr. type (<=, >= or =)'
WRITE(*, *) 'Press ENTER again after the last constraint'
text = ' '
DO i = 1, n
  pos = 8*i-6
  WRITE(text(pos:pos+3), '("X(", i1, ")")') i
END DO
text(pos+4:pos+11) = 'Con.type'
text(pos+13:pos+15) = 'RHS'
WRITE(*, '(a)') text
WRITE(*, *)
numle = 0
numge = 0
DO i = 1, 9
  READ(*, '(a)') in_text
  IF (LEN_TRIM(in_text) == 0) EXIT
  READ(in_text, *) a(i,1:n)
  pos = INDEX(in_text, '=')
  IF (pos == 0) THEN
    STOP 'You must enter the constraint type (<=, >= or =)'
  END IF
  IF (in_text(pos-1:pos-1) == '<') THEN
    constr_type(i) = 1
    numle = numle + 1
  ELSE IF (in_text(pos-1:pos-1) == '>') THEN
    constr_type(i) = 2
    numge = numge + 1
  ELSE
    constr_type(i) = 3
  END IF
  READ(in_text(pos+1:), *) b(i)
END DO

m = i - 1
ALLOCATE( bi(m,m) )

!     Re-order the constraints if necessary
DO i = 1, numle
  IF (constr_type(i) /= 1) THEN
    DO j = numle+1, m
      IF (constr_type(j) == 1) THEN
        temp(1:n) = a(i, 1:n)
        a(i, 1:n) = a(j, 1:n)
        a(j, 1:n) = temp(1:n)
        z = b(i)
        b(i) = b(j)
        b(j) = z
        constr_type(j) = constr_type(i)
        constr_type(i) = 1
        EXIT
      END IF
    END DO
  END IF
END DO
DO i = numle+1, numle+numge
  IF (constr_type(i) /= 2) THEN
    DO j = numle+numge+1, m
      IF (constr_type(j) == 2) THEN
        temp(1:n) = a(i, 1:n)
        a(i, 1:n) = a(j, 1:n)
        a(j, 1:n) = temp(1:n)
        z = b(i)
        b(i) = b(j)
        b(j) = z
        constr_type(j) = constr_type(i)
        constr_type(i) = 2
        EXIT
      END IF
    END DO
  END IF
END DO

!     Enter the coefficients in the objective function.
WRITE(*, *) 'Enter the coefficients (costs) in the objective to be maximized'
pos = 8*n-2
text(pos:) = ' '
WRITE(*, '(a)') text
WRITE(*, *)
READ(*, '(a)') in_text
READ(in_text, *) c(1:n)

CALL smplx (a, b, c, 9, m, n, ind, ibasis, x, z, iter, mxiter,   &
            numle, numge, bi, rerr)

WRITE(*, '(a, i2, a, i3)') ' IND = ', ind, '  No. of iterations = ', iter
IF (ind == 0 .OR. i== 6) THEN
  WRITE(*, '(a, 9f7.2)') ' Solution: ', x(1:n)
  WRITE(*, '(a, f8.2)') ' Value of objective = ', z
  WRITE(*, *) 'The inverse matrix:'
  DO i = 1, m
    WRITE(*, '(9f8.3)') bi(i,1:m)
  END DO
END IF

WRITE(*, '(a, g12.4)') ' Relative error = ', rerr

STOP
END PROGRAM test_smplx


module calculate
use math
use geom_utils
use divide
implicit none

private
public :: triangle_area
public :: cp_lengths, cp_net_areas
public :: arc_length_bezier, surface_area_bezier

contains

function triangle_area(m, tri) result(area)
    !> Calculate the area of a triangle.
    !> m - Number columns in triangle array.
    !> tri - Triangle array.
    !> area - Area of triangle.

    ! Input
    integer, intent(in) :: m
    double precision, intent(in) :: tri(3, m)

    ! Output
    double precision :: area

    ! Working
    double precision :: mag
    double precision :: v1(m), v2(m), vc(m)

    v1 = tri(2, :) - tri(1, :)
    v2 = tri(3, :) - tri(1, :)

    vc = cross(v1, v2)
    mag = norm(vc)
    area = 0.50d0 * mag

end function triangle_area

subroutine cp_lengths(n, cp, lp, lc)
    !> Calculate the linear length of the control polygon and its chord.
    !> n - Number of control points - 1.
    !> cp - Dehomogenized control points.
    !> lp - Length of control polygon.
    !> lc - Chord length.

    !f2py intent(in) n, cp
    !f2py intent(out) lp, lc
    !f2py depend(n) cp

    ! Input
    integer, intent(in) :: n

    ! Output
    double precision, intent(out) :: lp, lc
    double precision, intent(in) :: cp(0:n, 0:2)

    ! Working
    integer :: i
    double precision :: vec(0:2)

    vec = cp(n, :) - cp(0, :)
    lc = norm(vec)
    lp = 0.0d0
    do i = 0, n - 1
        vec = cp(i + 1, :) - cp(i, :)
        lp = lp + norm(vec)
    end do

end subroutine cp_lengths

subroutine cp_net_areas(n, m, cp, anet, ap)
    !> Calculate the surface areas of the control net.
    !> n - Number of control points - 1 in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> cp - Dehomogenized control points.
    !> anet - Area of control net.
    !> ap - Area of the plane formed by the four corners of the
    !> control net.

    !f2py intent(in) n, m, cp
    !f2py intent(out) anet, ap
    !f2py depend(n, m) cp

    ! Input
    integer, intent(in) :: n, m
    double precision, intent(in) :: cp(0:n, 0:m, 0:2)

    ! Output
    double precision, intent(out) :: anet, ap

    ! Working
    integer :: i, ntri
    integer :: triangles(0:2 * n * m - 1, 0:2)
    double precision :: v1(0:2), v2(0:2), v3(0:2)
    double precision :: verts(0:(n + 1) * (m + 1) - 1, 0:2)
    double precision :: c1(0:2), c2(0:2), c3(0:2)

    call tessellate_cp_net(n, m, cp, verts, triangles)
    ntri = size(triangles, 1)
    anet = 0.0d0
    do i = 0, ntri - 1
        v1 = verts(triangles(i, 0), :)
        v2 = verts(triangles(i, 1), :)
        v3 = verts(triangles(i, 2), :)
        c1 = v2 - v1
        c2 = v3 - v1
        c3 = cross(c1, c2)
        anet = anet + 0.50d0 * norm(c3)
    end do
    c1 = cp(n, 0, :) - cp(0, 0, :)
    c2 = cp(n, m, :) - cp(0, 0, :)
    c3 = cross(c1, c2)
    ap = 0.50d0 * norm(c3)
    c1 = cp(n, m, :) - cp(0, 0, :)
    c2 = cp(0, m, :) - cp(0, 0, :)
    c3 = cross(c1, c2)
    ap = ap + 0.50d0 * norm(c3)
end subroutine cp_net_areas

recursive subroutine arc_length_bezier(n, cpw, u0, u1, tol, l)
    !> Estimate the arc length of a Bezier curve.
    !> n - Number of control points - 1.
    !> cpw - Control points.
    !> u0 - Starting parameter.
    !> u1 - Ending parameter.
    !> tol - Tolerance for comparing control polygon length and chord
    !> length.
    !> l - Approximate arc length.

    !f2py intent(in) n, cpw, tol, u0, u1
    !f2py intent(in,out) l
    !f2py depend(n) cpw

    ! Input
    integer, intent(in) :: n
    double precision, intent(in) :: u0, u1, tol
    double precision, intent(in) :: cpw(0:n, 0:3)

    ! Input/Output
    double precision, intent(inout) :: l(1)

    ! Working
    integer :: i
    double precision :: lp, lc, a1, b1, a2, b2
    double precision :: cp(0:n, 0:2)
    double precision :: qw1(0:n, 0:3), qw2(0:n, 0:3)
    double precision :: temp2(0:n, 0:3), w(0:n)

    ! Extract curve if needed
    if ((u0 .gt. 0.0d0) .or. (u1 .lt. 1.0d0)) then
        call extract_bezier_curve(cpw, n, u0, u1, 0.0d0, 1.0d0, temp2, a1, b1)
    else
        temp2 = cpw
    end if

    call dehomogenize_array1d(n, temp2, cp, w)
    call cp_lengths(n, cp, lp, lc)

    if (dabs(lp - lc) .le. tol) then
        l(1) = l(1) + (2.0d0 * lc + (dble(n) - 1.0d0) * lp) / (dble(n) + 1.0d0)
    else
        call split_bezier_curve(temp2, n, 0.50d0, 0.0d0, 1.0d0, qw1, a1, b1, &
                                qw2, a2, b2)
        call arc_length_bezier(n, qw1, 0.0d0, 1.0d0, tol, l)
        call arc_length_bezier(n, qw2, 0.0d0, 1.0d0, tol, l)
    end if

end subroutine arc_length_bezier

recursive subroutine surface_area_bezier(n, m, cpw, tol, a)
    !> Estimate the surface area of a Bezier surface.
    !> n - Number of control points - 1 in u-direction.
    !> m - Number of control points - 1 in v-direction.
    !> cpw - Control points.
    !> tol - Tolerance for comparing area of control net to area of
    !> base area of formed by the four corners of the control net.
    !> a - Approximate area of surface.

    !f2py intent(in) n, m, cpw, tol
    !f2py intent(in,out) a
    !f2py depend(n, m) cpw

    ! Input
    integer, intent(in) :: n, m
    double precision, intent(in) :: tol
    double precision, intent(in) :: cpw(0:n, 0:m, 0:3)

    ! Input/Output
    double precision, intent(inout) :: a(1)

    integer :: i
    double precision :: ap, anet
    double precision :: cp(0:n, 0:m, 0:2)
    double precision :: qw1(0:n, 0:m, 0:3), qw2(0:n, 0:m, 0:3)
    double precision :: qw3(0:n, 0:m, 0:3), qw4(0:n, 0:m, 0:3)
    double precision :: qw5(0:n, 0:m, 0:3), qw6(0:n, 0:m, 0:3)
    double precision :: w(0:n, 0:m)
    double precision :: ab1(0:1, 0:1), ab2(0:1, 0:1)

    call dehomogenize_array2d(n, m, cpw, cp, w)
    call cp_net_areas(n, m, cp, anet, ap)

    if (abs(anet - ap) .le. tol) then
        a(1) = a(1) + (4.0d0 * ap + dble(n + m + n * m - 3) * anet) / &
               dble((n + 1) * (m + 1))
    else
        call split_bezier_surface(cpw, n, m, 0.50d0, -1.0d0, &
                                  0.0d0, 1.0d0, 0.0d0, 1.0d0, &
                                  qw1, qw2, ab1, ab2)
        call split_bezier_surface(qw1, n, m, -1.0d0, 0.50d0, &
                                  0.0d0, 1.0d0, 0.0d0, 1.0d0, &
                                  qw3, qw4, ab1, ab2)
        call split_bezier_surface(qw2, n, m, -1.0d0, 0.50d0, &
                                  0.0d0, 1.0d0, 0.0d0, 1.0d0, &
                                  qw5, qw6, ab1, ab2)
        call surface_area_bezier(n, m, qw3, tol, a)
        call surface_area_bezier(n, m, qw4, tol, a)
        call surface_area_bezier(n, m, qw5, tol, a)
        call surface_area_bezier(n, m, qw6, tol, a)
    end if

end subroutine surface_area_bezier

end module calculate


	FUNCTION PR_THWC  ( pres, tmpc, dwpc )
C************************************************************************
C* PR_THWC								*
C*									*
C* This subroutine computes wet bulb potential temperature in Celsius	*
C* from PRES, TMPC and DWPC.  The result is obtained by first		*
C* computing THTE of the the air parcel at level PRES.  Then the air	*
C* parcel is brought to 1000 mb moist adiabatically to get THWC.	*
C*									*
C* REAL PR_THWC  ( PRES, TMPC, DWPC )					*
C*									*
C* Input parameters:							*
C*	PRES   		REAL   		Pressure in millibars		*
C*	TMPC		REAL		Temperature in Celsius		*
C*	DWPC   		REAL		Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_THWC		REAL   		Wet bulb potential temp in C	*
C**									*
C* Log:									*
C* T. Lee/GSC		11/97						*
C* T. Lee/GSC		12/97	Added missing PR_THWC checks		*
C************************************************************************
        INCLUDE   	'GEMPRM.PRM'
        INCLUDE   	'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing values.
C
	IF  ( ERMISS ( pres ) .or. ERMISS ( tmpc ) .or.
     +	      ERMISS ( dwpc ) .or. ( pres .le. 0. ) )  THEN
	    PR_THWC = RMISSD
	    RETURN
	  ELSE
C
C*	    Find THTE.
C
	    thte = PR_THTE  ( pres, tmpc, dwpc )
	END IF
C
C*	Check for missing THTE and compute wet bulb temperature.
C
	IF  ( ERMISS ( thte ) )  THEN
	    PR_THWC = RMISSD
	  ELSE
	    tg      = 0.
	    p1000   = 1000.
	    PR_THWC = PR_TMST ( thte, p1000, tg )
	    IF  ( .not. ERMISS ( PR_THWC ) )  PR_THWC = PR_THWC - TMCK
	END IF
C*
	RETURN
	END


C
C $Id: rbglen.f,v 1.12 2008-09-18 00:42:18 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      DOUBLE PRECISION FUNCTION RBGLEN (RLAT)
C
        DOUBLE PRECISION RLAT
C
C The value of RBGLEN(RLAT) is the length of the parallel at latitude
C RLAT, stated as a fraction of the length of the equator.
C
C Declare local variables.
C
        DOUBLE PRECISION FLAT,PLEN(19)
C
        INTEGER          ILAT
C
C Define the contents of PLEN per the definition of the Robinson
C projection.  The values are associated with values of latitude from
C 0 North to 90 North at five-degree intervals.
C
        DATA PLEN( 1) / 1.0000D0 /
        DATA PLEN( 2) / 0.9986D0 /
        DATA PLEN( 3) / 0.9954D0 /
        DATA PLEN( 4) / 0.9900D0 /
        DATA PLEN( 5) / 0.9822D0 /
        DATA PLEN( 6) / 0.9730D0 /
        DATA PLEN( 7) / 0.9600D0 /
        DATA PLEN( 8) / 0.9427D0 /
        DATA PLEN( 9) / 0.9216D0 /
        DATA PLEN(10) / 0.8962D0 /
        DATA PLEN(11) / 0.8679D0 /
        DATA PLEN(12) / 0.8350D0 /
        DATA PLEN(13) / 0.7986D0 /
        DATA PLEN(14) / 0.7597D0 /
        DATA PLEN(15) / 0.7186D0 /
        DATA PLEN(16) / 0.6732D0 /
        DATA PLEN(17) / 0.6213D0 /
        DATA PLEN(18) / 0.5722D0 /
        DATA PLEN(19) / 0.5322D0 /
C
C Determine where the parallel of interest lies relative to the ones
C represented in the tables (between the ones associated with elements
C ILAT and ILAT+1 and a fractional distance FLAT from the former to the
C latter).
C
        ILAT=MAX(1,MIN(18,INT(1.D0+ABS(RLAT)/5.D0)))
C
        FLAT=1.D0+ABS(RLAT)/5.D0-DBLE(ILAT)
C
C Return the desired value.
C
        RBGLEN=(1.D0-FLAT)*PLEN(ILAT)+FLAT*PLEN(ILAT+1)
C
C Done.
C
        RETURN
C
      END


! vim: set ft=fortran sw=4 ts=4:

program tsunami

    ! Tsunami simulator
    !
    ! This version solves the linearized 1-d advection equation:
    !
    !   du/dt = - u du/dx - g dh/dx
    !
    !   dh/dt = -d(hu)/dx
    !

    use iso_fortran_env, only: int32, real32, output_unit
    use mod_diff, only: diff => diffc

    implicit none

    integer(int32) :: i, n

    integer(int32), parameter :: im = 100 ! grid size in x
    integer(int32), parameter :: nm = 5000 ! number of time steps

    real(real32), parameter :: dt = 0.02 ! time step [s]
    real(real32), parameter :: dx = 1 ! grid spacing [m]

    real(real32), parameter :: g = 9.81 ! gravitational accelration (m/s^2)

    real(real32), dimension(im) :: h, hmean, u

    ! initial position & shape of blob
    integer(int32), parameter :: ipos = 25
    real(real32), parameter :: decay = 0.02

    ! initialize a gaussian blob centered at i = ipos = 25
    do i = 1, im
        h(i) = exp(-decay * (i - ipos)**2)
    end do

    ! set initial speed to zero
    u = 0

    ! set mean water height to 10 m
    hmean = 10

    ! write initial state to screen
    write(output_unit, *) 0, h

    time_loop: do n = 1, nm

        ! update u at next time step
        u = u - (u * diff(u) + g * diff(h)) / dx * dt

        ! update h at next time step
        h = h - diff(u * (hmean + h)) / dx * dt

        ! write output state to screen
        write(output_unit, *) n, h

    end do time_loop

end program tsunami


      SUBROUTINE STGREC(X,Y,Z,DZ,NP, TRIANG,NT, Bdry, MB, XYLIM,NX,NY,
     * ZFILL, ZVALS, MX, MY, NCONT, WANTPD, DZVALS )
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1997-07-01 STGREC Krogh Reversed subscripts in B (CLL suggestion)
c>> 1997-06-18 STGREC CLL Added arguments Bdry and MB.
C>> 1996-02-02 STGREC CLL
C>> 1996-01-11 STGREC CLL
C>> 1995-11-03 STGREC CLL Added argument, NCONT.
C>> 1995-09-26 STGREC CLL Editing for inclusion into MATH77.
c  This subr builds a rectangular array of Z values by interpo-
c  lation in a triangular grid.  The subr will use either C0 or C1
c  interpolation methods, depending on the setting of NCONT = 0 or 1.
c  Optionally this subr also builds a rectangular array of values of
c  first partial derivatives.
c     CLL, 1979 JUNE 12, MINOR CHANGES.
c     C.L.LAWSON, JPL, 1976 DEC 8.  ADDED PARTIAL DERIVS 1977 MAR 3.
c     ------------------------------------------------------------------
C                      Subroutine arguments
c
c     All args are of intent IN except ZVALS() and DZVALS() which are
c     of intent OUT.  The contents of DZ() are only used when NCONT = 1.
c
c  X(),Y(),Z() [floating,in] NP sets of (X,Y,Z) data.
C
c  (DZ(I,J),I=1,2),J=1,NP) [floating,in] Partial derivs of Z w.r.t.
c     X and Y.  The contents of this array are only used when NCONT = 1,
c     not when NCONT = 0.
C
c  NP [integer,in]  No. of data points.
c
c  TRIANG(1:6*NT),NT [integer,in]  TRIANG() contains pointers (integers)
c     describing the triangular grid.  NT is the number of triangles.
c     Each triangle requires 6 pointers.
c
c  Bdry(1:4, MB) [integer, in]  Array containing pointers defining the
c      boundary of the (convex) triangular grid.
c
c  MB [integer, in]  Dimension parameter for Bdry() array.
C
c  XYLIM(1:4) [floating,in]  Contains XMIN, XMAX, YMIN, and YMAX
c     specifying boundaries of the rectangular grid.
c
c  NX,NY [integer, in] NO. OF X AND Y GRID LINES IN RECTANGULAR GRID.
C
c  ZFILL [floating, in]  Selects action to be taken when a node of the
c     rectangular grid is outside the (convex) triangular grid.
c     If ZFILL = 0.0, extrapolated values will be provided by this
c     package.
c     If ZFILL .ne. 0.0, this subroutine will store ZFILL into ZVALS()
c     and DZVALS() for locations outside the triangular grid.
c
c  ZVALS(,) [floating,out]  MX BY MY ARRAY IN WHICH THE NX BY NY SET OF
c     INTERPOLATED VALUES WILL BE STORED.
c
c  MX,MY [integer, in] DIMENSIONS OF THE ARRAYS ZVALS( , ) AND
c     DZVALS( , ,2)
C
c  NCONT [integer,in]  Order of continuity of interpolation method to be
c     used.
c     0 selects a C0 method.  This method uses linear interpolation over
c     each triangle.  The function value is continuous across the whole
c     grid but generally the 1st partial derivatives are discontinuous
c     across boundaries between triangles.
c     1 selects a C1 method.  This method partitions each triangle into
c     3 smaller triangles and constructs a bicubic patch over each of
c     the smaller triangles.  The function value and 1st partial deriv-
c     atives are continuous across the whole grid but generally the 2nd
c     and higher order partial derivatives are discontinuous across
c     boundaries between the original triangles and between the small
c     triangles.
c
c  WANTPD [logical, in] User sets = .true. if partial derivs are
c     desired, and .false. otherwise.
C
c  DZVALS(,,) [floating,out]  MX by NY by 2 array in which the
c     NX by NY by 2 set of partial derivatives will be stored if
c     WANTPD = .TRUE.
c     In the case of NCONT = 0, the interpolation function does not
c     generally have a partial derivative at points on the boundary
c     between two triangles.  For such points this subr will return the
c     1st partial derivatives associated with one of the adjoining
c     triangles.
c     ------------------------------------------------------------------
c--S replaces "?": ?TGREC, ?TGFI
c     ------------------------------------------------------------------
      integer mxwrk
      parameter(mxwrk = 28)
      integer MB, mx, my, np
        integer Bdry(4, MB)
      integer i, ix, iy
      integer mode, NCONT, NT, nx, ny, TRIANG(1:*)
      real             DELX, DELY, DZ(2,NP), DZOUT(2), DZVALS(MX,MY,2)
      real             SVWRK0(mxwrk), SVWRK1(mxwrk)
      real             X(NP), XY(2), XYLIM(4), Y(NP)
      real             Z(NP), zero, ZFILL, ZVALS(MX,MY)
        parameter(zero=0.0e0)
      logical FIRST, WANTPD
c     ------------------------------------------------------------------
      DELX = (XYLIM(2)-XYLIM(1)) / (NX-1)
      DELY = (XYLIM(4)-XYLIM(3)) / (NY-1)
      do 10 i = 1,mxwrk
         svwrk0(i) = zero
   10 continue
C
c        XY(1) AND XY(2) WILL BE SET SUCCESSIVELY TO THE (X,Y) COORDS
c        OF EACH POINT OF THE RECTANGULAR GRID.
c        When NCONT .eq. 0, the values of the 1st derivatives are
c        constant within each triangle.  Thus in the case of
c        NCONT .eq. 0 and WANTDZ being true, we only need to compute the
c        partial derivatives when NEWTRI is true.
C
      XY(2) = XYLIM(3)
      DO 60 IY=1,NY
         do 20 i = 1,mxwrk
            svwrk1(i) = svwrk0(i)
   20    continue
         FIRST = .true.
         XY(1) = XYLIM(1)
         DO 50 IX=1,NX
            call STGFI( X, Y, Z, DZ, TRIANG, NT, Bdry, MB,
     *            NCONT, XY, ZVALS(IX,IY), WANTPD, DZOUT, MODE, SVWRK1)
            IF(FIRST) then
               do 30 i = 1,mxwrk
                  svwrk0(i) = svwrk1(i)
   30          continue
               FIRST = .false.
            endif

            IF (MODE .EQ. 0) THEN
c
c                  0 means XY was found within the triangular grid.
c
                IF (WANTPD) THEN
                  DZVALS(IX,IY,1)=DZOUT(1)
                  DZVALS(IX,IY,2)=DZOUT(2)
                END IF
            ELSEif(mode .eq. 1) then
c
c                  1 MEANS XY IS OUTSIDE THE TRIANGULAR GRID.
c                  Will use extrapolated value if ZFILL .eq. zero.
c                  Otherwise set results to the ZFILL
c
               if(ZFILL .eq. zero) then
                  IF (WANTPD) THEN
                     DZVALS(IX,IY,1)=DZOUT(1)
                     DZVALS(IX,IY,2)=DZOUT(2)
                  ENDIF
                 else
                  ZVALS(IX,IY) = ZFILL
                  IF (WANTPD) THEN
                     DZVALS(IX,IY,1)=ZFILL
                     DZVALS(IX,IY,2)=ZFILL
                  ENDIF
                 endif
              else
c
c                 Mode = 2 MEANS CYCLING HAS HAPPENED IN the lookup
c                 process.  This should not happen.
c                 ERROR MESSAGE WILL BE PRINTED FROM _TGFI.
C
               ZVALS(IX,IY) = ZFILL
               IF (WANTPD) THEN
                  DZVALS(IX,IY,1)=ZFILL
                  DZVALS(IX,IY,2)=ZFILL
               ENDIF
            ENDIF
C
            XY(1) = XY(1) + DELX
   50    continue
         XY(2) = XY(2) + DELY
   60 continue
      RETURN
      END


!*****************************************************************************************
!> author: Jacob Williams
!
!  Complex-step differentiation routines.
!
!# See also
!  1. J.R.R.A. Martins, P. Sturdza, J.J. Alonso,
!     "The Complex-Step Derivative Approximation",
!     ACM Transactions on Mathematical Software,
!     Vol. 29, No. 3, September 2003, Pages 245262.

    module complex_step_module

    use kind_module,    only: wp

    implicit none

    private

    interface
        function func(x) result(f)
        import :: wp
        implicit none
        complex(wp),intent(in) :: x
        complex(wp) :: f
        end function func
    end interface

    public :: complex_step_derivative
    public :: complex_step_test  !for testing

    contains
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the first derivative using the complex-step method.
!  This is Equation 6 from Reference [1].

    subroutine complex_step_derivative(f,x,h,dfdx)

    implicit none

    procedure(func)        :: f
    complex(wp),intent(in) :: x
    real(wp),intent(in)    :: h
    real(wp),intent(out)   :: dfdx

    dfdx = AIMAG(f(cmplx(real(x,wp),AIMAG(x)+h,wp)))/h

    end subroutine complex_step_derivative
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the first derivative using a forward difference.
!  This is Equation 1 from Reference [1].

    subroutine forward_diff(f,x,h,dfdx)

    implicit none

    procedure(func)        :: f
    complex(wp),intent(in) :: x
    real(wp),intent(in)    :: h
    real(wp),intent(out)   :: dfdx

    dfdx = (f(x+h) - f(x)) / h

    end subroutine forward_diff
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the first derivative using a 2-point central difference [-h,h].

    subroutine central_diff(f,x,h,dfdx)

    implicit none

    procedure(func)        :: f
    complex(wp),intent(in) :: x
    real(wp),intent(in)    :: h
    real(wp),intent(out)   :: dfdx

    dfdx = (f(x+h) - f(x-h)) / (2.0_wp*h)

    end subroutine central_diff
!*****************************************************************************************

!*****************************************************************************************
!>
!  Compute the first derivative using a 4-point central difference [-2h,-h,h,2h].

    subroutine central_diff_4(f,x,h,dfdx)

    implicit none

    procedure(func)        :: f
    complex(wp),intent(in) :: x
    real(wp),intent(in)    :: h
    real(wp),intent(out)   :: dfdx

    real(wp) :: h2

    h2 = 2.0_wp * h

    dfdx = (f(x-h2) - 8.0_wp*f(x-h) + 8.0_wp*f(x+h) - f(x+h2)) / (12.0_wp*h)

    end subroutine central_diff_4
!*****************************************************************************************

!*****************************************************************************************
!>
!  Unit test for the complex_step module.

    subroutine complex_step_test()

    implicit none

    integer     :: i
    complex(wp) :: x
    real(wp)    :: h,dfdx,dfdx2,dfdx3,dfdx4,err,err2,err3,err4

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' complex_step_test'
    write(*,*) '---------------'
    write(*,*) ''

    x = cmplx(2.0_wp,0.0_wp,wp)
    h = 1.0e-10_wp

    call complex_step_derivative(test_func,x,h,dfdx)

    !write(*,*) ''
    !write(*,*) 'x     :',x
    !write(*,*) 'dfdx  :',dfdx
    !write(*,*) 'error :',real(test_deriv(x),wp) - dfdx
    !write(*,*) ''

    write(*,'(*(A30))') 'h', 'forward diff err', 'central diff err', 'central diff 4 err', 'complex step err'

    do i=1,200
        h = 10.0_wp**(-i/10.0_wp)
        call complex_step_derivative(test_func,x,h,dfdx)
        call forward_diff(test_func,x,h,dfdx2)
        call central_diff(test_func,x,h,dfdx3)
        call central_diff_4(test_func,x,h,dfdx4)
        err  = real(test_deriv(x),wp) - dfdx
        err2 = real(test_deriv(x),wp) - dfdx2
        err3 = real(test_deriv(x),wp) - dfdx3
        err4 = real(test_deriv(x),wp) - dfdx4
        write(*,'(*(E30.16,1X))') h, err2, err3, err4, err
    end do

    contains
!*****************************************************************************************

    !****************************************
        function test_func(x) result(f)

        implicit none

        complex(wp),intent(in) :: x
        complex(wp) :: f

        f = exp(x) + sin(x)

        end function test_func
    !****************************************

    !****************************************
        function test_deriv(x) result(f)

        implicit none

        complex(wp),intent(in) :: x
        complex(wp) :: f

        f = exp(x) + cos(x)

        end function test_deriv
    !****************************************

    end subroutine complex_step_test
!*****************************************************************************************

!*****************************************************************************************
    end module complex_step_module
!*****************************************************************************************


program buffon_needles
    implicit none
    real, parameter :: PI = acos(-1.0)
    integer, parameter :: nr_needles_default = 100
    real, parameter :: line_dist_default = 2.0
    real, parameter :: needle_len = 2.0
    integer :: nr_needles = nr_needles_default
    real :: line_dist = line_dist_default
    !> @brief a needle's position is represented by the x-coordinate of its
    !>        midpoint, and the angle theta
    type :: needle_t
        real :: x, theta
        real :: len = needle_len
    end type
    type(needle_t) :: needle
    integer :: i, nr_hits

    call get_command_line_values(nr_needles, line_dist)
    call check_distance_acceptable(line_dist, needle_len)
    nr_hits = 0
    do i = 1, nr_needles
        needle = drop_needle(line_dist)
        if (is_needle_crossing(needle, line_dist)) then
            nr_hits = nr_hits + 1
        end if
    end do
    print '(A, F15.7)', 'probability          = ', real(nr_hits)/real(nr_needles)
    print '(A, F15.7)', 'expected probability = ', 2.0*needle_len/(PI*line_dist)

contains

    !> @brief handle command line arguments
    !>
    !> @param[inout] nr_needles number of needles to drop
    !> @param[inout] line_dist distance between the lines on the page
    subroutine get_command_line_values(nr_needles, line_dist)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, intent(inout) :: nr_needles
        real, intent(inout) :: line_dist
        character(len=1024) :: buffer, iomsg
        integer :: iostat

        if (command_argument_count() > 0) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iomsg=iomsg, iostat=iostat) nr_needles
            if (iostat /= 0) then
                write (unit=error_unit, fmt='(A)') iomsg
                stop 1
            end if
        end if
        if (command_argument_count() > 1) then
            call get_command_argument(2, buffer)
            read (buffer, fmt=*, iomsg=iomsg, iostat=iostat) line_dist
            if (iostat /= 0) then
                write (unit=error_unit, fmt='(A)') iomsg
                stop 1
            end if
        end if
    end subroutine get_command_line_values

    !> @brief check whether the distance between the lines on paper is
    !>        acceptable
    !>
    !> The subroutine verifies the distance between the lines on the page, if
    !> that is not adequate, it will print an error message and exit the
    !> application.
    !>
    !> @param[in] line_dist distance between lines on the page
    !> @param[in] needle_len length of a needle
    subroutine check_distance_acceptable(line_dist, needle_len)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        real, value :: line_dist, needle_len

        if (line_dist < needle_len) then
            write (unit=error_unit, fmt='(A, F4.2)') &
                'error: the distance between the lines must be larger than the needle length', &
                needle_len
           stop 2
       end if
    end subroutine check_distance_acceptable

    !> @brief drop a needle on the plain
    !>
    !> Due to symmetry arbuments, the midpoint is restricted to fall between
    !> zero and half of the distance between two lines, for similar reasons,
    !> theta will fall between zero and pi/2
    !>
    !> @param[in] line_dist distance between two lines on the paper
    !> @returns a random needle position
    function drop_needle(line_dist) result(needle)
        implicit none
        real, value :: line_dist
        type(needle_t) :: needle
        real :: r

        call random_number(r)
        needle%x = 0.5*r*line_dist
        call random_number(r)
        needle%theta = 0.5*r*PI
    end function drop_needle

    !> @brief check whether a given needle crosses a line
    !>
    !> @param[in] needle needle position to check
    !> @param[in] line_dist distance between lines on the paper
    !> @returns .true. if the needle crosses a line, .false. otherwise
    function is_needle_crossing(needle, line_dist) result(does_cross)
        implicit none
        type(needle_t), intent(in) :: needle
        real, value :: line_dist
        logical :: does_cross

        does_cross = needle%x + 0.5*needle%len*cos(needle%theta) >= 0.5*line_dist
    end function is_needle_crossing

end program buffon_needles


*> \brief  CGESVDX computes the singular value decomposition (SVD) for GE matrices
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download CGESVDX + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
*  Definition:
*  ===========
*
*     SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
*    $                    IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
*    $                    LWORK, RWORK, IWORK, INFO )
*
*
*     .. Scalar Arguments ..
*      CHARACTER          JOBU, JOBVT, RANGE
*      INTEGER            IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
*      REAL               VL, VU
*     ..
*     .. Array Arguments ..
*     INTEGER            IWORK( * )
*     REAL               S( * ), RWORK( * )
*     COMPLEX            A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
*    $                   WORK( * )
*     ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*>  CGESVDX computes the singular value decomposition (SVD) of a complex
*>  M-by-N matrix A, optionally computing the left and/or right singular
*>  vectors. The SVD is written
*>
*>      A = U * SIGMA * transpose(V)
*>
*>  where SIGMA is an M-by-N matrix which is zero except for its
*>  min(m,n) diagonal elements, U is an M-by-M unitary matrix, and
*>  V is an N-by-N unitary matrix.  The diagonal elements of SIGMA
*>  are the singular values of A; they are real and non-negative, and
*>  are returned in descending order.  The first min(m,n) columns of
*>  U and V are the left and right singular vectors of A.
*>
*>  CGESVDX uses an eigenvalue problem for obtaining the SVD, which
*>  allows for the computation of a subset of singular values and
*>  vectors. See SBDSVDX for details.
*>
*>  Note that the routine returns V**T, not V.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] JOBU
*> \verbatim
*>          JOBU is CHARACTER*1
*>          Specifies options for computing all or part of the matrix U:
*>          = 'V':  the first min(m,n) columns of U (the left singular
*>                  vectors) or as specified by RANGE are returned in
*>                  the array U;
*>          = 'N':  no columns of U (no left singular vectors) are
*>                  computed.
*> \endverbatim
*>
*> \param[in] JOBVT
*> \verbatim
*>          JOBVT is CHARACTER*1
*>           Specifies options for computing all or part of the matrix
*>           V**T:
*>           = 'V':  the first min(m,n) rows of V**T (the right singular
*>                   vectors) or as specified by RANGE are returned in
*>                   the array VT;
*>           = 'N':  no rows of V**T (no right singular vectors) are
*>                   computed.
*> \endverbatim
*>
*> \param[in] RANGE
*> \verbatim
*>          RANGE is CHARACTER*1
*>          = 'A': all singular values will be found.
*>          = 'V': all singular values in the half-open interval (VL,VU]
*>                 will be found.
*>          = 'I': the IL-th through IU-th singular values will be found.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>          The number of rows of the input matrix A.  M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of columns of the input matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is COMPLEX array, dimension (LDA,N)
*>          On entry, the M-by-N matrix A.
*>          On exit, the contents of A are destroyed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] VL
*> \verbatim
*>          VL is REAL
*>          If RANGE='V', the lower bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] VU
*> \verbatim
*>          VU is REAL
*>          If RANGE='V', the upper bound of the interval to
*>          be searched for singular values. VU > VL.
*>          Not referenced if RANGE = 'A' or 'I'.
*> \endverbatim
*>
*> \param[in] IL
*> \verbatim
*>          IL is INTEGER
*>          If RANGE='I', the index of the
*>          smallest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[in] IU
*> \verbatim
*>          IU is INTEGER
*>          If RANGE='I', the index of the
*>          largest singular value to be returned.
*>          1 <= IL <= IU <= min(M,N), if min(M,N) > 0.
*>          Not referenced if RANGE = 'A' or 'V'.
*> \endverbatim
*>
*> \param[out] NS
*> \verbatim
*>          NS is INTEGER
*>          The total number of singular values found,
*>          0 <= NS <= min(M,N).
*>          If RANGE = 'A', NS = min(M,N); if RANGE = 'I', NS = IU-IL+1.
*> \endverbatim
*>
*> \param[out] S
*> \verbatim
*>          S is REAL array, dimension (min(M,N))
*>          The singular values of A, sorted so that S(i) >= S(i+1).
*> \endverbatim
*>
*> \param[out] U
*> \verbatim
*>          U is COMPLEX array, dimension (LDU,UCOL)
*>          If JOBU = 'V', U contains columns of U (the left singular
*>          vectors, stored columnwise) as specified by RANGE; if
*>          JOBU = 'N', U is not referenced.
*>          Note: The user must ensure that UCOL >= NS; if RANGE = 'V',
*>          the exact value of NS is not known in advance and an upper
*>          bound must be used.
*> \endverbatim
*>
*> \param[in] LDU
*> \verbatim
*>          LDU is INTEGER
*>          The leading dimension of the array U.  LDU >= 1; if
*>          JOBU = 'V', LDU >= M.
*> \endverbatim
*>
*> \param[out] VT
*> \verbatim
*>          VT is COMPLEX array, dimension (LDVT,N)
*>          If JOBVT = 'V', VT contains the rows of V**T (the right singular
*>          vectors, stored rowwise) as specified by RANGE; if JOBVT = 'N',
*>          VT is not referenced.
*>          Note: The user must ensure that LDVT >= NS; if RANGE = 'V',
*>          the exact value of NS is not known in advance and an upper
*>          bound must be used.
*> \endverbatim
*>
*> \param[in] LDVT
*> \verbatim
*>          LDVT is INTEGER
*>          The leading dimension of the array VT.  LDVT >= 1; if
*>          JOBVT = 'V', LDVT >= NS (see above).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is COMPLEX array, dimension (MAX(1,LWORK))
*>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*>          LWORK is INTEGER
*>          The dimension of the array WORK.
*>          LWORK >= MAX(1,MIN(M,N)*(MIN(M,N)+4)) for the paths (see
*>          comments inside the code):
*>             - PATH 1  (M much larger than N)
*>             - PATH 1t (N much larger than M)
*>          LWORK >= MAX(1,MIN(M,N)*2+MAX(M,N)) for the other paths.
*>          For good performance, LWORK should generally be larger.
*>
*>          If LWORK = -1, then a workspace query is assumed; the routine
*>          only calculates the optimal size of the WORK array, returns
*>          this value as the first entry of the WORK array, and no error
*>          message related to LWORK is issued by XERBLA.
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is REAL array, dimension (MAX(1,LRWORK))
*>          LRWORK >= MIN(M,N)*(MIN(M,N)*2+15*MIN(M,N)).
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*>          IWORK is INTEGER array, dimension (12*MIN(M,N))
*>          If INFO = 0, the first NS elements of IWORK are zero. If INFO > 0,
*>          then IWORK contains the indices of the eigenvectors that failed
*>          to converge in SBDSVDX/SSTEVX.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*>     INFO is INTEGER
*>           = 0:  successful exit
*>           < 0:  if INFO = -i, the i-th argument had an illegal value
*>           > 0:  if INFO = i, then i eigenvectors failed to converge
*>                 in SBDSVDX/SSTEVX.
*>                 if INFO = N*2 + 1, an internal error occurred in
*>                 SBDSVDX
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup complexGEsing
*
*  =====================================================================
      SUBROUTINE CGESVDX( JOBU, JOBVT, RANGE, M, N, A, LDA, VL, VU,
     $                    IL, IU, NS, S, U, LDU, VT, LDVT, WORK,
     $                    LWORK, RWORK, IWORK, INFO )
*
*  -- LAPACK driver routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*     .. Scalar Arguments ..
      CHARACTER          JOBU, JOBVT, RANGE
      INTEGER            IL, INFO, IU, LDA, LDU, LDVT, LWORK, M, N, NS
      REAL               VL, VU
*     ..
*     .. Array Arguments ..
      INTEGER            IWORK( * )
      REAL               S( * ), RWORK( * )
      COMPLEX            A( LDA, * ), U( LDU, * ), VT( LDVT, * ),
     $                   WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E0, 0.0E0 ),
     $                   CONE = ( 1.0E0, 0.0E0 ) )
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      CHARACTER          JOBZ, RNGTGK
      LOGICAL            ALLS, INDS, LQUERY, VALS, WANTU, WANTVT
      INTEGER            I, ID, IE, IERR, ILQF, ILTGK, IQRF, ISCL,
     $                   ITAU, ITAUP, ITAUQ, ITEMP, ITEMPR, ITGKZ,
     $                   IUTGK, J, K, MAXWRK, MINMN, MINWRK, MNTHR
      REAL               ABSTOL, ANRM, BIGNUM, EPS, SMLNUM
*     ..
*     .. Local Arrays ..
      REAL               DUM( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEBRD, CGELQF, CGEQRF, CLASCL, CLASET,
     $                   CUNMBR, CUNMQR, CUNMLQ, CLACPY,
     $                   SBDSVDX, SLASCL, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               SLAMCH, CLANGE
      EXTERNAL           LSAME, ILAENV, SLAMCH, CLANGE
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input arguments.
*
      NS = 0
      INFO = 0
      ABSTOL = 2*SLAMCH('S')
      LQUERY = ( LWORK.EQ.-1 )
      MINMN = MIN( M, N )

      WANTU = LSAME( JOBU, 'V' )
      WANTVT = LSAME( JOBVT, 'V' )
      IF( WANTU .OR. WANTVT ) THEN
         JOBZ = 'V'
      ELSE
         JOBZ = 'N'
      END IF
      ALLS = LSAME( RANGE, 'A' )
      VALS = LSAME( RANGE, 'V' )
      INDS = LSAME( RANGE, 'I' )
*
      INFO = 0
      IF( .NOT.LSAME( JOBU, 'V' ) .AND.
     $    .NOT.LSAME( JOBU, 'N' ) ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( JOBVT, 'V' ) .AND.
     $         .NOT.LSAME( JOBVT, 'N' ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( ALLS .OR. VALS .OR. INDS ) ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.GT.LDA ) THEN
         INFO = -7
      ELSE IF( MINMN.GT.0 ) THEN
         IF( VALS ) THEN
            IF( VL.LT.ZERO ) THEN
               INFO = -8
            ELSE IF( VU.LE.VL ) THEN
               INFO = -9
            END IF
         ELSE IF( INDS ) THEN
            IF( IL.LT.1 .OR. IL.GT.MAX( 1, MINMN ) ) THEN
               INFO = -10
            ELSE IF( IU.LT.MIN( MINMN, IL ) .OR. IU.GT.MINMN ) THEN
               INFO = -11
            END IF
         END IF
         IF( INFO.EQ.0 ) THEN
            IF( WANTU .AND. LDU.LT.M ) THEN
               INFO = -15
            ELSE IF( WANTVT ) THEN
               IF( INDS ) THEN
                   IF( LDVT.LT.IU-IL+1 ) THEN
                       INFO = -17
                   END IF
               ELSE IF( LDVT.LT.MINMN ) THEN
                   INFO = -17
               END IF
            END IF
         END IF
      END IF
*
*     Compute workspace
*     (Note: Comments in the code beginning "Workspace:" describe the
*     minimal amount of workspace needed at that point in the code,
*     as well as the preferred amount for good performance.
*     NB refers to the optimal block size for the immediately
*     following subroutine, as returned by ILAENV.)
*
      IF( INFO.EQ.0 ) THEN
         MINWRK = 1
         MAXWRK = 1
         IF( MINMN.GT.0 ) THEN
            IF( M.GE.N ) THEN
               MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 )
               IF( M.GE.MNTHR ) THEN
*
*                 Path 1 (M much larger than N)
*
                  MINWRK = N*(N+5)
                  MAXWRK = N + N*ILAENV(1,'CGEQRF',' ',M,N,-1,-1)
                  MAXWRK = MAX(MAXWRK,
     $                     N*N+2*N+2*N*ILAENV(1,'CGEBRD',' ',N,N,-1,-1))
                  IF (WANTU .OR. WANTVT) THEN
                     MAXWRK = MAX(MAXWRK,
     $                       N*N+2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1))
                  END IF
               ELSE
*
*                 Path 2 (M at least N, but not much larger)
*
                  MINWRK = 3*N + M
                  MAXWRK = 2*N + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1)
                  IF (WANTU .OR. WANTVT) THEN
                     MAXWRK = MAX(MAXWRK,
     $                        2*N+N*ILAENV(1,'CUNMQR','LN',N,N,N,-1))
                  END IF
               END IF
            ELSE
               MNTHR = ILAENV( 6, 'CGESVD', JOBU // JOBVT, M, N, 0, 0 )
               IF( N.GE.MNTHR ) THEN
*
*                 Path 1t (N much larger than M)
*
                  MINWRK = M*(M+5)
                  MAXWRK = M + M*ILAENV(1,'CGELQF',' ',M,N,-1,-1)
                  MAXWRK = MAX(MAXWRK,
     $                     M*M+2*M+2*M*ILAENV(1,'CGEBRD',' ',M,M,-1,-1))
                  IF (WANTU .OR. WANTVT) THEN
                     MAXWRK = MAX(MAXWRK,
     $                       M*M+2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1))
                  END IF
               ELSE
*
*                 Path 2t (N greater than M, but not much larger)
*
*
                  MINWRK = 3*M + N
                  MAXWRK = 2*M + (M+N)*ILAENV(1,'CGEBRD',' ',M,N,-1,-1)
                  IF (WANTU .OR. WANTVT) THEN
                     MAXWRK = MAX(MAXWRK,
     $                        2*M+M*ILAENV(1,'CUNMQR','LN',M,M,M,-1))
                  END IF
               END IF
            END IF
         END IF
         MAXWRK = MAX( MAXWRK, MINWRK )
         WORK( 1 ) = CMPLX( REAL( MAXWRK ), ZERO )
*
         IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
            INFO = -19
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGESVDX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 ) THEN
         RETURN
      END IF
*
*     Set singular values indices accord to RANGE='A'.
*
      IF( ALLS ) THEN
         RNGTGK = 'I'
         ILTGK = 1
         IUTGK = MIN( M, N )
      ELSE IF( INDS ) THEN
         RNGTGK = 'I'
         ILTGK = IL
         IUTGK = IU
      ELSE
         RNGTGK = 'V'
         ILTGK = 0
         IUTGK = 0
      END IF
*
*     Get machine constants
*
      EPS = SLAMCH( 'P' )
      SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = CLANGE( 'M', M, N, A, LDA, DUM )
      ISCL = 0
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ISCL = 1
         CALL CLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ISCL = 1
         CALL CLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
      END IF
*
      IF( M.GE.N ) THEN
*
*        A has at least as many rows as columns. If A has sufficiently
*        more rows than columns, first reduce A using the QR
*        decomposition.
*
         IF( M.GE.MNTHR ) THEN
*
*           Path 1 (M much larger than N):
*           A = Q * R = Q * ( QB * B * PB**T )
*                     = Q * ( QB * ( UB * S * VB**T ) * PB**T )
*           U = Q * QB * UB; V**T = VB**T * PB**T
*
*           Compute A=Q*R
*           (Workspace: need 2*N, prefer N+N*NB)
*
            ITAU = 1
            ITEMP = ITAU + N
            CALL CGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )
*
*           Copy R into WORK and bidiagonalize it:
*           (Workspace: need N*N+3*N, prefer N*N+N+2*N*NB)
*
            IQRF = ITEMP
            ITAUQ = ITEMP + N*N
            ITAUP = ITAUQ + N
            ITEMP = ITAUP + N
            ID = 1
            IE = ID + N
            ITGKZ = IE + N
            CALL CLACPY( 'U', N, N, A, LDA, WORK( IQRF ), N )
            CALL CLASET( 'L', N-1, N-1, CZERO, CZERO,
     $                   WORK( IQRF+1 ), N )
            CALL CGEBRD( N, N, WORK( IQRF ), N, RWORK( ID ),
     $                   RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ),
     $                   WORK( ITEMP ), LWORK-ITEMP+1, INFO )
            ITEMPR = ITGKZ + N*(N*2+1)
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*N*N+14*N)
*
            CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ),
     $                    RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S,
     $                    RWORK( ITGKZ ), N*2, RWORK( ITEMPR ),
     $                    IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               K = ITGKZ
               DO I = 1, NS
                  DO J = 1, N
                     U( J, I ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + N
               END DO
               CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU)
*
*              Call CUNMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL CUNMBR( 'Q', 'L', 'N', N, NS, N, WORK( IQRF ), N,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
*
*              Call CUNMQR to compute Q*(QB*UB).
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL CUNMQR( 'L', 'N', M, NS, N, A, LDA,
     $                      WORK( ITAU ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               K = ITGKZ + N
               DO I = 1, NS
                  DO J = 1, N
                     VT( I, J ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + N
               END DO
*
*              Call CUNMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL CUNMBR( 'P', 'R', 'C', NS, N, N, WORK( IQRF ), N,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
         ELSE
*
*           Path 2 (M at least N, but not much larger)
*           Reduce A to bidiagonal form without QR decomposition
*           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
*           U = QB * UB; V**T = VB**T * PB**T
*
*           Bidiagonalize A
*           (Workspace: need 2*N+M, prefer 2*N+(M+N)*NB)
*
            ITAUQ = 1
            ITAUP = ITAUQ + N
            ITEMP = ITAUP + N
            ID = 1
            IE = ID + N
            ITGKZ = IE + N
            CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ),
     $                   WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )
            ITEMPR = ITGKZ + N*(N*2+1)
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*N*N+14*N)
*
            CALL SBDSVDX( 'U', JOBZ, RNGTGK, N, RWORK( ID ),
     $                    RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S,
     $                    RWORK( ITGKZ ), N*2, RWORK( ITEMPR ),
     $                    IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               K = ITGKZ
               DO I = 1, NS
                  DO J = 1, N
                     U( J, I ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + N
               END DO
               CALL CLASET( 'A', M-N, NS, CZERO, CZERO, U( N+1,1 ), LDU)
*
*              Call CUNMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, IERR )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               K = ITGKZ + N
               DO I = 1, NS
                  DO J = 1, N
                     VT( I, J ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + N
               END DO
*
*              Call CUNMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need N, prefer N*NB)
*
               CALL CUNMBR( 'P', 'R', 'C', NS, N, N, A, LDA,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, IERR )
            END IF
         END IF
      ELSE
*
*        A has more columns than rows. If A has sufficiently more
*        columns than rows, first reduce A using the LQ decomposition.
*
         IF( N.GE.MNTHR ) THEN
*
*           Path 1t (N much larger than M):
*           A = L * Q = ( QB * B * PB**T ) * Q
*                     = ( QB * ( UB * S * VB**T ) * PB**T ) * Q
*           U = QB * UB ; V**T = VB**T * PB**T * Q
*
*           Compute A=L*Q
*           (Workspace: need 2*M, prefer M+M*NB)
*
            ITAU = 1
            ITEMP = ITAU + M
            CALL CGELQF( M, N, A, LDA, WORK( ITAU ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )

*           Copy L into WORK and bidiagonalize it:
*           (Workspace in WORK( ITEMP ): need M*M+3*M, prefer M*M+M+2*M*NB)
*
            ILQF = ITEMP
            ITAUQ = ILQF + M*M
            ITAUP = ITAUQ + M
            ITEMP = ITAUP + M
            ID = 1
            IE = ID + M
            ITGKZ = IE + M
            CALL CLACPY( 'L', M, M, A, LDA, WORK( ILQF ), M )
            CALL CLASET( 'U', M-1, M-1, CZERO, CZERO,
     $                   WORK( ILQF+M ), M )
            CALL CGEBRD( M, M, WORK( ILQF ), M, RWORK( ID ),
     $                   RWORK( IE ), WORK( ITAUQ ), WORK( ITAUP ),
     $                   WORK( ITEMP ), LWORK-ITEMP+1, INFO )
            ITEMPR = ITGKZ + M*(M*2+1)
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*M*M+14*M)
*
            CALL SBDSVDX( 'U', JOBZ, RNGTGK, M, RWORK( ID ),
     $                    RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S,
     $                    RWORK( ITGKZ ), M*2, RWORK( ITEMPR ),
     $                    IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               K = ITGKZ
               DO I = 1, NS
                  DO J = 1, M
                     U( J, I ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + M
               END DO
*
*              Call CUNMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL CUNMBR( 'Q', 'L', 'N', M, NS, M, WORK( ILQF ), M,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               K = ITGKZ + M
               DO I = 1, NS
                  DO J = 1, M
                     VT( I, J ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + M
               END DO
               CALL CLASET( 'A', NS, N-M, CZERO, CZERO,
     $                      VT( 1,M+1 ), LDVT )
*
*              Call CUNMBR to compute (VB**T)*(PB**T)
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL CUNMBR( 'P', 'R', 'C', NS, M, M, WORK( ILQF ), M,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
*
*              Call CUNMLQ to compute ((VB**T)*(PB**T))*Q.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL CUNMLQ( 'R', 'N', NS, N, M, A, LDA,
     $                      WORK( ITAU ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
         ELSE
*
*           Path 2t (N greater than M, but not much larger)
*           Reduce to bidiagonal form without LQ decomposition
*           A = QB * B * PB**T = QB * ( UB * S * VB**T ) * PB**T
*           U = QB * UB; V**T = VB**T * PB**T
*
*           Bidiagonalize A
*           (Workspace: need 2*M+N, prefer 2*M+(M+N)*NB)
*
            ITAUQ = 1
            ITAUP = ITAUQ + M
            ITEMP = ITAUP + M
            ID = 1
            IE = ID + M
            ITGKZ = IE + M
            CALL CGEBRD( M, N, A, LDA, RWORK( ID ), RWORK( IE ),
     $                   WORK( ITAUQ ), WORK( ITAUP ), WORK( ITEMP ),
     $                   LWORK-ITEMP+1, INFO )
            ITEMPR = ITGKZ + M*(M*2+1)
*
*           Solve eigenvalue problem TGK*Z=Z*S.
*           (Workspace: need 2*M*M+14*M)
*
            CALL SBDSVDX( 'L', JOBZ, RNGTGK, M, RWORK( ID ),
     $                    RWORK( IE ), VL, VU, ILTGK, IUTGK, NS, S,
     $                    RWORK( ITGKZ ), M*2, RWORK( ITEMPR ),
     $                    IWORK, INFO)
*
*           If needed, compute left singular vectors.
*
            IF( WANTU ) THEN
               K = ITGKZ
               DO I = 1, NS
                  DO J = 1, M
                     U( J, I ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + M
               END DO
*
*              Call CUNMBR to compute QB*UB.
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL CUNMBR( 'Q', 'L', 'N', M, NS, N, A, LDA,
     $                      WORK( ITAUQ ), U, LDU, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
*
*           If needed, compute right singular vectors.
*
            IF( WANTVT) THEN
               K = ITGKZ + M
               DO I = 1, NS
                  DO J = 1, M
                     VT( I, J ) = CMPLX( RWORK( K ), ZERO )
                     K = K + 1
                  END DO
                  K = K + M
               END DO
               CALL CLASET( 'A', NS, N-M, CZERO, CZERO,
     $                      VT( 1,M+1 ), LDVT )
*
*              Call CUNMBR to compute VB**T * PB**T
*              (Workspace in WORK( ITEMP ): need M, prefer M*NB)
*
               CALL CUNMBR( 'P', 'R', 'C', NS, N, M, A, LDA,
     $                      WORK( ITAUP ), VT, LDVT, WORK( ITEMP ),
     $                      LWORK-ITEMP+1, INFO )
            END IF
         END IF
      END IF
*
*     Undo scaling if necessary
*
      IF( ISCL.EQ.1 ) THEN
         IF( ANRM.GT.BIGNUM )
     $      CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1,
     $                   S, MINMN, INFO )
         IF( ANRM.LT.SMLNUM )
     $      CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1,
     $                   S, MINMN, INFO )
      END IF
*
*     Return optimal workspace in WORK(1)
*
      WORK( 1 ) = CMPLX( REAL( MAXWRK ), ZERO )
*
      RETURN
*
*     End of CGESVDX
*
      END


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          Futility Development Group                          !
!                             All rights reserved.                             !
!                                                                              !
! Futility is a jointly-maintained, open-source project between the University !
! of Michigan and Oak Ridge National Laboratory.  The copyright and license    !
! can be found in LICENSE.txt in the head directory of this repository.        !
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
MODULE testNonLinearSolverInterface
USE IntrType
USE VectorTypes
USE MatrixTypes
USE NonLinearSolverModule

IMPLICIT NONE
PRIVATE

PUBLIC :: NonLinearSolverInterface_Test

!Sets up a test interface to find the roots of the following system of equations:
!  2*x1 + x1*x2 = 2
!  2*x2 - x1*x2**2 = 2
!The root occurs at x1 = 0.5, x2 = 2
TYPE,EXTENDS(NonLinearSolverInterface_Base) :: NonLinearSolverInterface_Test
  CONTAINS
    PROCEDURE,PASS :: eval => eval_test
ENDTYPE NonLinearSolverInterface_Test

CONTAINS
SUBROUTINE eval_test(this,x,y)
  CLASS(NonLinearSolverInterface_Test),INTENT(IN) :: this
  CLASS(VectorType),INTENT(INOUT) :: x
  CLASS(VectorType),INTENT(INOUT) :: y
  !
  REAL(SRK) :: xreal(2)

  CALL x%getAll(xreal)
  CALL y%set((/2.0_SRK*xreal(1) + xreal(1)*xreal(2) - 2.0_SRK, & ! 2*x1 + x1*x2 -2
      2.0_SRK*xreal(2) - xreal(1)*xreal(2)**2.0_SRK - 2.0_SRK/)) ! 2*x2 - x1*x2**2 -2

ENDSUBROUTINE eval_test
ENDMODULE testNonLinearSolverInterface
!
PROGRAM testNonLinearSolver
#include "UnitTest.h"
USE UnitTest
USE IntrType
USE ParameterLists
USE FutilityComputingEnvironmentModule
USE VectorTypes
USE MatrixTypes
USE LinearSolverTypes
USE NonLinearSolverModule
USE testNonLinearSolverInterface

IMPLICIT NONE

TYPE(FutilityComputingEnvironment),TARGET :: ce
TYPE(NonLinearSolverInterface_Test),TARGET :: ftest
TYPE(NonLinearSolver_Native) :: nativeSolver

CALL setupTest()
CREATE_TEST("testNonLinearSolver")

REGISTER_SUBTEST('Native, Newton''s Method',testNativeNewton)

FINALIZE_TEST()
CALL clearTest()
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE testNativeNewton()
  REAL(SRK) :: refsol(2)=(/0.5_SRK,2.0_SRK/),testsol(2)
  TYPE(ParamType) :: plist
  TYPE(RealVectorType) :: x
  TYPE(LinearSolverType_Direct) :: refLS
  CLASS(LinearSolverType_Base),ALLOCATABLE :: testLS

  CALL plist%add('NonLinearSolver -> n',2)
  CALL plist%add('NonLinearSolver -> method',NLSOLVER_METHOD_NEWTON)
  CALL plist%add('NonLinearSolver -> tolerance',1.0E-14_SRK)
  CALL nativeSolver%init(ce,ftest,plist)
  CALL plist%clear()

  COMPONENT_TEST('InitBase')
  ASSERT_EQ(testSolverMethod(nativeSolver),NLSOLVER_METHOD_NEWTON,'%solverMethod')
  ASSERT_EQ(testN(nativeSolver),2,'%n')
  ASSERT_EQ(testIterations(nativeSolver),-1,'%iterations')
  ASSERT_EQ(testTol(nativeSolver),1.0E-14_SRK,'%tol')
  ASSERT(ASSOCIATED(testCE(nativeSolver)),'%ce')
  ASSERT(ASSOCIATED(testFunc(nativeSolver)),'%func')

  COMPONENT_TEST('Init')
  ASSERT_EQ(testTPLType(nativeSolver),NLSOLVER_TPL_NATIVE,'%TPLType')
  CALL testLinSys(nativeSolver,testLS)
  ASSERT(testLS%isInit,'%linSys')
  ASSERT(SAME_TYPE_AS(refLS,testLS),'%linSys dynamic type')
  DEALLOCATE(testLS)
  ASSERT(nativeSolver%isInit,'%isInit')

  CALL plist%add('VectorType -> n',2)
  CALL x%init(plist)
  CALL plist%clear()

  COMPONENT_TEST('Solve')
  CALL x%set((/0.0_SRK,0.0_SRK/))
  CALL nativeSolver%solve(x)
  CALL x%get(testsol)
  ASSERT_APPROXEQ(testsol(1),refsol(1),'solution(1)')
  ASSERT_APPROXEQ(testsol(2),refsol(2),'solution(2)')
  ASSERT_EQ(testIterations(nativeSolver),7,'%iterations')
  CALL x%clear()

  CALL nativeSolver%clear()

  COMPONENT_TEST('ClearBase')
  ASSERT_EQ(testSolverMethod(nativeSolver),-1,'%solverMethod')
  ASSERT_EQ(testTPLType(nativeSolver),-1,'%TPLType')
  ASSERT_EQ(testN(nativeSolver),-1,'%n')
  ASSERT_EQ(testIterations(nativeSolver),-1,'%iterations')
  ASSERT_EQ(testTol(nativeSolver),1.0E-5_SRK,'%tol')
  CALL testLinSys(nativeSolver,testLS)
  ASSERT(.NOT.ALLOCATED(testLS),'%linSys')
  ASSERT(.NOT.ASSOCIATED(testCE(nativeSolver)),'%ce')
  ASSERT(.NOT.ASSOCIATED(testFunc(nativeSolver)),'ASSOCIATED %func')
  ASSERT(.NOT.nativeSolver%isInit,'%isInit')

ENDSUBROUTINE testNativeNewton
!
!-------------------------------------------------------------------------------
SUBROUTINE setupTest()

  ALLOCATE(ce%exceptHandler)
  ALLOCATE(ce%parEnv)

ENDSUBROUTINE setupTest
!
!-------------------------------------------------------------------------------
SUBROUTINE clearTest()

  DEALLOCATE(ce%exceptHandler)
  CALL ce%parEnv%world%finalize()
  DEALLOCATE(ce%parEnv)

ENDSUBROUTINE clearTest
!
ENDPROGRAM testNonLinearSolver


SUBROUTINE fmdsig(dee,e,v)
!
! This subroutine returns the elastic dee matrix for ih=3 (plane stress),
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::e,v
 REAL(iwp),INTENT(OUT)::dee(:,:)
 REAL(iwp)::zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp
 INTEGER::ih
 dee=zero
 ih=UBOUND(dee,1)
 SELECT CASE(ih)
 CASE(3)
   dee=zero
   dee(1,1)=e/(one-v*v)
   dee(2,2)=dee(1,1)
   dee(3,3)=pt5*e/(one+v)
   dee(1,2)=v*dee(1,1)
   dee(2,1)=dee(1,2)
 CASE DEFAULT
   WRITE(*,*)'wrong size for dee matrix'
 END SELECT
RETURN
END SUBROUTINE fmdsig


! { dg-do compile }
! Test the fix for PR43843, in which the temporary for b(1) in
! test_member was an indirect reference, rather then the value.
!
! Contributed by Kyle Horne <horne.kyle@gmail.com>
! Reported by Tobias Burnus <burnus@gcc.gno.org>
! Reported by Harald Anlauf <anlauf@gmx.de> (PR43841)
!
module polar_mod
  implicit none
  complex, parameter :: i = (0.0,1.0)
  real, parameter :: pi = 3.14159265359
  real, parameter :: e = exp (1.0)
  type :: polar_t
    real :: l, th
  end type
  type(polar_t) :: one = polar_t (1.0, 0)
  interface operator(/)
    module procedure div_pp
  end interface
  interface operator(.ne.)
    module procedure ne_pp
  end interface
contains
  elemental function div_pp(u,v) result(o)
    type(polar_t), intent(in) :: u, v
    type(polar_t) :: o
    complex :: a, b, c
    a = u%l*exp (i*u%th*pi)
    b = v%l*exp (i*v%th*pi)
    c = a/b
    o%l = abs (c)
    o%th = atan2 (imag (c), real (c))/pi
  end function div_pp
  elemental function ne_pp(u,v) result(o)
    type(polar_t), intent(in) :: u, v
    LOGICAL :: o
    if (u%l .ne. v%l) then
      o = .true.
    else if (u%th .ne. v%th) then
      o = .true.
    else
      o = .false.
    end if
  end function ne_pp
end module polar_mod

program main
  use polar_mod
  implicit none
  call test_member
  call test_other
  call test_scalar
  call test_real
contains
  subroutine test_member
    type(polar_t), dimension(3) :: b
    b = polar_t (2.0,0.5)
    b(:) = b(:)/b(1)
    if (any (b .ne. one)) call abort
  end subroutine test_member
  subroutine test_other
    type(polar_t), dimension(3) :: b
    type(polar_t), dimension(3) :: c
    b = polar_t (3.0,1.0)
    c = polar_t (3.0,1.0)
    b(:) = b(:)/c(1)
    if (any (b .ne. one)) call abort
  end subroutine test_other
  subroutine test_scalar
    type(polar_t), dimension(3) :: b
    type(polar_t) :: c
    b = polar_t (4.0,1.5)
    c = b(1)
    b(:) = b(:)/c
    if (any (b .ne. one)) call abort
  end subroutine test_scalar
  subroutine test_real
    real,dimension(3) :: b
    real :: real_one
    b = 2.0
    real_one = b(2)/b(1)
    b(:) = b(:)/b(1)
    if (any (b .ne. real_one)) call abort
  end subroutine test_real
end program main
! { dg-final { cleanup-modules "polar_mod" } }


program monte_carlo_pi
  use iso_fortran_env, only : team_type, STAT_FAILED_IMAGE
  implicit none
  integer, parameter :: NFAIL=2, NSAMPLES=10**6
  integer :: sample, status, n_copy, n = 0
  type(team_type) :: team_active_images
  logical :: fail
  double precision :: x, y
  ! gfortran 9.x doesn't support NUM_IMAGES([TEAM])
  integer :: num_images_initial_team, image_index_in_active_team

  call random_init(repeatable=.true., image_distinct=.true.)

  do sample = 1, NSAMPLES
    call random_number(x); call random_number(y)
    if (hypot(x, y) <= 1) n = n + 1
  end do

  num_images_initial_team = num_images()
  n_copy = n

  do
    form team(1, team_active_images, stat=status)
    change team (team_active_images, stat=status)
      ! FORM TEAM NEW_INDEX= specifier not used; image index in team_active_images is processor-dependent
      image_index_in_active_team = this_image()
      if (num_images_initial_team - num_images() < NFAIL .and. this_image() == num_images()) fail image
      call co_sum(n, result_image = 1, stat=status)
    end team (stat=status)
    if (status /= STAT_FAILED_IMAGE) exit
    ! else value of n is undefined; restore from copy
    n = n_copy
  end do

  if (image_index_in_active_team == 1) then
    write(*,*) (4.0d0 * n / NSAMPLES) / (num_images() - size(failed_images()))
  end if
end program monte_carlo_pi


FUNCTION equa_time(idoy)
!
IMPLICIT NONE
!
INCLUDE 'p1unconv.inc'
!
! Function arguments
!
INTEGER :: idoy
REAL :: equa_time
!
! Local variables
!
REAL :: b
!
!     + + + purpose + + +
!     this function calculates the declination of the earth with respect
!     the sun based on the day of the year

!     + + + keywords + + +
!     solar equation of time

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy   - day of year

!     + + + local variables + + +

!     + + + local definitions + + +
!     b      - sub calculation (time of year, radians)

!     + + + common blocks + + +

!     + + + end specifications + + +

!     calculate time of year (b)
b = (360.0/365.0)*(idoy-81.25)*degtorad                                 !h-55
equa_time = 9.87*sin(2*b) - 7.53*cos(b) - 1.5*sin(b)            !h-54
!
END FUNCTION equa_time

Project Documents/Source Code Original/Equa_time.f90


*+CEL_CARTS
        subroutine CEL_CARTS( ra, dec, vector )

        implicit none

        double precision deg2rad
        parameter( deg2rad = 0.01745329252D+00 )

        double precision ra, dec
        double precision vector( 3 )

*       Description:
*         Given RA and Dec, returns the 3-d vector
*
*       Arguments:
*         ra        (i) : input RA (decimal hours)
*         dec       (i) : input Dec
*         vector    (o) : 3-d vector
*
*       Dependencies:
*         Assumes the presence of trig functions on degrees on the system
*
*       Origin:
*         Conceived as a part of the 3-d vector routines
*
*       Author:
*         Koji Mukai, 1993 Mar 15, Original version
*-CEL_CARTS

        double precision cos_dec, ra_rad, dec_rad

	dec_rad = dec * deg2rad
        cos_dec = cos( dec_rad )
        ra_rad = ra * 1.5d+01 * deg2rad
        vector( 1 ) = cos_dec * cos( ra_rad )
        vector( 2 ) = cos_dec * sin( ra_rad )
        vector( 3 ) = sin( dec_rad )

        end

*+ECL_CARTS
        subroutine ECL_CARTS( lambda, beta, vector )

        implicit none

        double precision deg2rad
        parameter( deg2rad = 0.01745329252D+00 )

        double precision lambda, beta
        double precision vector( 3 )

*       Description:
*         Given ecliptic longitude and latitude, returns the 3-d vector
*
*       Arguments:
*         ra        (i) : input RA (decimal hours)
*         dec       (i) : input Dec
*         vector    (o) : 3-d vector
*
*       Dependencies:
*         Assumes the presence of trig functions on degrees on the system
*
*       Origin:
*         Conceived as a part of the 3-d vector routines
*
*       Author:
*         Koji Mukai, 1993 Mar 15, Original version
*-CEL_CARTS

        double precision cos_beta, lambda_rad, beta_rad

	beta_rad = beta * deg2rad
        cos_beta = cos( beta_rad )
        lambda_rad = lambda * deg2rad
        vector( 1 ) = cos_beta * cos( lambda_rad )
        vector( 2 ) = cos_beta * sin( lambda_rad )
        vector( 3 ) = sin( beta_rad )

        end

*+VEC_ANGLE
        double precision function VEC_ANGLE( vector1, vector2 )

        implicit none

        double precision rad2deg
	parameter( rad2deg = 57.29577951D+00 )

        double precision vector1( 3 ), vector2( 3 )

*       Description:
*         Angle between two cartesian vectors
*
*       Arguments:
*         vector1, vector2 (i) : two input Cartesian vectors
*         <VEC_ANGLE>      (r) : Angle between the two
*
*       Dependencies:
*         Assumes the presence of trig functions on degrees on the system
*
*       Origin:
*         Conceived as a part of the 3-d vector routines
*
*       Author:
*         Koji Mukai, 1993 Mar 15, Original version
*-VEC_ANGLE

        double precision inner, temp, work
        integer j

        inner = 0.0d+00
        do j = 1, 3
          inner = inner + vector1( j ) * vector2( j )
        end do

        if( inner .gt. 0.71d+00 ) then
*            Use sine, which is more accurate in this regime
*            Length( vector1 - vector2 ) * 0.5 = sin( angle * 0.5 )
*            (Cosine of small x is ~1.0-x^2/2, whereas sin x ~ x)
          temp = 0.0
          do j = 1, 3
            work = vector1( j ) - vector2( j )
            temp = temp + work * work
          end do
          temp = sqrt( temp ) * 0.5d+00
          VEC_ANGLE = asin( temp ) * 2.0d+00 * rad2deg
        else if( inner .ge. -0.71d+00 ) then
*            Use the more familiar cosine formula
          VEC_ANGLE = acos( inner ) * rad2deg
        else
*            Back to sine, but two vectors are ~180 degrees apart
          temp = 0.0
          do j = 1, 3
            work = vector1( j ) + vector2( j )
            temp = temp + work * work
          end do
          temp = sqrt( temp ) * 0.5d+00
          VEC_ANGLE = 1.8d+02 - asin( temp ) * 2.0d+00 * rad2deg
        end if

        end

*+VEC_PRDCT
        subroutine VEC_PRDCT( vector1, vector2, vector3 )

        implicit none

        double precision vector1( 3 ), vector2( 3 ), vector3( 3 )

*       Description:
*         Calculates product of two vectors
*
*       Arguments:
*         vector1, vector2 (i) : two input Cartesian vectors
*         vector3          (o) : product of the two input vectors
*
*       Dependencies:
*         None
*
*       Origin:
*         Conceived as a part of the 3-d vector routines
*
*       Author:
*         Koji Mukai, 1993 Mar 15, Original version
*-VEC_PRDCT

        integer i, j, k

        do i = 1, 3
          j = i + 1
          if( j .eq. 4 ) j = 1
          k = j + 1
          if( k .eq. 4 ) k = 1
          vector3( i ) = vector1( j ) * vector2( k )
     &                                - vector1( k ) * vector2( j )
        end do

        end

*+VEC_RENRM
        subroutine VEC_RENRM( vector )

        implicit none

        double precision vector( 3 )

*       Description:
*         Renormalizes a Cartesian vector
*
*       Arguments:
*         vector  (i/o) : Cartesian vector to be renormalized
*
*       Dependencies:
*         None
*
*       Origin:
*         Conceived as a part of the 3-d vector routines
*
*       Author:
*         Koji Mukai, 1993 Mar 15, Original version
*-VEC_RENRM

        double precision temp
        integer j

        temp = 0.0d+00
        do j = 1, 3
          temp = temp + vector( j ) * vector( j )
        end do
        temp = 1.0d+00 / sqrt( temp )
        do j = 1, 3
          vector( j ) = vector( j ) * temp
        end do

        end


      FUNCTION probks(alam)
      REAL probks,alam,EPS1,EPS2
      PARAMETER (EPS1=0.001, EPS2=1.e-8)
      INTEGER j
      REAL a2,fac,term,termbf
      a2=-2.*alam**2
      fac=2.
      probks=0.
      termbf=0.
      do 11 j=1,100
        term=fac*exp(a2*j**2)
        probks=probks+term
        if(abs(term).le.EPS1*termbf.or.abs(term).le.EPS2*probks)return
        fac=-fac
        termbf=abs(term)
11    continue
      probks=1.
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/probks.for


PROGRAM nr
integer :: i
real :: x, f, df
write(*,*) "ENter x0 "
read (*,*)  x
write (*,*) 'Initial value: x=',x

 do i=1,100
     f= x**3 - 8*x - 4
     df = 3*(x**2) - 8
     write (*,*) i,x,f,df
     x = x-f/df
 end do

 write (*,*) '#x = ',x
 End PROGRAM nr


program complex2
complex :: x
x = (3.0, 4.0)
x = x/4.0
print *, x
x = 2/x
print *, x
x = 1/(x + (0.0, 3.0))
print *, x
end program


      subroutine get_diurnal_sst_models(rgeo,wnd,precip,diurnal_sst,diurnal_sst2,diurnal_sst3)
      implicit none

c	c.gentemann gentemann@remss.com 6/2009

c	returns diurnal_sst = webster96
c			diurnal_sst2=kk02 skin
c			diurnal_sst3=kk02 bulk
      real(4), parameter :: pi=3.141592654
	real(4), parameter :: solar_constant=1360   !watts/m**2
	real(4) wnd,precip,peak_solar,rgeo
      real(4) diurnal_sst
      real(4) a0,b0,c0,d0,e0,f0
	real diurnal_sst2,diurnal_sst3

c     calculate solar insolation

	peak_solar=rgeo
c	clayson
	if(wnd>2)then
	a0=0.00265
	b0=0.028
	c0=-0.838
	d0=-0.00105
	e0=0.158
	f0=0.262
      else
	a0=0.002
	b0=0.041
	c0=0.212
	d0=-0.000185
	e0=-0.329
	f0=0.328
	endif

	if(wnd<.01)wnd=.01
	diurnal_sst=f0+a0*peak_solar+b0*precip+c0*log(wnd)+d0*peak_solar*log(wnd)+e0*wnd
	if(rgeo<=0)diurnal_sst=0

c skin algorithm kk02
cu>2.5ms-1	3.2708x10-6	-0.079982	-1.3329x10-6 	0.073287
cu<=2.5ms-1	5.6814x10-6 	0.40052	-3.9637x10-6 	-0.367
	if(wnd>2.5)then
	a0=3.2708e-6
	b0=-0.079982
	c0=-1.3329e-6
	d0=0.073287
c	a0=0.000003049;b0=-0.028258;c0=-0.0000011987;d0=-.025893
      else
	a0=5.6814e-6
	b0=0.40052
	c0=-3.9637e-6
	d0=-0.367
c	a0=0.0000050109;b0=0.22063;c0=-0.0000033394;d0=-0.20216
	endif
	diurnal_sst2=a0*peak_solar**2+b0*log(wnd)+c0*peak_solar**2*log(wnd)+d0
	if(diurnal_sst2<0)diurnal_sst2=0;
	if(rgeo<=0)diurnal_sst2=0

c bulk algorithm kko2
c	u>2.5ms-1	2.3989x10-6	0.057289	-9.2463x10-7 	-0.14236
c	u<=2.5ms-1	1.9361x10-6 	0.014576	-4.1966x10-7 	-.10322

	if(wnd>2.5)then
	a0=2.3989e-6
	b0=0.057289
	c0=-9.2463e-7
	d0=-0.14236
      else
	a0=1.9361e-6
	b0=0.014576
	c0=-4.1966e-7
	d0=-.10322
	endif
	diurnal_sst3=a0*peak_solar**2+b0*log(wnd)+c0*peak_solar**2*log(wnd)+d0
	if(diurnal_sst3<0)diurnal_sst3=0;
	if(rgeo<=0)diurnal_sst3=0

	RETURN
	END


SUBROUTINE gcf(gammcf,a,x,gln)
INTEGER*4 ITMAX
REAL*8 a,gammcf,gln,x,EPS,FPMIN
PARAMETER (ITMAX=100,EPS=3.d-7,FPMIN=1.d-30)
!CU    USES gammln
INTEGER*4 i
REAL*8 an,b,c,d,del,h,gammln
EXTERNAL gammln
gln=gammln(a)
b=x+1.-a
c=1./FPMIN
d=1./b
h=d
do i=1,ITMAX
	an=-i*(i-a)
	b=b+2.
	d=an*d+b
	if(abs(d).lt.FPMIN)d=FPMIN
	c=b+an/c
	if(abs(c).lt.FPMIN)c=FPMIN
	d=1./d
	del=d*c
	h=h*del
	if(abs(del-1.).lt.EPS)goto 1
end do
pause 'a too large, ITMAX too small in gcf'
1     gammcf=exp(-x+a*log(x)-gln)*h
return
END


module stdlib_linalg
  !!Provides a support for various linear algebra procedures
  !! ([Specification](../page/specs/stdlib_linalg.html))
  use stdlib_kinds, only: sp, dp, qp, &
    int8, int16, int32, int64
  use stdlib_optval, only: optval
  implicit none
  private

  public :: diag
  public :: eye
  public :: trace
  public :: outer_product

  interface diag
    !! version: experimental
    !!
    !! Creates a diagonal array or extract the diagonal elements of an array
    !! ([Specification](../page/specs/stdlib_linalg.html#description))
      !
      ! Vector to matrix
      !
      module function diag_rsp(v) result(res)
        real(sp), intent(in) :: v(:)
        real(sp) :: res(size(v),size(v))
      end function diag_rsp
      module function diag_rdp(v) result(res)
        real(dp), intent(in) :: v(:)
        real(dp) :: res(size(v),size(v))
      end function diag_rdp
      module function diag_rqp(v) result(res)
        real(qp), intent(in) :: v(:)
        real(qp) :: res(size(v),size(v))
      end function diag_rqp
      module function diag_csp(v) result(res)
        complex(sp), intent(in) :: v(:)
        complex(sp) :: res(size(v),size(v))
      end function diag_csp
      module function diag_cdp(v) result(res)
        complex(dp), intent(in) :: v(:)
        complex(dp) :: res(size(v),size(v))
      end function diag_cdp
      module function diag_cqp(v) result(res)
        complex(qp), intent(in) :: v(:)
        complex(qp) :: res(size(v),size(v))
      end function diag_cqp
      module function diag_iint8(v) result(res)
        integer(int8), intent(in) :: v(:)
        integer(int8) :: res(size(v),size(v))
      end function diag_iint8
      module function diag_iint16(v) result(res)
        integer(int16), intent(in) :: v(:)
        integer(int16) :: res(size(v),size(v))
      end function diag_iint16
      module function diag_iint32(v) result(res)
        integer(int32), intent(in) :: v(:)
        integer(int32) :: res(size(v),size(v))
      end function diag_iint32
      module function diag_iint64(v) result(res)
        integer(int64), intent(in) :: v(:)
        integer(int64) :: res(size(v),size(v))
      end function diag_iint64
      module function diag_rsp_k(v,k) result(res)
        real(sp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(sp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_rsp_k
      module function diag_rdp_k(v,k) result(res)
        real(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(dp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_rdp_k
      module function diag_rqp_k(v,k) result(res)
        real(qp), intent(in) :: v(:)
        integer, intent(in) :: k
        real(qp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_rqp_k
      module function diag_csp_k(v,k) result(res)
        complex(sp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(sp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_csp_k
      module function diag_cdp_k(v,k) result(res)
        complex(dp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(dp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_cdp_k
      module function diag_cqp_k(v,k) result(res)
        complex(qp), intent(in) :: v(:)
        integer, intent(in) :: k
        complex(qp) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_cqp_k
      module function diag_iint8_k(v,k) result(res)
        integer(int8), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int8) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_iint8_k
      module function diag_iint16_k(v,k) result(res)
        integer(int16), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int16) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_iint16_k
      module function diag_iint32_k(v,k) result(res)
        integer(int32), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int32) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_iint32_k
      module function diag_iint64_k(v,k) result(res)
        integer(int64), intent(in) :: v(:)
        integer, intent(in) :: k
        integer(int64) :: res(size(v)+abs(k),size(v)+abs(k))
      end function diag_iint64_k

      !
      ! Matrix to vector
      !
      module function diag_rsp_mat(A) result(res)
        real(sp), intent(in) :: A(:,:)
        real(sp) :: res(minval(shape(A)))
      end function diag_rsp_mat
      module function diag_rdp_mat(A) result(res)
        real(dp), intent(in) :: A(:,:)
        real(dp) :: res(minval(shape(A)))
      end function diag_rdp_mat
      module function diag_rqp_mat(A) result(res)
        real(qp), intent(in) :: A(:,:)
        real(qp) :: res(minval(shape(A)))
      end function diag_rqp_mat
      module function diag_csp_mat(A) result(res)
        complex(sp), intent(in) :: A(:,:)
        complex(sp) :: res(minval(shape(A)))
      end function diag_csp_mat
      module function diag_cdp_mat(A) result(res)
        complex(dp), intent(in) :: A(:,:)
        complex(dp) :: res(minval(shape(A)))
      end function diag_cdp_mat
      module function diag_cqp_mat(A) result(res)
        complex(qp), intent(in) :: A(:,:)
        complex(qp) :: res(minval(shape(A)))
      end function diag_cqp_mat
      module function diag_iint8_mat(A) result(res)
        integer(int8), intent(in) :: A(:,:)
        integer(int8) :: res(minval(shape(A)))
      end function diag_iint8_mat
      module function diag_iint16_mat(A) result(res)
        integer(int16), intent(in) :: A(:,:)
        integer(int16) :: res(minval(shape(A)))
      end function diag_iint16_mat
      module function diag_iint32_mat(A) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer(int32) :: res(minval(shape(A)))
      end function diag_iint32_mat
      module function diag_iint64_mat(A) result(res)
        integer(int64), intent(in) :: A(:,:)
        integer(int64) :: res(minval(shape(A)))
      end function diag_iint64_mat
      module function diag_rsp_mat_k(A,k) result(res)
        real(sp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(sp) :: res(minval(shape(A))-abs(k))
      end function diag_rsp_mat_k
      module function diag_rdp_mat_k(A,k) result(res)
        real(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(dp) :: res(minval(shape(A))-abs(k))
      end function diag_rdp_mat_k
      module function diag_rqp_mat_k(A,k) result(res)
        real(qp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        real(qp) :: res(minval(shape(A))-abs(k))
      end function diag_rqp_mat_k
      module function diag_csp_mat_k(A,k) result(res)
        complex(sp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(sp) :: res(minval(shape(A))-abs(k))
      end function diag_csp_mat_k
      module function diag_cdp_mat_k(A,k) result(res)
        complex(dp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(dp) :: res(minval(shape(A))-abs(k))
      end function diag_cdp_mat_k
      module function diag_cqp_mat_k(A,k) result(res)
        complex(qp), intent(in) :: A(:,:)
        integer, intent(in) :: k
        complex(qp) :: res(minval(shape(A))-abs(k))
      end function diag_cqp_mat_k
      module function diag_iint8_mat_k(A,k) result(res)
        integer(int8), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int8) :: res(minval(shape(A))-abs(k))
      end function diag_iint8_mat_k
      module function diag_iint16_mat_k(A,k) result(res)
        integer(int16), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int16) :: res(minval(shape(A))-abs(k))
      end function diag_iint16_mat_k
      module function diag_iint32_mat_k(A,k) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int32) :: res(minval(shape(A))-abs(k))
      end function diag_iint32_mat_k
      module function diag_iint64_mat_k(A,k) result(res)
        integer(int64), intent(in) :: A(:,:)
        integer, intent(in) :: k
        integer(int64) :: res(minval(shape(A))-abs(k))
      end function diag_iint64_mat_k
  end interface

  ! Matrix trace
  interface trace
    !! version: experimental
    !!
    !! Computes the trace of a matrix
    !! ([Specification](../page/specs/stdlib_linalg.html#description_2))
      module procedure trace_rsp
      module procedure trace_rdp
      module procedure trace_rqp
      module procedure trace_csp
      module procedure trace_cdp
      module procedure trace_cqp
      module procedure trace_iint8
      module procedure trace_iint16
      module procedure trace_iint32
      module procedure trace_iint64
  end interface

  ! Outer product (of two vectors)
  interface outer_product
    !! version: experimental
    !!
    !! Computes the outer product of two vectors, returning a rank-2 array
    !! ([Specification](../page/specs/stdlib_linalg.html#description_3))
      pure module function outer_product_rsp(u, v) result(res)
        real(sp), intent(in) :: u(:), v(:)
        real(sp) :: res(size(u),size(v))
      end function outer_product_rsp
      pure module function outer_product_rdp(u, v) result(res)
        real(dp), intent(in) :: u(:), v(:)
        real(dp) :: res(size(u),size(v))
      end function outer_product_rdp
      pure module function outer_product_rqp(u, v) result(res)
        real(qp), intent(in) :: u(:), v(:)
        real(qp) :: res(size(u),size(v))
      end function outer_product_rqp
      pure module function outer_product_csp(u, v) result(res)
        complex(sp), intent(in) :: u(:), v(:)
        complex(sp) :: res(size(u),size(v))
      end function outer_product_csp
      pure module function outer_product_cdp(u, v) result(res)
        complex(dp), intent(in) :: u(:), v(:)
        complex(dp) :: res(size(u),size(v))
      end function outer_product_cdp
      pure module function outer_product_cqp(u, v) result(res)
        complex(qp), intent(in) :: u(:), v(:)
        complex(qp) :: res(size(u),size(v))
      end function outer_product_cqp
      pure module function outer_product_iint8(u, v) result(res)
        integer(int8), intent(in) :: u(:), v(:)
        integer(int8) :: res(size(u),size(v))
      end function outer_product_iint8
      pure module function outer_product_iint16(u, v) result(res)
        integer(int16), intent(in) :: u(:), v(:)
        integer(int16) :: res(size(u),size(v))
      end function outer_product_iint16
      pure module function outer_product_iint32(u, v) result(res)
        integer(int32), intent(in) :: u(:), v(:)
        integer(int32) :: res(size(u),size(v))
      end function outer_product_iint32
      pure module function outer_product_iint64(u, v) result(res)
        integer(int64), intent(in) :: u(:), v(:)
        integer(int64) :: res(size(u),size(v))
      end function outer_product_iint64
  end interface outer_product

contains

    !> Version: experimental
    !>
    !> Constructs the identity matrix.
    !> ([Specification](../page/specs/stdlib_linalg.html#eye-construct-the-identity-matrix))
    pure function eye(dim1, dim2) result(result)

        integer, intent(in) :: dim1
        integer, intent(in), optional :: dim2
        integer(int8), allocatable :: result(:, :)

        integer :: dim2_
        integer :: i

        dim2_ = optval(dim2, dim1)
        allocate(result(dim1, dim2_))

        result = 0_int8
        do i = 1, min(dim1, dim2_)
            result(i, i) = 1_int8
        end do

    end function eye

      function trace_rsp(A) result(res)
        real(sp), intent(in) :: A(:,:)
        real(sp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_rsp
      function trace_rdp(A) result(res)
        real(dp), intent(in) :: A(:,:)
        real(dp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_rdp
      function trace_rqp(A) result(res)
        real(qp), intent(in) :: A(:,:)
        real(qp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_rqp
      function trace_csp(A) result(res)
        complex(sp), intent(in) :: A(:,:)
        complex(sp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_csp
      function trace_cdp(A) result(res)
        complex(dp), intent(in) :: A(:,:)
        complex(dp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_cdp
      function trace_cqp(A) result(res)
        complex(qp), intent(in) :: A(:,:)
        complex(qp) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_cqp
      function trace_iint8(A) result(res)
        integer(int8), intent(in) :: A(:,:)
        integer(int8) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_iint8
      function trace_iint16(A) result(res)
        integer(int16), intent(in) :: A(:,:)
        integer(int16) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_iint16
      function trace_iint32(A) result(res)
        integer(int32), intent(in) :: A(:,:)
        integer(int32) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_iint32
      function trace_iint64(A) result(res)
        integer(int64), intent(in) :: A(:,:)
        integer(int64) :: res
        integer :: i
        res = 0
        do i = 1, minval(shape(A))
          res = res + A(i,i)
        end do
      end function trace_iint64

end module stdlib_linalg


 SUBROUTINE CPBSV_F95( A, B, UPLO, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO, LSAME
    USE F77_LAPACK, ONLY: PBSV_F77 => LA_PBSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    COMPLEX(WP), INTENT(INOUT) :: A(:,:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!     LA_PBSV computes the solution to a linear system of equations
! A*X = B, where A has band form and is real symmetric or complex
! Hermitian and, in either case, positive definite, and where X and B are
! rectangular matrices or vectors. The Cholesky decomposition is used to
! factor A as A = U^H*U if UPLO = 'U', or A = L*L^H if UPLO = 'L'
! where U is an upper triangular band matrix and L is a lower triangular
! band matrix, each with the same number of superdiagonals or subdiagonals
! as A. The factored form of A is then used to solve the above system.
!
! =========
!
!      SUBROUTINE LA_PBSV( AB, B, UPLO=uplo, INFO=info )
!          <type>(<wp>), INTENT(INOUT) :: AB(:,:), <rhs>
!          CHARACTER(LEN=1), INTENT(IN), OPTIONAL :: UPLO
!          INTEGER, INTENT(OUT), OPTIONAL :: INFO
!      where
!          <type> ::= REAL | COMPLEX
!          <wp>   ::= KIND(1.0) | KIND(1.0D0)
!          <rhs>  ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! AB      (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(AB,1) = kd + 1 and size(AB,2) = n, where kd is the number
!         of superdiagonals or subdiagonals in the band and n is the
!  	  order of A.
!         On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
! 	  triangle of matrix A in band storage. The (kd + 1) diagonals of
! 	  A are stored in the rows of AB so that the j-th column of A is
! 	  stored in the j-th column of AB as follows:
! 	  if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j
! 	                                           1<=j<=n
!         if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd)
! 	                                           1<=j<=n.
!         On exit, the factor U or L from the Cholesky factorization
!    	  A = U^H*U = L*L^H in the same storage format as A.
! B       (input/output) REAL or COMPLEX array, shape (:,:) with
!         size(B,1) = n or shape (:) with size(B) = n.
!         On entry, the matrix B.
!         On exit, the solution matrix X .
! UPLO    Optional (input) CHARACTER(LEN=1)
!           = 'U': Upper triangle of A is stored;
!           = 'L': Lower triangle of A is stored.
!         Default value: 'U'.
! INFO    Optional (output) INTEGER.
!         = 0: successful exit.
!         < 0: if INFO = -i, the i-th argument had an illegal value.
!         > 0: if INFO = i, the leading minor of order i of A is not
! 	     positive definite, so the factorization could not be
! 	     completed and the solution could not be computed.
!         If INFO is not present and an error occurs, then the program
! 	  is terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_PBSV'
!   .. LOCAL SCALARS ..
    CHARACTER(LEN=1) :: LUPLO
    INTEGER :: LINFO, KD, N, NRHS
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE, PRESENT
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0; KD = SIZE(A,1)-1; N = SIZE(A,2); NRHS = SIZE(B,2)
    IF( PRESENT(UPLO) ) THEN; LUPLO = UPLO; ELSE; LUPLO = 'U'; ENDIF
!   .. TEST THE ARGUMENTS
    IF( KD < 0 .OR. N < 0 ) THEN; LINFO = -1
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -2
    ELSE IF( .NOT.LSAME(LUPLO,'U') .AND. .NOT.LSAME(LUPLO,'L') )THEN; LINFO = -3
    ELSE IF ( N > 0 ) THEN
       CALL PBSV_F77( LUPLO, N, KD, NRHS, A, KD+1, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE CPBSV_F95