!   G02HBF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module g02hbfe_mod

!     G02HBF Example Program Module:
!            Parameters and User-defined Routines

!     .. Use Statements ..
      Use nag_library, Only: nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Accessibility Statements ..
      Private
      Public                           :: ucv
!     .. Parameters ..
      Real (Kind=nag_wp), Parameter, Public :: one = 1.0_nag_wp
      Real (Kind=nag_wp), Parameter    :: two = 2.0_nag_wp
      Real (Kind=nag_wp), Parameter    :: zero = 0.0_nag_wp
      Integer, Parameter, Public       :: iset = 1, nin = 5, nout = 6
    Contains
      Function ucv(t)
!       UCV function for Krasker-Welsch weights

!       .. Use Statements ..
        Use nag_library, Only: s15abf, x01aaf, x02akf
!       .. Function Return Value ..
        Real (Kind=nag_wp)             :: ucv
!       .. Parameters ..
        Real (Kind=nag_wp), Parameter  :: ucvc = 2.5_nag_wp
!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: pc, pd, q, q2
        Integer                        :: ifail
!       .. Intrinsic Procedures ..
        Intrinsic                      :: exp, log, sqrt
!       .. Executable Statements ..
        ucv = one
        If (t/=zero) Then
          q = ucvc/t
          q2 = q*q
          ifail = 0
          pc = s15abf(q,ifail)
          If (q2<-log(x02akf())) Then
            pd = exp(-q2/two)/sqrt(x01aaf(zero)*two)
          Else
            pd = zero
          End If
          ucv = (two*pc-one)*(one-q2) + q2 - two*q*pd
        End If
        Return
      End Function ucv
    End Module g02hbfe_mod
    Program g02hbfe

!     G02HBF Example Main Program

!     .. Use Statements ..
      Use g02hbfe_mod, Only: iset, nin, nout, one, ucv
      Use nag_library, Only: g02hbf, nag_wp, x04abf, x04ccf
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: bd, bl, tol
      Integer                          :: i, ifail, la, ldx, m, maxit, n,      &
                                          nadv, nit, nitmon
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), wk(:), x(:,:), z(:)
!     .. Executable Statements ..
      Write (nout,*) 'G02HBF Example Program Results'
      Write (nout,*)
      Flush (nout)

!     Skip heading in data file
      Read (nin,*)

!     Read in the problem size
      Read (nin,*) n, m

      ldx = n
      la = (m+1)*m/2
      Allocate (x(ldx,m),a(la),wk(la),z(n))

!     Read in data
      Read (nin,*)(x(i,1:m),i=1,n)

!     Read in initial value of A
      Read (nin,*) a(1:la)

!     Read in control parameters
      Read (nin,*) nitmon, bl, bd, maxit, tol

!     Set the advisory channel to NOUT for monitoring information
      If (nitmon/=0) Then
        nadv = nout
        Call x04abf(iset,nadv)
      End If

!     Calculate A
      ifail = 0
      Call g02hbf(ucv,n,m,x,ldx,a,z,bl,bd,tol,maxit,nitmon,nit,wk,ifail)

!     Display results
      Write (nout,99999) 'G02HBF required ', nit, ' iterations to converge'
      Write (nout,*)
      Flush (nout)
      ifail = 0
      Call x04ccf('Lower','Non-Unit',m,a,'Matrix A',ifail)
      Write (nout,*)
      Write (nout,*) 'Vector Z'
      Write (nout,99998)(z(i),i=1,n)
      Write (nout,*)
      Write (nout,*) 'Vector of Krasker-Welsch weights'
      Write (nout,99998)(one/z(i),i=1,n)

99999 Format (1X,A,I0,A)
99998 Format (1X,F9.4)
    End Program g02hbfe