*> \brief \b DSYT01
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C, LDC,
*                             RWORK, RESID )
*
*       .. Scalar Arguments ..
*       CHARACTER          UPLO
*       INTEGER            LDA, LDAFAC, LDC, N
*       DOUBLE PRECISION   RESID
*       ..
*       .. Array Arguments ..
*       INTEGER            IPIV( * )
*       DOUBLE PRECISION   A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
*      $                   RWORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DSYT01 reconstructs a symmetric indefinite matrix A from its
*> block L*D*L' or U*D*U' factorization and computes the residual
*>    norm( C - A ) / ( N * norm(A) * EPS ),
*> where C is the reconstructed matrix and EPS is the machine epsilon.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] UPLO
*> \verbatim
*>          UPLO is CHARACTER*1
*>          Specifies whether the upper or lower triangular part of the
*>          symmetric matrix A is stored:
*>          = 'U':  Upper triangular
*>          = 'L':  Lower triangular
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The number of rows and columns of the matrix A.  N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA,N)
*>          The original symmetric matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of the array A.  LDA >= max(1,N)
*> \endverbatim
*>
*> \param[in] AFAC
*> \verbatim
*>          AFAC is DOUBLE PRECISION array, dimension (LDAFAC,N)
*>          The factored form of the matrix A.  AFAC contains the block
*>          diagonal matrix D and the multipliers used to obtain the
*>          factor L or U from the block L*D*L' or U*D*U' factorization
*>          as computed by DSYTRF.
*> \endverbatim
*>
*> \param[in] LDAFAC
*> \verbatim
*>          LDAFAC is INTEGER
*>          The leading dimension of the array AFAC.  LDAFAC >= max(1,N).
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*>          IPIV is INTEGER array, dimension (N)
*>          The pivot indices from DSYTRF.
*> \endverbatim
*>
*> \param[out] C
*> \verbatim
*>          C is DOUBLE PRECISION array, dimension (LDC,N)
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*>          LDC is INTEGER
*>          The leading dimension of the array C.  LDC >= max(1,N).
*> \endverbatim
*>
*> \param[out] RWORK
*> \verbatim
*>          RWORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] RESID
*> \verbatim
*>          RESID is DOUBLE PRECISION
*>          If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS )
*>          If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS )
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*  @precisions fortran d -> z c
*
*> \ingroup double_lin
*
*  =====================================================================
      SUBROUTINE DSYT01_AA( UPLO, N, A, LDA, AFAC, LDAFAC, IPIV, C,
     $                         LDC, RWORK, RESID )
*
*  -- LAPACK test routine (version 3.7.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, LDAFAC, LDC, N
      DOUBLE PRECISION   RESID
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      DOUBLE PRECISION   A( LDA, * ), AFAC( LDAFAC, * ), C( LDC, * ),
     $                   RWORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   ANORM, EPS
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           LSAME, DLAMCH, DLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           DLASET, DLAVSY
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE
*     ..
*     .. Executable Statements ..
*
*     Quick exit if N = 0.
*
      IF( N.LE.0 ) THEN
         RESID = ZERO
         RETURN
      END IF
*
*     Determine EPS and the norm of A.
*
      EPS = DLAMCH( 'Epsilon' )
      ANORM = DLANSY( '1', UPLO, N, A, LDA, RWORK )
*
*     Initialize C to the tridiagonal matrix T.
*
      CALL DLASET( 'Full', N, N, ZERO, ZERO, C, LDC )
      CALL DLACPY( 'F', 1, N, AFAC( 1, 1 ), LDAFAC+1, C( 1, 1 ), LDC+1 )
      IF( N.GT.1 ) THEN
         IF( LSAME( UPLO, 'U' ) ) THEN
            CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 1, 2 ),
     $                   LDC+1 )
            CALL DLACPY( 'F', 1, N-1, AFAC( 1, 2 ), LDAFAC+1, C( 2, 1 ),
     $                   LDC+1 )
         ELSE
            CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 1, 2 ),
     $                   LDC+1 )
            CALL DLACPY( 'F', 1, N-1, AFAC( 2, 1 ), LDAFAC+1, C( 2, 1 ),
     $                   LDC+1 )
         ENDIF
*
*        Call DTRMM to form the product U' * D (or L * D ).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            CALL DTRMM( 'Left', UPLO, 'Transpose', 'Unit', N-1, N,
     $                  ONE, AFAC( 1, 2 ), LDAFAC, C( 2, 1 ), LDC )
         ELSE
            CALL DTRMM( 'Left', UPLO, 'No transpose', 'Unit', N-1, N,
     $                  ONE, AFAC( 2, 1 ), LDAFAC, C( 2, 1 ), LDC )
         END IF
*
*        Call DTRMM again to multiply by U (or L ).
*
         IF( LSAME( UPLO, 'U' ) ) THEN
            CALL DTRMM( 'Right', UPLO, 'No transpose', 'Unit', N, N-1,
     $                  ONE, AFAC( 1, 2 ), LDAFAC, C( 1, 2 ), LDC )
         ELSE
            CALL DTRMM( 'Right', UPLO, 'Transpose', 'Unit', N, N-1,
     $                  ONE, AFAC( 2, 1 ), LDAFAC, C( 1, 2 ), LDC )
         END IF
      ENDIF
*
*     Apply symmetric pivots
*
      DO J = N, 1, -1
         I = IPIV( J )
         IF( I.NE.J )
     $      CALL DSWAP( N, C( J, 1 ), LDC, C( I, 1 ), LDC )
      END DO
      DO J = N, 1, -1
         I = IPIV( J )
         IF( I.NE.J )
     $      CALL DSWAP( N, C( 1, J ), 1, C( 1, I ), 1 )
      END DO
*
*
*     Compute the difference  C - A .
*
      IF( LSAME( UPLO, 'U' ) ) THEN
         DO J = 1, N
            DO I = 1, J
               C( I, J ) = C( I, J ) - A( I, J )
            END DO
         END DO
      ELSE
         DO J = 1, N
            DO I = J, N
               C( I, J ) = C( I, J ) - A( I, J )
            END DO
         END DO
      END IF
*
*     Compute norm( C - A ) / ( N * norm(A) * EPS )
*
      RESID = DLANSY( '1', UPLO, N, C, LDC, RWORK )
*
      IF( ANORM.LE.ZERO ) THEN
         IF( RESID.NE.ZERO )
     $      RESID = ONE / EPS
      ELSE
         RESID = ( ( RESID / DBLE( N ) ) / ANORM ) / EPS
      END IF
*
      RETURN
*
*     End of DSYT01
*
      END


! { dg-do compile }
!
! Test the vendor intrinsic (d)gamma, lgamma and algama/dlgama
! gamma is also part of the Fortran 2008 draft; lgamma is called
! log_gamma in the Fortran 2008 draft.
!
! PR fortran/32980
!
program gamma_test
implicit none
intrinsic :: gamma, lgamma
real :: x

x = gamma(cmplx(1.0,0.0))            ! { dg-error "is not consistent with a specific intrinsic interface" }
x = dgamma(cmplx(1.0,0.0,kind(0d0))) ! { dg-error "must be REAL" }
x = gamma(int(1))                    ! { dg-error "is not consistent with a specific intrinsic interface" }
x = dgamma(int(1))                   ! { dg-error "must be REAL" }

x = lgamma(cmplx(1.0,0.0))           ! { dg-error "must be REAL" }
x = algama(cmplx(1.0,0.0))           ! { dg-error "must be REAL" }
x = dlgama(cmplx(1.0,0.0,kind(0d0))) ! { dg-error "must be REAL" }

x = lgamma(int(1))                   ! { dg-error "must be REAL" }
x = algama(int(1))                   ! { dg-error "must be REAL" }
x = dlgama(int(1))                   ! { dg-error "must be REAL" }
end program gamma_test


      PROGRAM CCPKLB
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)

      PARAMETER (K=40,N=40,LRWK=2000,LIWK=2000)
      REAL Z(K,N), RWRK(LRWK)
      INTEGER M, IWRK(LIWK)
      CHARACTER*16 STRING

      CALL GETDAT (Z, K, M, N)
C
C Open GKS
C
      CALL GOPKS (IERRF, ISZDM)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C Initialize Conpack
C
      CALL CPRECT(Z,K,M,N,RWRK,LRWK,IWRK,LIWK)

      CALL CPPKCL(Z, RWRK, IWRK)
      CALL CPPKLB(Z, RWRK, IWRK)
      CALL CPGETI('NCL - NUMBER OF CONTOUR LEVELS',NOCL)
      DO 10, I=1,NOCL
         CALL CPSETI('PAI - PARAMETER ARRAY INDEX',I)
         CALL CPGETR('CLV - CONTOUR LEVEL VALUE',CLVL)
         WRITE (STRING,5) CLVL
    1         CALL CPSETC('LLT - LINE LABEL TEXT',STRING)
 10   CONTINUE
C
C Draw perimeter
C
      CALL CPBACK(Z, RWRK, IWRK)
C
C Draw Contours
C
      CALL CPCLDR(Z,RWRK,IWRK)
C
C Close frame and close GKS
C
      CALL FRAME
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS

 5    FORMAT ('Contour at ',F5.3)
      STOP
      END

      SUBROUTINE GETDAT (Z, K, M, N)
      INTEGER I,J,K,M,N
      REAL Z(K,N)

      M=K
      DO 10, I=1,M
         DO 20, J=1,N
            Z(I,J)= 10.E-8*(-16.*REAL(I**2*J) +
     +            34*REAL(I*J**2) - REAL(6*I) + 93.)
 20      CONTINUE
 10   CONTINUE

      RETURN
      END


      DOUBLE PRECISION FUNCTION DASUM(N,X,INCX)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-11-11 DASUM  Krogh  Declared all vars.
c>> 1994-10-20 DASUM  Krogh  Changes to use M77CON
c>> 1994-04-19 DASUM  Krogh  Minor -- Made diff. precision line up.
C>> 1985-08-02 DASUM  Lawson Initial code.
c--D replaces "?": ?ASUM
C
C     RETURNS SUM OF MAGNITUDES OF X.
C     DASUM = SUM FROM 0 TO N-1 OF ABS(X(1+I*INCX))
C
      INTEGER N, INCX, NS, I, M, MP1
      DOUBLE PRECISION X(*)
      DASUM = 0.0D0
      IF(N.LE.0)RETURN
      IF(INCX.EQ.1)GOTO 20
C
C        CODE FOR INCREMENTS NOT EQUAL TO 1.
C
      NS = N*INCX
          DO 10 I=1,NS,INCX
          DASUM = DASUM + ABS(X(I))
   10     CONTINUE
      RETURN
C
C        CODE FOR INCREMENTS EQUAL TO 1.
C
C
C        CLEAN-UP LOOP SO REMAINING VECTOR LENGTH IS A MULTIPLE OF 6.
C
   20 M = MOD(N,6)
      IF( M .EQ. 0 ) GO TO 40
      DO 30 I = 1,M
         DASUM = DASUM + ABS(X(I))
   30 CONTINUE
      IF( N .LT. 6 ) RETURN
   40 MP1 = M + 1
      DO 50 I = MP1,N,6
         DASUM = DASUM + ABS(X(I)) + ABS(X(I + 1)) + ABS(X(I + 2))
     $   + ABS(X(I + 3)) + ABS(X(I + 4)) + ABS(X(I + 5))
   50 CONTINUE
      RETURN
      END


MODULE FUN_xyDOT
!!#### PURPOSE
!! Define DOT product for R^2 Cartesian geometry.

!!#### USAGE
!!         s = xyDOT_VV( V_a , V_b )
!
!! where V_a, V_b are vectors.

!!#### AUTHOR
!! William Wieselquist | william.wieselquist@gmail.com

!!#### DEPENDENCIES
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!#### DEFAULT IMPLICIT
IMPLICIT NONE

!!#### DEFAULT ACCESS
PRIVATE

!!#### PROCEDURE OVERLOADING
INTERFACE xyDOT_VV
 MODULE PROCEDURE xyDOT_VV_Rsp
 MODULE PROCEDURE xyDOT_VV_Rdp
END INTERFACE

!!#### PUBLIC ACCESS LIST
PUBLIC :: xyDOT_VV

CONTAINS

PURE FUNCTION xyDOT_VV_Rsp( V_a , V_b ) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyDOT_VV.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyDOT_VV.f90.bdy"
!!--end--
END FUNCTION

PURE FUNCTION xyDOT_VV_Rdp( V_a , V_b ) RESULT(s)
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "03-A-FUN_xyDOT_VV.f90.hdr"
!!--begin--
INCLUDE "03-A-FUN_xyDOT_VV.f90.bdy"
!!--end--
END FUNCTION

END MODULE


MODULE SMMP

  IMPLICIT NONE

  INTERFACE

    !> Symbolic matrix-matrix multiply.
    SUBROUTINE SYMBMM(N,M,L,IA,JA,DIAGA,IB,JB,DIAGB,IC,JC,DIAGC,INDEX)
      INTEGER :: N
      INTEGER :: M
      INTEGER :: L
      INTEGER :: IA(*)
      INTEGER :: JA(*)
      INTEGER :: DIAGA
      INTEGER :: IB(*)
      INTEGER :: JB(*)
      INTEGER :: DIAGB
      INTEGER :: IC(*)
      INTEGER :: JC(*)
      INTEGER :: DIAGC
      INTEGER :: INDEX(*)
    END SUBROUTINE SYMBMM

    !> Numerical matrix-matrix multiply.
    SUBROUTINE NUMBMM(N,M,L,IA,JA,DIAGA,A,IB,JB,DIAGB,B,IC,JC,DIAGC,C,TEMP)
      INTEGER :: N
      INTEGER :: M
      INTEGER :: L
      INTEGER :: IA(*)
      INTEGER :: JA(*)
      INTEGER :: DIAGA
      REAL :: A(*)
      INTEGER :: IB(*)
      INTEGER :: JB(*)
      INTEGER :: DIAGB
      REAL :: B(*)
      INTEGER :: IC(*)
      INTEGER :: JC(*)
      INTEGER :: DIAGC
      REAL :: C(*)
      REAL :: TEMP(*)
    END SUBROUTINE NUMBMM

    !> Transpose of a sparse matrix.
    SUBROUTINE TRANSP(N,M,IA,JA,DIAGA,A,IB,JB,B,MOVE)
      INTEGER :: N
      INTEGER :: M
      INTEGER :: IA(*)
      INTEGER :: JA(*)
      INTEGER :: DIAGA
      REAL :: A(*)
      INTEGER :: IB(*)
      INTEGER :: JB(*)
      REAL :: B(*)
      INTEGER :: MOVE
    END SUBROUTINE TRANSP

    !> Convert a Yale format sparse matrix into the Bank-Smith format.
    SUBROUTINE YTOBS(N,IA,JA,DIAGA,SYMA,A,IB,JB,B,MOVE)
      INTEGER :: N
      INTEGER :: IA(*)
      INTEGER :: JA(*)
      INTEGER :: DIAGA
      INTEGER :: SYMA
      REAL :: A(*)
      INTEGER :: IB(*)
      INTEGER :: JB(*)
      REAL :: B(*)
      INTEGER :: MOVE
    END SUBROUTINE YTOBS

    !> Convert a Bank-Smith format sparse matric into one of the Yale format.
    SUBROUTINE BSTOY(N,IA,JA,SYMA,A,IB,JB,DIAGB,B,MOVE)
      INTEGER :: N
      INTEGER :: IA(*)
      INTEGER :: JA(*)
      INTEGER :: SYMA
      REAL :: A(*)
      INTEGER :: IB(*)
      INTEGER :: JB(*)
      INTEGER :: DIAGB
      REAL :: B(*)
      INTEGER :: MOVE
    END SUBROUTINE BSTOY

  END INTERFACE

END MODULE


program derivatives_cost

  use ccpdata, only: MU, CORR, ABSERR, RELERR, set_seed, initialize, &
                     destroy

  integer, parameter :: dims(10) = (/2, 3, 4, 5, 10, 15, 20, 30, 40, 50/)

  integer :: np, flag, nruns
  real(8) :: start, finish, p, dfttime, fttime

  real(8), allocatable :: x(:), l(:), u(:), dp(:)

  write(*,*)
  write(*,*) "This program tests the cost of derivatives"
  write(*,*) "of CCP functions"

  nruns = 10

  write(*,FMT=0002) 'DIM', 'F TIME', 'G TIME', 'RELATION'

  do i = 1, size(dims)

     fttime = 0.0D0

     dfttime = 0.0D0

     do j = 1, nruns

        np = dims(i)

        allocate(x(np),l(np),u(np),dp(np))

        call set_seed(12345678 + i * j)

        ! Function

        call initialize(np, np, 0, x, l, u, 0.0D0)

        call CPU_TIME(start)

        call evalprob(np, x, MU, CORR, ABSERR, RELERR, p, flag)

        call CPU_TIME(finish)

        fttime = fttime + (finish - start)

        ! Derivatives

        call CPU_TIME(start)

        call evaldprob(np, x, MU, CORR, ABSERR, RELERR, dp, flag)

        call CPU_TIME(finish)

        dfttime = dfttime + (finish - start)

        deallocate(x, l, u, dp)

        call destroy()

     end do

     write(*,FMT=0001) np, (fttime / nruns), (dfttime / nruns), &
                       (dfttime / fttime)

  end do

  0002 FORMAT(/,A5,1X,A11,1X,A11,1X,A11)
  0001 FORMAT(I5,1X,F11.8,1X,F11.8,1X,F11.8)

contains

  function fgauss(x, m, s)

    implicit none

    ! PARAMETERS
    real(8), parameter :: PI = asin(1.0)

    ! SCALAR ARGUMENTS
    real(8) :: m, s, x

    intent(in) :: m, s, x

    ! RETURN VALUE
    real(8) :: fgauss

    fgauss = 1 / (sqrt(2 * PI) * s) * &
             exp(- 5.0D-1 * (x - m) ** 2.0D0)

  end function fgauss

  !------------------------------------------------------------!
  ! SUBROUTINE EVALDPROB                                       !
  !                                                            !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evaldprob(n, x, MU, CORR, ABSERR, RELERR, dp, flag)

    implicit none

    ! SCALAR ARGUMENTS
    integer :: flag, n
    real(8) :: ABSERR, RELERR

    ! ARRAY ARGUMENTS
    real(8) :: CORR(n * (n - 1) / 2), dp(n), MU(n), x(n)

    intent(in ) :: ABSERR, CORR, MU, n, RELERR, x
    intent(out) :: dp, flag

    ! Interface

    interface
       SUBROUTINE MVNDST( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, &
            ABSEPS, RELEPS, ERROR, VAL, INFORM )

         integer :: N, INFORM, MAXPTS
         real(8) :: ABSEPS, RELEPS, VAL, ERROR

         integer :: INFIN(N)
         real(8) :: LOWER(N), UPPER(N), CORREL((N - 1) * N / 2)

         intent(in ) :: N, MAXPTS, INFIN, LOWER, UPPER, CORREL, &
                        ABSEPS, RELEPS
         intent(out) :: INFORM, VAL, ERROR

       end SUBROUTINE MVNDST
    end interface

    ! LOCAL SCALARS
    integer :: i, j, k, pos, pi, pj
    real(8) :: error, ff

    ! LOCAL ARRAYS
    real(8) :: l(n - 1), u(n - 1), ncorr((n - 1) * (n - 2) / 2)
    integer :: infty(n - 1)

    flag = 0

    do k = 1,n

       ff = fgauss(x(k), MU(k), 1.0D0)

       dp(k) = 0.0D0

       if ( ff .gt. 1.0D-60 ) then

          pos = 1

          do j = 1, n

             if ( j .eq. k ) cycle

             do i = 1, j - 1

                if ( i .eq. k ) cycle

                if ( i .lt. k ) then

                   pi = i + (k - 1) * (k - 2) / 2

                else

                   pi = k + (i - 1) * (i - 2) / 2

                end if

                if ( j .lt. k ) then

                   pj = j + (k - 1) * (k - 2) / 2

                else

                   pj = k + (j - 1) * (j - 2) / 2

                end if

                ncorr(pos) = corr(i + (j - 1) * (j - 2) / 2)

                ncorr(pos) = ncorr(pos) - corr(pi) * corr(pj)

                pos = pos + 1

             end do

          end do

          ! Affine transformation.
          ! Only need to shift 'mu'

          do i = 1, n

             if ( i .lt. k ) then

                u(i) = x(i) - (MU(i) + (x(k) - MU(k)) * &
                                 corr(i + (k - 1) * (k - 2) / 2))

             else if ( i .gt. k ) then

                u(i - 1) = x(i) - (MU(i) + (x(k) - MU(k)) * &
                                   corr(k + (i - 1) * (i - 2) / 2))

             end if

          end do

          do i = 1, n - 1

             infty(i) = 0

          end do

          flag = 0

          call mvndst(n - 1, l, u, infty, ncorr, &
               5000 * (n - 1) * (n - 1) * (n - 1), &
               ABSERR, RELERR, error, dp(k), flag)

          if ( flag .ne. 0 ) then

             write(*,*) 'MVNDST Returned nonzero flag!'

             stop

          end if

          dp(k) = dp(k) * ff

       end if

    end do

  end subroutine evaldprob

  !------------------------------------------------------------!
  ! SUBROUTINE EVALPROB                                        !
  !                                                            !
  ! This subroutine evaluates the probability P(\x_i \le x_i)  !
  ! for i \in \{1, \dots, np\}                                 !
  !                                                            !
  !------------------------------------------------------------!

  subroutine evalprob(n, x, MU, CORR, ABSERR, RELERR, p, flag)

    implicit none

    ! SCALAR ARGUMENTS
    integer :: flag, n
    real(8) :: ABSERR, p, RELERR

    ! ARRAY ARGUMENTS
    real(8) :: CORR(n * (n - 1) / 2), MU(n), x(n)

    intent(in ) :: ABSERR, CORR, MU, n, RELERR, x
    intent(out) :: p, flag

    ! Interface

    interface
       SUBROUTINE MVNDST( N, LOWER, UPPER, INFIN, CORREL, MAXPTS, &
            ABSEPS, RELEPS, ERROR, VAL, INFORM )

         integer :: N, INFORM, MAXPTS
         real(8) :: ABSEPS, RELEPS, VAL, ERROR

         integer :: INFIN(N)
         real(8) :: LOWER(N), UPPER(N), CORREL((N - 1) * N / 2)

         intent(in ) :: N, MAXPTS, INFIN, LOWER, UPPER, CORREL, &
                        ABSEPS, RELEPS
         intent(out) :: INFORM, VAL, ERROR

       end SUBROUTINE MVNDST
    end interface

    ! LOCAL SCALARS
    integer :: i
    real(8) :: error

    ! LOCAL ARRAYS
    real(8) :: l(n), u(n)
    integer :: infty(n)

    ! Affine transformation.
    ! Only need to shift 'mu'

    do i = 1, n

       u(i) = x(i) - MU(i)

    end do

    do i = 1, n

       infty(i) = 0

    end do

    flag = 0

    call mvndst(n, l, u, infty, corr, 5000 * n * n * n, ABSERR, &
                RELERR, error, p, flag)

  end subroutine evalprob

end program derivatives_cost


!!## MODULE SUBROUTINE: FlagDuplicateScalars0
MODULE SUB_FlagDuplicateScalars0
!!### PURPOSE
!! Flag duplicates in a list of scalars from a *SORTED*
!! list of Scalars by setting the duplicates to the
!! error number, and optionally returning a mask that
!! is true only for the unique Scalars.

!!### USAGE
!
!     CALL FlagDuplicateScalars0( sorted_SCAL [,tol] [,reltol] [,unique])
!
!! where <sorted_SCAL> is a list of *SORTED* Scalars
!! <VECS(1:Nd,:)>, where <Nd> is the number of dimensions
!! and <tol>, <reltol> are the tolerances and relative
!! tolerances of the comparison for duplicate status,
!! respectively.
!!
!! The Scalars that are duplicates will be changed to the
!! error number, and have a value of <.FALSE.> in the <unique> mask.
!!

!!### DETAILS
!! Optional arguments, <tol> and <reltol> provide
!! absolute and relative tolerances, with <tol> overriding
!! <reltol> if (for some reason) both are present, for determining
!! whether or not two points are actually duplicates.

!!### MODULAR KINDS
USE KND_IntrinsicTypes,ONLY: KIND_Rsp,KIND_Rdp !!((01-A-KND_IntrinsicTypes.f90))

!!### MODULAR PROCEDURES
USE FUN_IsApprox                               !!((03-A-FUN_IsApprox.f90))
USE FUN_Error                                  !!((04-A-FUN_Error.f90))

!!### DEFAULT IMPLICIT
IMPLICIT NONE

!!### DEFAULT ACCESS
PRIVATE

!!### OPERATOR DEFINITION
INTERFACE FlagDuplicateScalars0
 MODULE PROCEDURE FlagDuplicateScalars0_Rsp
 MODULE PROCEDURE FlagDuplicateScalars0_Rdp
END INTERFACE

!!### PUBLIC ACCESS LIST
PUBLIC :: FlagDuplicateScalars0

!!## PROCEDURE LISTING
CONTAINS

!!### PURE SUBROUTINE: FlagDuplicateScalars0_Rsp
PURE SUBROUTINE FlagDuplicateScalars0_Rsp(sorted_SCAL,tol,reltol,unique)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rsp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-SUB_FlagDuplicateScalars0.f90.hdr"
!!--begin--
INCLUDE "05-A-SUB_FlagDuplicateScalars0.f90.bdy"
!!--end--
END SUBROUTINE

!!### PURE SUBROUTINE: FlagDuplicateScalars0_Rdp
PURE SUBROUTINE FlagDuplicateScalars0_Rdp(sorted_SCAL,tol,reltol,unique)
!!#### LOCAL KINDS
USE KND_IntrinsicTypes,ONLY: KIND_R=>KIND_Rdp  !!((01-A-KND_IntrinsicTypes.f90))
INCLUDE "05-A-SUB_FlagDuplicateScalars0.f90.hdr"
!!--begin--
INCLUDE "05-A-SUB_FlagDuplicateScalars0.f90.bdy"
!!--end--
END SUBROUTINE

END MODULE


program init_proc_vars
    implicit none
    integer, parameter :: nr_elems = 5, nr_arrays = 5
    integer, dimension(nr_elems) :: a
    integer :: i, nr_ones
    do i = 1, nr_arrays
        call init_array(a)
        nr_ones = count_one_wrong(a)
        print '(I5, I4, A, I1)', i, nr_ones, '/', size(a)
    end do

contains

    subroutine init_array(a)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        integer, dimension(:), intent(inout) :: a
        integer :: i
        real(kind=dp) :: r

        do i = 1, size(a)
            call random_number(r)
            if (r < 0.5) then
                a(i) = 0
            else
                a(i) = 1
            end if
        end do
    end subroutine init_array

    function count_one_wrong(a) result(result)
        implicit none
        integer, dimension(:), intent(in) :: a
        integer :: result
        integer :: count = 0
        integer :: i
        do i = 1, size(a)
            if (a(i) > 0) count = count + 1
        end do
        result = count
    end function count_one_wrong

end program init_proc_vars


!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
!                          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.        !
! test with ./unit_tests/testRSORprecon/Futility_testRSORprecon.exe
!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++!
PROGRAM testRSORPrecon
#include "UnitTest.h"

USE ISO_FORTRAN_ENV
USE UnitTest
USE IntrType
USE ExceptionHandler
USE BLAS
USE ParameterLists
USE ParallelEnv
USE VectorTypes
USE MatrixTypes
USE PreconditionerTypes
IMPLICIT NONE

#ifdef HAVE_MPI
INCLUDE 'mpif.h'
#endif

TYPE(ExceptionHandlerType),TARGET :: e
TYPE(ParamType) :: PListMat,PListVec,PListRSOR
CLASS(MatrixType),ALLOCATABLE :: testSparseMatrix,testDenseMatrix,testMatrix
CLASS(MatrixType),ALLOCATABLE :: testBandedMatrix
CLASS(VectorType),ALLOCATABLE :: testVector,testDummy,refVector
CLASS(VectorType),ALLOCATABLE :: testVec_1g,testVec_mg

#ifdef HAVE_MPI
INTEGER :: mpierr
CALL MPI_Init(mpierr)
#endif
!Configure exception handler for test
CALL e%setStopOnError(.FALSE.)
CALL e%setQuietMode(.TRUE.)
CALL eParams%addSurrogate(e)
CALL ePreCondType%addSurrogate(e)

CREATE_TEST('Test RSOR Preconditioner')

CALL setupRSORTest()
REGISTER_SUBTEST('Test RSOR Preconditioner Type',testRSOR_PreCondType)
CALL clearTest()

FINALIZE_TEST()

#ifdef HAVE_MPI
CALL MPI_Finalize(mpierr)
#endif
!
!===============================================================================
CONTAINS
!
!-------------------------------------------------------------------------------
SUBROUTINE setupRSORTest()
  INTEGER(SIK) :: i,j,numnonzero
  REAL(SRK) :: tmpreal1(9*9),tmpreal2(9)

  CALL PListRSOR%add('PCType->numblocks',3)
  CALL PListRSOR%add('PCType->omega',1.0_SRK)
  CALL PListVec%add('VectorType->n',9)
  ALLOCATE(RealVectorType :: testVector)
  ALLOCATE(RealVectorType :: refVector)
  CALL testVector%init(PListVec)
  CALL refVector%init(PListVec)
  CALL PListMat%add('MatrixType->n',9)
  CALL PListMat%add('MatrixType->m',9)
  CALL PListMat%add('MatrixType->isSym',.FALSE.)
  ALLOCATE(DenseSquareMatrixType :: testDenseMatrix)
  CALL testDenseMatrix%init(PListMat)

  tmpreal1=(/-64_SRK, 16_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
              16_SRK,-64_SRK, 16_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
               0_SRK, 16_SRK,-64_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,&
              16_SRK,  0_SRK,  0_SRK,-64_SRK, 16_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,&
               0_SRK, 16_SRK,  0_SRK, 16_SRK,-64_SRK, 16_SRK,  0_SRK, 16_SRK,  0_SRK,&
               0_SRK,  0_SRK, 16_SRK,  0_SRK, 16_SRK,-64_SRK,  0_SRK,  0_SRK, 16_SRK,&
               0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,-64_SRK, 16_SRK,  0_SRK,&
               0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK, 16_SRK,-64_SRK, 16_SRK,&
               0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK, 16_SRK,-64_SRK/)

  !setup the dense matrixk and count the number of nonzeroentries
  numnonzero=0
  DO i=1,9
    DO j=1,9
      CALL testDenseMatrix%set(i,j,tmpreal1((i-1)*9+j))
      IF(tmpreal1((i-1)*9+j) /= 0_SRK) numnonzero=numnonzero+1
    ENDDO
  ENDDO

  !setup the sparse version of the matrix
  CALL PListMat%add('MatrixType->nnz',numnonzero)
  ALLOCATE(SparseMatrixType :: testSparseMatrix)
  CALL testSparseMatrix%init(PListMat)
  SELECT TYPE(testSparseMatrix); TYPE IS(SparseMatrixType)
    DO i=1,9
      DO j=1,9
        IF(tmpreal1((i-1)*9+j) /= 0_SRK)THEN
          CALL testSparseMatrix%setShape(i,j,tmpreal1((i-1)*9+j))
        ENDIF
      ENDDO
    ENDDO
  ENDSELECT

  !setup the banded version of the matrix
  ALLOCATE(BandedMatrixType :: testBandedMatrix)
  CALL testBandedMatrix%init(PListMat)
  SELECT TYPE(testBandedMatrix); TYPE IS(BandedMatrixType)
    DO i=1,9
      DO j=1,9
        IF(tmpreal1((i-1)*9+j) /= 0_SRK) THEN
          CALL testBandedMatrix%set(i,j,tmpreal1((i-1)*9+j))
        ENDIF
      ENDDO
    ENDDO
    CALL testBandedMatrix%assemble()
  ENDSELECT

  tmpreal2=(/-16.0_SRK,                  &
              -1.95943487863577E-15_SRK, &
              16.0_SRK,                  &
              25.1327412287183_SRK,      &
               3.07787310995486E-15_SRK, &
             -25.1327412287183_SRK,      &
             -16.0000000000000_SRK,      &
              -1.95943487863576E-15_SRK, &
              16.0000000000000_SRK/)
  SELECT TYPE(testVector); TYPE IS(RealVectorType)
    testVector%b(:)=tmpreal2(:)
  ENDSELECT

  tmpreal2=(/0.15182522957531913_SRK,     &
             7.4014868308343768E-018_SRK, &
            -0.15182522957531916_SRK,     &
            -0.26769908169872342_SRK,     &
            -2.9605947323337507E-017_SRK, &
             0.26769908169872342_SRK,     &
             0.15182522957531913_SRK,     &
             7.4014868308343768E-018_SRK, &
            -0.15182522957531916_SRK/)
  SELECT TYPE(refVector); TYPE IS(RealVectorType)
    refVector%b(:) = tmpreal2(:)
  ENDSELECT

ENDSUBROUTINE setupRSORTest
!
!-------------------------------------------------------------------------------
SUBROUTINE testRSOR_PreCondType()
  CLASS(SOR_PreCondType),ALLOCATABLE :: testSOR
  INTEGER(SIK) :: i,j,k
  REAL(SRK) :: trv1(9*9),trv2(3*3*3)
  REAL(SRK) :: refLpU(9,9),refLU(3,3,3)
  REAL(SRK) :: vecsave(9)

  ALLOCATE(RSOR_PreCondType :: testSOR)
  !data for checking that the setup is correct
  trv1=(/ 0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
          0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
          0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,&
         16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,&
          0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,&
          0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,&
          0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
          0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK,&
          0_SRK,  0_SRK,  0_SRK,  0_SRK,  0_SRK, 16_SRK,  0_SRK,  0_SRK,  0_SRK/)

  DO i=1,9
    DO j=1,9
      refLpU(i,j)=trv1((i-1)*9+j)
    ENDDO
  ENDDO

  trv2=(/-64.0_SRK, -0.25_SRK, -0.00_SRK,                &
          16.0_SRK,-60.00_SRK, -0.26666666666666666_SRK, &
           0.0_SRK, 16.00_SRK,-59.733333333333334_SRK,   &
         -64.0_SRK, -0.25_SRK, -0.0_SRK,                 &
          16.0_SRK,-60.00_SRK, -0.26666666666666666_SRK, &
           0.0_SRK, 16.00_SRK,-59.733333333333334_SRK,   &
         -64.0_SRK, -0.25_SRK, -0.0_SRK,                 &
          16.0_SRK,-60.00_SRK, -0.26666666666666666_SRK, &
           0.0_SRK, 16.00_SRK,-59.733333333333334_SRK/)

  DO k=1,3
    DO i=1,3
      DO j=1,3
        refLU(j,i,k)=trv2((i-1)*3+j+(k-1)*9)
      ENDDO
    ENDDO
  ENDDO

  SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
    vecsave=tv%b
  ENDSELECT

  !check if it works for dense matrices
  COMPONENT_TEST('RSOR_PreCondType, DenseMatrixType')
  IF(testDenseMatrix%isInit .AND. testVector%isInit) THEN
    ! Check %init
    CALL testSOR%init(testDenseMatrix,PListRSOR)

    ASSERT(testSOR%isInit,'DenseSquareMatrixType RSOR%isInit')
    ASSERT(ASSOCIATED(testSOR%A),'DenseSquareMatrixType ASSOCIATED(RSOR%LU%A)')
    ASSERT(testSOR%LpU%isInit,'DenseSquareMatrixType RSOR%LpU%isInit')
    SELECT TYPE(LpU => testSOR%LpU); TYPE IS(DenseSquareMatrixType)
      SELECT TYPE(A => testSOR%A); TYPE IS(DenseSquareMatrixType)
        ASSERT(ALL(LpU%a .APPROXEQA. A%a),'DenseSquareMatrixType RSOR%LpU%a')
      ENDSELECT
    CLASS DEFAULT
      ASSERT(.FALSE.,'DenseSquareMatrixType RSOR%LpU TYPE IS(DenseSquareMatrixType)')
    ENDSELECT

    ! Check %setup
    CALL testSOR%setup()
    SELECT TYPE(LpU => testSOR%LpU); TYPE IS(DenseSquareMatrixType)
      ASSERT(ALL(LpU%a .APPROXEQA. refLpU),'RSOR%LpU%a Correct')
    ENDSELECT
    DO k=1,3
      SELECT TYPE(LU => testSOR%LU(k)); TYPE IS(DenseSquareMatrixType)
        DO i=1,3
          DO j=1,3
            ASSERT(LU%a(i,j) .APPROXEQA. refLU(i,j,k),'RSOR%LU(k)%a Correct')
          ENDDO
        ENDDO
        FINFO() 'Result:',LU%a,'Solution:',refLU(:,:,k)
      ENDSELECT
    ENDDO

    ! Check %apply
    CALL testSOR%apply(testVector)
    SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
      SELECT TYPE(rv => refVector); TYPE IS(RealVectorType)
        ASSERT(ALL(tv%b .APPROXEQA. rv%b),'DenseSquareMatrixType RSOR%apply(vector)')
        FINFO() 'Result:',tv%b,'Solution:',rv%b
      ENDSELECT
    ENDSELECT

    ! Check %clear
    CALL testSOR%clear()
    ASSERT(.NOT.(testSOR%isInit),'DenseSquareMatrixType .NOT.(RSOR%SOR%isInit)')
    ASSERT(.NOT.(ASSOCIATED(testSOR%A)),'DenseSquareMatrixType .NOT.(ASSOCIATED(RSOR%SOR%A))')
    ASSERT(.NOT.(ALLOCATED(testSOR%LpU)),'DenseSquareMatrixType .NOT.(ASSOCIATED(RSOR%SOR%LpU))')
  ELSE
    ASSERT(testDenseMatrix%isInit,'TestDenseMatrix Initialization')
    ASSERT(testVector%isInit,'TestVector Initialization')
  ENDIF

  SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
    tv%b=vecsave
  ENDSELECT

  !check if it works for sparse matrices
  COMPONENT_TEST('RSOR_PreCondType, SparseMatrixType')
  IF(testSparseMatrix%isInit .AND. testVector%isInit) THEN
    ! Check %init
    CALL testSOR%init(testSparseMatrix,PListRSOR)
    ASSERT(testSOR%isInit,'SparseMatrixType RSOR%isInit')
    ASSERT(ASSOCIATED(testSOR%A),'SparseMatrixType ASSOCIATED(RSOR%LU%A)')
    ASSERT(testSOR%LpU%isInit,'SparseMatrixType RSOR%LpU%isInit')
    SELECT TYPE(LpU => testSOR%LpU); TYPE IS(SparseMatrixType)
      SELECT TYPE(A => testSOR%A); TYPE IS(SparseMatrixType)
        ASSERT(ALL(LpU%a .APPROXEQA. A%a),'SparseMatrixType RSOR%LpU%a')
      ENDSELECT
    CLASS DEFAULT
      ASSERT(.FALSE.,'SparseMatrixType RSOR%LpU TYPE IS(SparseMatrixType)')
    ENDSELECT

    ! Check %setup
    CALL testSOR%setup()
    !SELECT TYPE(LpU => testSOR%LpU); TYPE IS(SparseMatrixType)
    !  ASSERT(ALL(LpU%a .APPROXEQA. refLpU),'RSOR%LpU%a Correct')
    !ENDSELECT
    DO k=1,3
      SELECT TYPE(LU => testSOR%LU(k)); TYPE IS(DenseSquareMatrixType)
        DO i=1,3
          DO j=1,3
            ASSERT(LU%a(i,j) .APPROXEQA. refLU(i,j,k),'RSOR%LU(k)%a Correct')
          ENDDO
        ENDDO
        FINFO() 'Result:',LU%a,'Solution:',refLU(:,:,k)
      ENDSELECT
    ENDDO

    ! Check %apply
    CALL testSOR%apply(testVector)
    SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
      SELECT TYPE(rv => refVector); TYPE IS(RealVectorType)
        ASSERT(ALL(tv%b .APPROXEQA. rv%b),'SparseMatrixType RSOR%apply(vector)')
        FINFO() 'Result:',tv%b,'Solution:',rv%b
      ENDSELECT
    ENDSELECT

    ! Check %clear
    CALL testSOR%clear()
    ASSERT(.NOT.(testSOR%isInit),'SparseMatrixType .NOT.(RSOR%SOR%isInit)')
    ASSERT(.NOT.(ASSOCIATED(testSOR%A)),'SparseMatrixType .NOT.(ASSOCIATED(RSOR%SOR%A))')
    ASSERT(.NOT.(ALLOCATED(testSOR%LpU)),'SparseMatrixType .NOT.(ASSOCIATED(RSOR%SOR%LpU))')
  ELSE
    ASSERT(testDenseMatrix%isInit,'TestSparseMatrix Initialization')
    ASSERT(testVector%isInit,'TestVector Initialization')
  ENDIF

  SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
    tv%b=vecsave
  ENDSELECT

  !check if it works for banded matrices
  COMPONENT_TEST('RSOR_PreCondType, BandedMatrixType')
  IF(testBandedMatrix%isInit .AND. testVector%isInit) THEN
    ! Check %init
    CALL testSOR%init(testBandedMatrix,PListRSOR)
    ASSERT(testSOR%isInit,'BandedMatrixType RSOR%isInit')
    ASSERT(ASSOCIATED(testSOR%A),'BandedMatrixType ASSOCIATED(RSOR%LU%A)')
    ASSERT(testSOR%LpU%isInit,'BandedMatrixType RSOR%LpU%isInit')

    ! Check %setup
    CALL testSOR%setup()
    DO k=1,3
      SELECT TYPE(LU => testSOR%LU(k)); TYPE IS(DenseSquareMatrixType)
        DO i=1,3
          DO j=1,3
            ASSERT(LU%a(i,j) .APPROXEQA. refLU(i,j,k),'RSOR%LU(k)%a Correct')
          ENDDO
        ENDDO
        FINFO() 'Result:',LU%a,'Solution:',refLU(:,:,k)
      ENDSELECT
    ENDDO

    ! Check %apply
    CALL testSOR%apply(testVector)
    SELECT TYPE(tv => testVector); TYPE IS(RealVectorType)
      SELECT TYPE(rv => refVector); TYPE IS(RealVectorType)
        ASSERT(ALL(tv%b .APPROXEQA. rv%b),'BandedMatrixType RSOR%apply(vector)')
        FINFO() 'Result:',tv%b,'Solution:',rv%b
      ENDSELECT
    ENDSELECT

    ! Check %clear
    CALL testSOR%clear()
    ASSERT(.NOT.(testSOR%isInit),'BandedMatrixType .NOT.(RSOR%SOR%isInit)')
    ASSERT(.NOT.(ASSOCIATED(testSOR%A)),'BandedMatrixType .NOT.(ASSOCIATED(RSOR%SOR%A))')
    ASSERT(.NOT.(ALLOCATED(testSOR%LpU)),'BandedMatrixType .NOT.(ASSOCIATED(RSOR%SOR%LpU))')
  ELSE
    ASSERT(testDenseMatrix%isInit,'TestBandedMatrix Initialization')
    ASSERT(testVector%isInit,'TestVector Initialization')
  ENDIF

  DEALLOCATE(testSOR)
ENDSUBROUTINE testRSOR_PreCondtype
!
!-------------------------------------------------------------------------------
SUBROUTINE clearTest()

  CALL PListMat%clear()
  CALL PListVec%clear()
  CALL MatrixTypes_Clear_ValidParams()
  IF(ALLOCATED(testBandedMatrix)) CALL testBandedMatrix%clear()
  IF(ALLOCATED(testSparseMatrix)) CALL testSparseMatrix%clear()
  IF(ALLOCATED(testDenseMatrix)) CALL testDenseMatrix%clear()
  IF(ALLOCATED(testMatrix)) CALL testMatrix%clear()
  IF(ALLOCATED(testVec_1g)) CALL testVec_1g%clear()
  IF(ALLOCATED(testVec_mg)) CALL testVec_mg%clear()
  IF(ALLOCATED(testVector)) CALL testVector%clear()
  IF(ALLOCATED(testDummy)) CALL testDummy%clear()
  IF(ALLOCATED(testDummy)) CALL refVector%clear()

  IF(ALLOCATED(testBandedMatrix)) DEALLOCATE(testBandedMatrix)
  IF(ALLOCATED(testSparseMatrix)) DEALLOCATE(testSparseMatrix)
  IF(ALLOCATED(testDenseMatrix)) DEALLOCATE(testDenseMatrix)
  IF(ALLOCATED(testMatrix)) DEALLOCATE(testMatrix)
  IF(ALLOCATED(testVec_1g)) DEALLOCATE(testVec_1g)
  IF(ALLOCATED(testVec_mg)) DEALLOCATE(testVec_mg)
  IF(ALLOCATED(testVector)) DEALLOCATE(testVector)
  IF(ALLOCATED(testDummy)) DEALLOCATE(testDummy)
  IF(ALLOCATED(refVector)) DEALLOCATE(refVector)

ENDSUBROUTINE clearTest
!
ENDPROGRAM testRSORPrecon


      PROGRAM xdf1dim
C     driver for routine df1dim
      INTEGER NDIM,NMAX
      PARAMETER(NDIM=3,NMAX=50)
      INTEGER i,j,ncom
      REAL pcom,xicom
      COMMON /f1com/ pcom(NMAX),xicom(NMAX),ncom
      REAL df1dim,p(NDIM),xi(NDIM)
      EXTERNAL df1dim
      DATA p/0.0,0.0,0.0/
      ncom=NDIM
      write(*,'(/1x,a)') 'Enter vector direction along which to'
      write(*,'(1x,a)') 'plot the function. Minimum is in the'
      write(*,'(1x,a)') 'direction 1.0,1.0,1.0 - Enter X,Y,Z:'
      read(*,*) (xi(i),i=1,3)
      do 11 j=1,NDIM
        pcom(j)=p(j)
        xicom(j)=xi(j)
11    continue
      call scrsho(df1dim)
      END
      SUBROUTINE dfunc(x,df)
      INTEGER i
      REAL x(3),df(3)
      do 11 i=1,3
        df(i)=(x(i)-1.0)**2
11    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xdf1dim.for


C-----------------------------------------------------------------------ZXCG0030
C                                                                       ZXCG0040
C   COMPUTER            - HP9000/DOUBLE                                 ZXCG0050
C                                                                       ZXCG0060
C   LATEST REVISION     - NOVEMBER 1, 1979                              ZXCG0070
C                                                                       ZXCG0080
C   PURPOSE             - A CONJUGATE GRADIENT ALGORITHM FOR FINDING    ZXCG0090
C                           THE MINIMUM OF A FUNCTION OF N VARIABLES    ZXCG0100
C                                                                       ZXCG0110
C   USAGE               - CALL ZXCGR (FUNCT,N,ACC,MAXFN,DFPRED,X,G,F,W, ZXCG0120
C                           IER)                                        ZXCG0130
C                                                                       ZXCG0140
C   ARGUMENTS    FUNCT  - A USER SUPPLIED SUBROUTINE WHICH CALCULATES   ZXCG0150
C                           THE OBJECTIVE FUNCTION AND ITS GRADIENT     ZXCG0160
C                           FOR GIVEN PARAMETER VALUES                  ZXCG0170
C                           X(1),X(2),...,X(N).                         ZXCG0180
C                           THE CALLING SEQUENCE HAS THE FOLLOWING FORM ZXCG0190
C                           CALL FUNCT (N,X,F,G)                        ZXCG0200
C                           WHERE X AND G ARE VECTORS OF LENGTH N.      ZXCG0210
C                           THE SCALAR F IS FOR THE OBJECTIVE FUNCTION. ZXCG0220
C                           G(1), G(2), ..., G(N) ARE FOR THE COMPONENTSZXCG0230
C                           OF THE GRADIENT OF F.                       ZXCG0240
C                           FUNCT MUST APPEAR IN AN EXTERNAL STATEMENT  ZXCG0250
C                           IN THE CALLING PROGRAM. FUNCT MUST NOT      ZXCG0260
C                           ALTER THE VALUES OF X(I),I=1,...,N OR N.    ZXCG0270
C                N      - THE NUMBER OF PARAMETERS OF THE OBJECTIVE     ZXCG0280
C                           FUNCTION. (INPUT) (I.E.,THE LENGTH OF X)    ZXCG0290
C                ACC    - CONVERGENCE CRITERION. (INPUT)                ZXCG0300
C                           THE CALCULATION ENDS WHEN THE SUM OF SQUARESZXCG0310
C                           OF THE COMPONENTS OF G IS LESS THAN ACC.    ZXCG0320
C                MAXFN  - MAXIMUM NUMBER OF FUNCTION EVALUATIONS (I.E., ZXCG0330
C                           CALLS TO SUBROUTINE FUNCT) ALLOWED. (INPUT) ZXCG0340
C                           IF MAXFN IS SET TO ZERO, THEN THERE IS      ZXCG0350
C                           NO RESTRICTION ON THE NUMBER OF FUNCTION    ZXCG0360
C                           EVALUATIONS.                                ZXCG0370
C                DFPRED - A ROUGH ESTIMATE OF THE EXPECTED REDUCTION    ZXCG0380
C                           IN F, WHICH IS USED TO DETERMINE THE SIZE   ZXCG0390
C                           OF THE INITIAL CHANGE TO X. (INPUT)         ZXCG0400
C                           NOTE THAT DFPRED IS THE EXPECTED REDUCTION  ZXCG0410
C                           ITSELF, AND DOES NOT DEPEND ON ANY RATIOS.  ZXCG0420
C                           A BAD VALUE OF DFPRED CAUSES AN ERROR       ZXCG0430
C                           MESSAGE, WITH IER=129, AND A RETURN ON THE  ZXCG0440
C                           FIRST ITERATION. (SEE THE DESCRIPTION OF    ZXCG0450
C                           IER BELOW)                                  ZXCG0460
C                X      - VECTOR OF LENGTH N CONTAINING PARAMETER       ZXCG0470
C                           VALUES.                                     ZXCG0480
C                         ON INPUT, X MUST CONTAIN THE INITIAL          ZXCG0490
C                           PARAMETER ESTIMATES.                        ZXCG0500
C                         ON OUTPUT, X CONTAINS THE FINAL PARAMETER     ZXCG0510
C                           ESTIMATES AS DETERMINED BY ZXCGR.           ZXCG0520
C                G      - A VECTOR OF LENGTH N CONTAINING THE           ZXCG0530
C                           COMPONENTS OF THE GRADIENT OF F AT THE      ZXCG0540
C                           FINAL PARAMETER ESTIMATES. (OUTPUT)         ZXCG0550
C                F      - A SCALAR CONTAINING THE VALUE OF THE FUNCTION ZXCG0560
C                           AT THE FINAL PARAMETER ESTIMATES. (OUTPUT)  ZXCG0570
C                W      - WORK VECTOR OF LENGTH 6*N.                    ZXCG0580
C                IER    - ERROR PARAMETER. (OUTPUT)                     ZXCG0590
C                         IER = 0 IMPLIES THAT CONVERGENCE WAS          ZXCG0600
C                           ACHIEVED AND NO ERRORS OCCURRED.            ZXCG0610
C                         TERMINAL ERROR                                ZXCG0620
C                           IER = 129 IMPLIES THAT THE LINE SEARCH OF   ZXCG0630
C                             AN INTEGRATION WAS ABANDONED. THIS        ZXCG0640
C                             ERROR MAY BE CAUSED BY AN ERROR IN THE    ZXCG0650
C                             GRADIENT.                                 ZXCG0660
C                           IER = 130 IMPLIES THAT THE CALCULATION      ZXCG0670
C                             CANNOT CONTINUE BECAUSE THE SEARCH        ZXCG0680
C                             DIRECTION IS UPHILL.                      ZXCG0690
C                           IER = 131 IMPLIES THAT THE ITERATION WAS    ZXCG0700
C                             TERMINATED BECAUSE MAXFN WAS EXCEEDED.    ZXCG0710
C                           IER = 132 IMPLIES THAT THE CALCULATION      ZXCG0720
C                             WAS TERMINATED BECAUSE TWO CONSECUTIVE    ZXCG0730
C                             ITERATIONS FAILED TO REDUCE F.            ZXCG0740
C                                                                       ZXCG0750
C   PRECISION/HARDWARE  - SINGLE AND DOUBLE/H32                         ZXCG0760
C                       - SINGLE/H36,H48,H60                            ZXCG0770
C                                                                       ZXCG0780
C   REQD. IMSL ROUTINES - UERTST,UGETIO                                 ZXCG0790
C                                                                       ZXCG0800
C   NOTATION            - INFORMATION ON SPECIAL NOTATION AND           ZXCG0810
C                           CONVENTIONS IS AVAILABLE IN THE MANUAL      ZXCG0820
C                           INTRODUCTION OR THROUGH IMSL ROUTINE UHELP  ZXCG0830
C                                                                       ZXCG0840
C   REMARKS  1.  THE ROUTINE INCLUDES NO THOROUGH CHECKS ON THE PART    ZXCG0850
C                OF THE USER PROGRAM THAT CALCULATES THE DERIVATIVES    ZXCG0860
C                OF THE OBJECTIVE FUNCTION. THEREFORE, BECAUSE          ZXCG0870
C                DERIVATIVE CALCULATION IS A FREQUENT SOURCE OF         ZXCG0880
C                ERROR, THE USER SHOULD VERIFY INDEPENDENTLY THE        ZXCG0890
C                CORRECTNESS OF THE DERIVATIVES THAT ARE GIVEN TO       ZXCG0900
C                THE ROUTINE.                                           ZXCG0910
C            2.  BECAUSE OF THE CLOSE RELATION BETWEEN THE CONJUGATE    ZXCG0920
C                GRADIENT METHOD AND THE METHOD OF STEEPEST DESCENTS,   ZXCG0930
C                IT IS VERY HELPFUL TO CHOOSE THE SCALE OF THE          ZXCG0940
C                VARIABLES IN A WAY THAT BALANCES THE MAGNITUDES OF     ZXCG0950
C                THE COMPONENTS OF A TYPICAL DERIVATE VECTOR. IT        ZXCG0960
C                CAN BE PARTICULARLY INEFFICIENT IF A FEW COMPONENTS    ZXCG0970
C                OF THE GRADIENT ARE MUCH LARGER THAN THE REST.         ZXCG0980
C            3.  IF THE VALUE OF THE PARAMETER ACC IN THE ARGUMENT      ZXCG0990
C                LIST OF THE ROUTINE IS SET TO ZERO, THEN THE           ZXCG1000
C                SUBROUTINE WILL CONTINUE ITS CALCULATION UNTIL IT      ZXCG1010
C                STOPS REDUCING THE OBJECTIVE FUNCTION. IN THIS CASE    ZXCG1020
C                THE USUAL BEHAVIOUR IS THAT CHANGES IN THE             ZXCG1030
C                OBJECTIVE FUNCTION BECOME DOMINATED BY COMPUTER        ZXCG1040
C                ROUNDING ERRORS BEFORE PRECISION IS LOST IN THE        ZXCG1050
C                GRADIENT VECTOR. THEREFORE, BECAUSE THE POINT OF       ZXCG1060
C                VIEW HAS BEEN TAKEN THAT THE USER REQUIRES THE         ZXCG1070
C                LEAST POSSIBLE VALUE OF THE FUNCTION, A VALUE OF       ZXCG1080
C                THE OBJECTIVE FUNCTION THAT IS SMALL DUE TO            ZXCG1090
C                COMPUTER ROUNDING ERRORS CAN PREVENT FURTHER           ZXCG1100
C                PROGRESS. HENCE THE PRECISION IN THE FINAL VALUES      ZXCG1110
C                OF THE VARIABLES MAY BE ONLY ABOUT HALF THE            ZXCG1120
C                NUMBER OF SIGNIFICANT DIGITS IN THE COMPUTER           ZXCG1130
C                ARITHMETIC, BUT THE LEAST VALUE OF F IS USUALLY        ZXCG1140
C                FOUND TO QUITE HIGH ACCURACY.                          ZXCG1150
C                                                                       ZXCG1160
C   COPYRIGHT           - 1978 BY IMSL, INC. ALL RIGHTS RESERVED.       ZXCG1170
C                                                                       ZXCG1180
C   WARRANTY            - IMSL WARRANTS ONLY THAT IMSL TESTING HAS BEEN ZXCG1190
C                           APPLIED TO THIS CODE. NO OTHER WARRANTY,    ZXCG1200
C                           EXPRESSED OR IMPLIED, IS APPLICABLE.        ZXCG1210
C                                                                       ZXCG1220
C-----------------------------------------------------------------------ZXCG1230
C                                                                       ZXCG1240
      SUBROUTINE ZXCGRF77  (FUNCT,N,ACC,MAXFN,DFPRED,X,G,F,W,IER)          ZXCG1250
      external FUNCT
C                                  SPECIFICATIONS FOR ARGUMENTS         ZXCG1260
      INTEGER            N,MAXFN,IER                                    ZXCG1270
      DOUBLE PRECISION   ACC,DFPRED,X(N),G(N),F,W(1)                    ZXCG1280
C                                  SPECIFICATIONS FOR LOCAL VARIABLES   ZXCG1290
      INTEGER            MAXLIN,MXFCON,I,IGINIT,IGOPT,IRETRY,IRSDG,     ZXCG1300
     1                   IRSDX,ITERC,ITERFM,ITERRS,IXOPT,NCALLS,NFBEG,  ZXCG1310
     2                   NFOPT                                          ZXCG1320
      DOUBLE PRECISION   BETA,DDSPLN,DFPR,FCH,FINIT,FMIN,GAMDEN,GAMA,   ZXCG1330
     1                   GINIT,GMIN,GNEW,GSPLN,GSQRD,SBOUND,STEP,STEPCH,ZXCG1340
     2                   STMIN,SUM,WORK                                 ZXCG1350
      DATA               MAXLIN/5/,MXFCON/2/                            ZXCG1360
C                                  FIRST EXECUTABLE STATEMENT           ZXCG1370
      IER = 0                                                           ZXCG1380
C                                  THE WORKING SPACE ARRAY IS SPLIT     ZXCG1390
C                                    INTO SIX VECTORS OF LENGTH N. THE  ZXCG1400
C                                    FIRST PART IS USED FOR THE SEARCH  ZXCG1410
C                                    DIRECTION OF AN ITERATION. THE     ZXCG1420
C                                    SECOND AND THIRD PARTS CONTAIN THE ZXCG1430
C                                    INFORMATION THAT IS REQUIRED BY    ZXCG1440
C                                    THE CONJUGACY CONDITIONS OF THE    ZXCG1450
C                                    RESTART PROCEDURE. THE FOURTH PART ZXCG1460
C                                    CONTAINS THE GRADIENT AT THE START ZXCG1470
C                                    OF AN ITERATION. THE FIFTH PART    ZXCG1480
C                                    CONTAINS THE PARAMETERS THAT GIVE  ZXCG1490
C                                    THE LEAST CALCULATED VALUE OF F.   ZXCG1500
C                                    THE SIXTH PART CONTAINS THE        ZXCG1510
C                                    GRADIENT VECTOR WHERE F IS LEAST.  ZXCG1520
      IRSDX = N                                                         ZXCG1530
      IRSDG = IRSDX+N                                                   ZXCG1540
      IGINIT = IRSDG+N                                                  ZXCG1550
      IXOPT = IGINIT+N                                                  ZXCG1560
      IGOPT = IXOPT+N                                                   ZXCG1570
C                                  SET SOME PARAMETERS TO BEGIN THE     ZXCG1580
C                                    CALCULATION. ITERC AND             ZXCG1590
C                                    NCALLS COUNT THE NUMBER OF         ZXCG1600
C                                    ITERATIONS AND CALLS OF FUNCT.     ZXCG1610
C                                    ITERFM IS THE NUMBER OF THE MOST   ZXCG1620
C                                    RECENT ITERATION THAT DECREASES F. ZXCG1630
      ITERC = 0                                                         ZXCG1640
      NCALLS = 0                                                        ZXCG1650
      ITERFM = ITERC                                                    ZXCG1660
C                                  CALL SUBROUTINE FUNCT. LET THE       ZXCG1670
C                                    INITIAL SEARCH DIRECTION BE MINUS  ZXCG1680
C                                    THE GRADIENT VECTOR. USUALLY THE   ZXCG1690
C                                    PARAMETER ITERRS GIVES THE         ZXCG1700
C                                    ITERATION NUMBER OF THE MOST       ZXCG1710
C                                    RECENT RESTART, BUT IT IS SET TO   ZXCG1720
C                                    ZERO WHEN THE STEEPEST DESCENT     ZXCG1730
C                                    DIRECTION IS USED.                 ZXCG1740
    5 NCALLS = NCALLS+1                                                 ZXCG1750
      CALL FUNCT(N,X,F,G)                                                    ZXCG1760
      IF (NCALLS.GE.2) GO TO 20                                         ZXCG1770
   10 DO 15 I=1,N                                                       ZXCG1780
   15 W(I) = -G(I)                                                      ZXCG1790
      ITERRS = 0                                                        ZXCG1800
      IF (ITERC.GT.0) GO TO 80                                          ZXCG1810
C                                  SET SUM TO G SQUARED. GMIN AND GNEW  ZXCG1820
C                                    ARE THE OLD AND THE NEW            ZXCG1830
C                                    DIRECTIONAL DERIVATIVES ALONG THE  ZXCG1840
C                                    CURRENT SEARCH DIRECTION. LET FCH  ZXCG1850
C                                    BE THE DIFFERENCE BETWEEN F AND    ZXCG1860
C                                    THE PREVIOUS BEST VALUE OF THE     ZXCG1870
C                                    OBJECTIVE FUNCTION.                ZXCG1880
   20 GNEW = 0.0D0                                                      ZXCG1890
      SUM = 0.0D0                                                       ZXCG1900
      DO 25 I=1,N                                                       ZXCG1910
         GNEW = GNEW+W(I)*G(I)                                          ZXCG1920
   25 SUM = SUM+G(I)**2                                                 ZXCG1930
      IF (NCALLS.EQ.1) GO TO 35                                         ZXCG1940
      FCH = F-FMIN                                                      ZXCG1950
C                                  STORE THE VALUES OF X, F AND G, IF   ZXCG1960
C                                    THEY ARE THE BEST THAT HAVE BEEN   ZXCG1970
C                                    CALCULATED SO FAR, AND NOTE G      ZXCG1980
C                                    SQUARED AND THE VALUE OF NCALLS.   ZXCG1990
C                                    TEST FOR CONVERGENCE.              ZXCG2000
      IF (FCH) 35,30,50                                                 ZXCG2010
   30 IF (GNEW/GMIN.LT.-1.0D0) GO TO 45                                 ZXCG2020
   35 FMIN = F                                                          ZXCG2030
      GSQRD = SUM                                                       ZXCG2040
      NFOPT = NCALLS                                                    ZXCG2050
      DO 40 I=1,N                                                       ZXCG2060
         W(IXOPT+I) = X(I)                                              ZXCG2070
   40 W(IGOPT+I) = G(I)                                                 ZXCG2080
   45 IF (SUM.LE.ACC) GO TO 9005                                        ZXCG2090
C                                  TEST IF THE VALUE OF MAXFN ALLOWS    ZXCG2100
C                                    ANOTHER CALL OF FUNCT.             ZXCG2110
   50 IF (NCALLS.NE.MAXFN) GO TO 55                                     ZXCG2120
      IER = 131                                                         ZXCG2130
      GO TO 9000                                                        ZXCG2140
   55 IF (NCALLS.GT.1) GO TO 100                                        ZXCG2150
C                                  SET DFPR TO THE ESTIMATE OF THE      ZXCG2160
C                                    REDUCTION IN F GIVEN IN THE        ZXCG2170
C                                    ARGUMENT LIST, IN ORDER THAT THE   ZXCG2180
C                                    INITIAL CHANGE TO THE PARAMETERS   ZXCG2190
C                                    IS OF A SUITABLE SIZE. THE VALUE   ZXCG2200
C                                    OF STMIN IS USUALLY THE            ZXCG2210
C                                    STEP-LENGTH OF THE MOST RECENT     ZXCG2220
C                                    LINE SEARCH THAT GIVES THE LEAST   ZXCG2230
C                                    CALCULATED VALUE OF F.             ZXCG2240
      DFPR = DFPRED                                                     ZXCG2250
      STMIN = DFPRED/GSQRD                                              ZXCG2260
C                                  BEGIN THE ITERATION                  ZXCG2270
   80 ITERC = ITERC+1                                                   ZXCG2280
C                                  STORE THE INITIAL FUNCTION VALUE AND ZXCG2290
C                                    GRADIENT, CALCULATE THE INITIAL    ZXCG2300
C                                    DIRECTIONAL DERIVATIVE, AND BRANCH ZXCG2310
C                                    IF ITS VALUE IS NOT NEGATIVE. SET  ZXCG2320
C                                    SBOUND TO MINUS ONE TO INDICATE    ZXCG2330
C                                    THAT A BOUND ON THE STEP IS NOT    ZXCG2340
C                                    KNOWN YET, AND SET NFBEG TO THE    ZXCG2350
C                                    CURRENT VALUE OF NCALLS. THE       ZXCG2360
C                                    PARAMETER IRETRY SHOWS THE NUMBER  ZXCG2370
C                                    OF ATTEMPTS AT SATISFYING THE BETA ZXCG2380
C                                    CONDITION.                         ZXCG2390
      FINIT = F                                                         ZXCG2400
      GINIT = 0.0D0                                                     ZXCG2410
      DO 85 I=1,N                                                       ZXCG2420
         W(IGINIT+I) = G(I)                                             ZXCG2430
   85 GINIT = GINIT+W(I)*G(I)                                           ZXCG2440
      IF (GINIT.GE.0.0D0) GO TO 165                                     ZXCG2450
      GMIN = GINIT                                                      ZXCG2460
      SBOUND = -1.0D0                                                   ZXCG2470
      NFBEG = NCALLS                                                    ZXCG2480
      IRETRY = -1                                                       ZXCG2490
C                                  SET STEPCH SO THAT THE INITIAL       ZXCG2500
C                                    STEP-LENGTH IS CONSISTENT WITH THE ZXCG2510
C                                    PREDICTED REDUCTION IN F, SUBJECT  ZXCG2520
C                                    TO THE CONDITION THAT IT DOES NOT  ZXCG2530
C                                    EXCEED THE STEP-LENGTH OF THE      ZXCG2540
C                                    PREVIOUS ITERATION. LET STMIN BE   ZXCG2550
C                                    THE STEP TO THE LEAST CALCULATED   ZXCG2560
C                                    VALUE OF F.                        ZXCG2570
      STEPCH = DMIN1(STMIN,DABS(DFPR/GINIT))                            ZXCG2580
      STMIN = 0.0D0                                                     ZXCG2590
C                                  CALL SUBROUTINE FUNCT AT THE VALUE   ZXCG2600
C                                    OF X THAT IS DEFINED BY THE NEW    ZXCG2610
C                                    CHANGE TO THE STEP-LENGTH, AND LET ZXCG2620
C                                    THE NEW STEP-LENGTH BE STEP. THE   ZXCG2630
C                                    VARIABLE WORK IS USED AS WORK      ZXCG2640
C                                    SPACE.                             ZXCG2650
   90 STEP = STMIN+STEPCH                                               ZXCG2660
      WORK = 0.0D0                                                      ZXCG2670
      DO 95 I=1,N                                                       ZXCG2680
         X(I) = W(IXOPT+I)+STEPCH*W(I)                                  ZXCG2690
   95 WORK = DMAX1(WORK,DABS(X(I)-W(IXOPT+I)))                          ZXCG2700
      IF (WORK.GT.0.0D0) GO TO 5                                        ZXCG2710
C                                  TERMINATE THE LINE SEARCH IF STEPCH  ZXCG2720
C                                    IS EFFECTIVELY ZERO.               ZXCG2730
      IF (NCALLS.GT.NFBEG+1) GO TO 115                                  ZXCG2740
      IF (DABS(GMIN/GINIT)-0.2D0) 170,170,115                           ZXCG2750
C                                  LET SPLN BE THE QUADRATIC SPLINE     ZXCG2760
C                                    THAT INTERPOLATES THE CALCULATED   ZXCG2770
C                                    FUNCTION VALUES AND DIRECTIONAL    ZXCG2780
C                                    DERIVATIVES AT THE POINTS STMIN    ZXCG2790
C                                    AND STEP OF THE LINE SEARCH, WHERE ZXCG2800
C                                    THE KNOT OF THE SPLINE IS AT       ZXCG2810
C                                    0.5*(STMIN+STEP). REVISE STMIN,    ZXCG2820
C                                    GMIN AND SBOUND, AND SET DDSPLN TO ZXCG2830
C                                    THE SECOND DERIVATIVE OF SPLN AT   ZXCG2840
C                                    THE NEW STMIN. HOWEVER, IF FCH IS  ZXCG2850
C                                    ZERO, IT IS ASSUMED THAT THE       ZXCG2860
C                                    MAXIMUM ACCURACY IS ALMOST         ZXCG2870
C                                    ACHIEVED, SO DDSPLN IS CALCULATED  ZXCG2880
C                                    USING ONLY THE CHANGE IN THE       ZXCG2890
C                                    GRADIENT.                          ZXCG2900
  100 WORK = (FCH+FCH)/STEPCH-GNEW-GMIN                                 ZXCG2910
      DDSPLN = (GNEW-GMIN)/STEPCH                                       ZXCG2920
      IF (NCALLS.GT.NFOPT) SBOUND = STEP                                ZXCG2930
      IF (NCALLS.GT.NFOPT) GO TO 105                                    ZXCG2940
      IF (GMIN*GNEW.LE.0.0D0) SBOUND = STMIN                            ZXCG2950
      STMIN = STEP                                                      ZXCG2960
      GMIN = GNEW                                                       ZXCG2970
      STEPCH = -STEPCH                                                  ZXCG2980
  105 IF (FCH.NE.0.0D0) DDSPLN = DDSPLN+(WORK+WORK)/STEPCH              ZXCG2990
C                                                                       ZXCG3000
C                                  TEST FOR CONVERGENCE OF THE LINE     ZXCG3010
C                                    SEARCH, BUT FORCE AT LEAST TWO     ZXCG3020
C                                    STEPS TO BE TAKEN IN ORDER NOT TO  ZXCG3030
C                                    LOSE QUADRATIC TERMINATION.        ZXCG3040
      IF (GMIN.EQ.0.0D0) GO TO 170                                      ZXCG3050
      IF (NCALLS.LE.NFBEG+1) GO TO 120                                  ZXCG3060
      IF (DABS(GMIN/GINIT).LE.0.2D0) GO TO 170                          ZXCG3070
C                                  APPLY THE TEST THAT DEPENDS ON THE   ZXCG3080
C                                    PARAMETER MAXLIN.                  ZXCG3090
  110 IF (NCALLS.LT.NFOPT+MAXLIN) GO TO 120                             ZXCG3100
  115 IER = 129                                                         ZXCG3110
      GO TO 170                                                         ZXCG3120
C                                  SET STEPCH TO THE GREATEST CHANGE TO ZXCG3130
C                                    THE CURRENT VALUE OF STMIN THAT IS ZXCG3140
C                                    ALLOWED BY THE BOUND ON THE LINE   ZXCG3150
C                                    SEARCH. SET GSPLN TO THE GRADIENT  ZXCG3160
C                                    OF THE QUADRATIC SPLINE AT         ZXCG3170
C                                    (STMIN+STEPCH). HENCE CALCULATE    ZXCG3180
C                                    THE VALUE OF STEPCH THAT MINIMIZES ZXCG3190
C                                    THE SPLINE FUNCTION, AND THEN      ZXCG3200
C                                    OBTAIN THE NEW FUNCTION AND        ZXCG3210
C                                    GRADIENT VECTOR, FOR THIS VALUE OF ZXCG3220
C                                    THE CHANGE TO THE STEP-LENGTH.     ZXCG3230
  120 STEPCH = 0.5D0*(SBOUND-STMIN)                                     ZXCG3240
      IF (SBOUND.LT.-0.5D0) STEPCH = 9.0D0*STMIN                        ZXCG3250
      GSPLN = GMIN+STEPCH*DDSPLN                                        ZXCG3260
      IF (GMIN*GSPLN.LT.0.0D0) STEPCH = STEPCH*GMIN/(GMIN-GSPLN)        ZXCG3270
      GO TO 90                                                          ZXCG3280
C                                  CALCULATE THE VALUE OF BETA THAT     ZXCG3290
C                                    OCCURS IN THE NEW SEARCH           ZXCG3300
C                                    DIRECTION.                         ZXCG3310
  125 SUM = 0.0D0                                                       ZXCG3320
      DO 130 I=1,N                                                      ZXCG3330
  130 SUM = SUM+G(I)*W(IGINIT+I)                                        ZXCG3340
      BETA = (GSQRD-SUM)/(GMIN-GINIT)                                   ZXCG3350
C                                  TEST THAT THE NEW SEARCH DIRECTION   ZXCG3360
C                                    CAN BE MADE DOWNHILL. IF IT        ZXCG3370
C                                    CANNOT, THEN MAKE ONE ATTEMPT TO   ZXCG3380
C                                    IMPROVE THE ACCURACY OF THE LINE   ZXCG3390
C                                    SEARCH.                            ZXCG3400
      IF (DABS(BETA*GMIN).LE.0.2D0*GSQRD) GO TO 135                     ZXCG3410
      IRETRY = IRETRY+1                                                 ZXCG3420
      IF (IRETRY.LE.0) GO TO 110                                        ZXCG3430
C                                  APPLY THE TEST THAT DEPENDS ON THE   ZXCG3440
C                                    PARAMETER MXFCON.                  ZXCG3450
C                                    SET DFPR TO THE PREDICTED          ZXCG3460
C                                    REDUCTION IN F ON THE NEXT         ZXCG3470
C                                    ITERATION.                         ZXCG3480
  135 IF (F.LT.FINIT) ITERFM = ITERC                                    ZXCG3490
      IF (ITERC.LT.ITERFM+MXFCON) GO TO 140                             ZXCG3500
      IER = 132                                                         ZXCG3510
      GO TO 9000                                                        ZXCG3520
  140 DFPR = STMIN*GINIT                                                ZXCG3530
C                                  BRANCH IF A RESTART PROCEDURE IS     ZXCG3540
C                                    REQUIRED DUE TO THE ITERATION      ZXCG3550
C                                    NUMBER OR DUE TO THE SCALAR        ZXCG3560
C                                    PRODUCT OF CONSECUTIVE GRADIENTS.  ZXCG3570
      IF (IRETRY.GT.0) GO TO 10                                         ZXCG3580
      IF (ITERRS.EQ.0) GO TO 155                                        ZXCG3590
      IF (ITERC-ITERRS.GE.N) GO TO 155                                  ZXCG3600
      IF (DABS(SUM).GE.0.2D0*GSQRD) GO TO 155                           ZXCG3610
C                                  CALCULATE THE VALUE OF GAMA THAT     ZXCG3620
C                                    OCCURS IN THE NEW SEARCH           ZXCG3630
C                                    DIRECTION, AND SET SUM TO A SCALAR ZXCG3640
C                                    PRODUCT FOR THE TEST BELOW. THE    ZXCG3650
C                                    VALUE OF GAMDEN IS SET BY THE      ZXCG3660
C                                    RESTART PROCEDURE.                 ZXCG3670
      GAMA = 0.0D0                                                      ZXCG3680
      SUM = 0.0D0                                                       ZXCG3690
      DO 145 I=1,N                                                      ZXCG3700
         GAMA = GAMA+G(I)*W(IRSDG+I)                                    ZXCG3710
  145 SUM = SUM+G(I)*W(IRSDX+I)                                         ZXCG3720
      GAMA = GAMA/GAMDEN                                                ZXCG3730
C                                  RESTART IF THE NEW SEARCH DIRECTION  ZXCG3740
C                                    IS NOT SUFFICIENTLY DOWNHILL.      ZXCG3750
C                                                                       ZXCG3760
      IF (DABS(BETA*GMIN+GAMA*SUM).GE.0.2D0*GSQRD) GO TO 155            ZXCG3770
C                                                                       ZXCG3780
C                                  CALCULATE THE NEW SEARCH DIRECTION.  ZXCG3790
      DO 150 I=1,N                                                      ZXCG3800
  150 W(I) = -G(I)+BETA*W(I)+GAMA*W(IRSDX+I)                            ZXCG3810
      GO TO 80                                                          ZXCG3820
C                                  APPLY THE RESTART PROCEDURE.         ZXCG3830
  155 GAMDEN = GMIN-GINIT                                               ZXCG3840
      DO 160 I=1,N                                                      ZXCG3850
         W(IRSDX+I) = W(I)                                              ZXCG3860
         W(IRSDG+I) = G(I)-W(IGINIT+I)                                  ZXCG3870
  160 W(I) = -G(I)+BETA*W(I)                                            ZXCG3880
      ITERRS = ITERC                                                    ZXCG3890
      GO TO 80                                                          ZXCG3900
C                                  SET IER TO INDICATE THAT THE SEARCH  ZXCG3910
C                                    DIRECTION IS UPHILL.               ZXCG3920
  165 IER = 130                                                         ZXCG3930
C                                  ENSURE THAT F, X AND G ARE OPTIMAL.  ZXCG3940
  170 IF (NCALLS.EQ.NFOPT) GO TO 180                                    ZXCG3950
      F = FMIN                                                          ZXCG3960
      DO 175 I=1,N                                                      ZXCG3970
         X(I) = W(IXOPT+I)                                              ZXCG3980
  175 G(I) = W(IGOPT+I)                                                 ZXCG3990
  180 IF (IER.EQ.0) GO TO 125                                           ZXCG4000
 9000 CONTINUE                                                          ZXCG4010
c      CALL UERTST (IER,'ZXCGRF77 ')                                    ZXCG4020
 9005 RETURN                                                            ZXCG4030
      END                                                               ZXCG4040


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.
   PROGRAM GALAHAD_FDC_example
   USE GALAHAD_FDC_double                      ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )   ! set precision
   INTEGER, PARAMETER :: n = 4, m = 3, a_ne = 10
   INTEGER :: A_ptr( m + 1 ), A_col( a_ne )
   REAL ( KIND = wp ) :: A_val( a_ne ), C( m )
   INTEGER, ALLOCATABLE :: C_depen( : ) ! Remeber to nullify C_depen
   INTEGER :: n_depen
   TYPE ( SMT_type ) :: K
   TYPE ( SILS_factors ) :: FACTORS
   TYPE ( FDC_control_type ) :: control
   TYPE ( FDC_inform_type ) :: inform
   A_val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp, 2.0_wp, -4.0_wp, 6.0_wp,         &
             -8.0_wp, 5.0_wp, 10.0_wp /)
   A_col = (/ 1, 2, 3, 4, 1, 2, 3, 4, 2, 4 /)
   A_ptr = (/ 1, 5, 9, 11 /)
   C = (/ 5.0_wp, 10.0_wp, 0.0_wp /)
   CALL FDC_initialize( control, FACTORS )     ! Initialize control parameters
   CALL FDC_find_dependent( n, m, A_val, A_col, A_ptr, C, K, FACTORS, n_depen, &
     C_depen, control, inform )                ! Check for dependencies
   IF ( inform%status == 0 ) THEN              ! Successful return
     IF ( n_depen == 0 ) THEN
       WRITE( 6, "( ' FDC_find_dependent - no dependencies ' )" )
     ELSE
       WRITE( 6, "( ' FDC_find_dependent - dependent constraint(s):', 3I3 )")  &
         C_depen
     END IF
   ELSE                                        !  Error returns
     WRITE( 6, "( ' FDC_find_dependent exit status = ', I6 ) " ) inform%status
   END IF
   CALL FDC_terminate( K, FACTORS, C_depen, control, inform ) ! Delete workspace
   END PROGRAM GALAHAD_FDC_example