!   H02BZF Example Program Text
!   Mark 23 Release. NAG Copyright 2011.

    MODULE h02bzfe_mod

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

!      .. Use Statements ..
       USE nag_library, ONLY : nag_wp
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       INTEGER, PARAMETER                  :: nin = 5, nout = 6
    CONTAINS
!dec$ attributes offload : mic :: outsol
       SUBROUTINE outsol(n,m,a,lda,bl,bu,x,istate,clamda,bigbnd,names,nout)

!         .. Use Statements ..
          USE nag_library, ONLY : ddot
!         .. Implicit None Statement ..
          IMPLICIT NONE
!         .. Parameters ..
          CHARACTER (2), PARAMETER            :: lstate(-2:4) = (/  '  ',      &
                                                 '  ',  'FR',  'LL',  'UL',    &
                                                 'EQ',  'TF'  /)
!         .. Scalar Arguments ..
          REAL (KIND=nag_wp), INTENT (IN)     :: bigbnd
          INTEGER, INTENT (IN)                :: lda, m, n, nout
!         .. Array Arguments ..
          REAL (KIND=nag_wp), INTENT (IN)     :: a(lda,*), bl(n+m), bu(n+m),   &
                                                 clamda(n+m), x(n)
          INTEGER, INTENT (IN)                :: istate(n+m)
          CHARACTER (8), INTENT (IN)          :: names(n+m)
!         .. Local Scalars ..
          REAL (KIND=nag_wp)                  :: b1, b2, res, res2, v, wlam
          INTEGER                             :: is, j, k
          CHARACTER (80)                      :: rec
!         .. Intrinsic Functions ..
          INTRINSIC                              abs
!         .. Executable Statements ..
          WRITE (nout,99999)

          DO j = 1, n + m
             b1 = bl(j)
             b2 = bu(j)
             wlam = clamda(j)
             is = istate(j)

             IF (j<=n) THEN

!               The variables  x.

                k = j
                v = x(j)
             ELSE

!               The linear constraints  A*x.

                IF (j==n+1) THEN
                   WRITE (nout,99998)
                END IF

                k = j - n
!               The NAG name equivalent of ddot is f06eaf
                v = ddot(n,a(k,1),lda,x,1)
             END IF

!            Print a line for the j-th variable or constraint.

             res = v - b1
             res2 = b2 - v

             IF (abs(res)>abs(res2)) THEN
                res = res2
             END IF

             WRITE (rec,99997) names(j), lstate(is), v, b1, b2, wlam, res

             IF (b1<=-bigbnd) THEN
                rec(29:42) = '    None     '
             END IF

             IF (b2>=bigbnd) THEN
                rec(43:56) = '    None     '
             END IF

             WRITE (nout,'(A)') rec
          END DO

          RETURN

99999     FORMAT (//1X,'Varbl',3X,'State',5X,'Value',5X,'Lower Bound',3X, &
             'Upper Bound',4X,'Lagr Mult',3X,'Residual'/)
99998     FORMAT (//1X,'L Con',3X,'State',5X,'Value',5X,'Lower Bound',3X, &
             'Upper Bound',4X,'Lagr Mult',3X,'Residual'/)
99997     FORMAT (1X,A8,2X,A2,1X,1P,3G14.4,1P,G12.4,1P,G12.4)
!dec$ attributes offload : mic :: outsol
       END SUBROUTINE outsol
    END MODULE h02bzfe_mod
    PROGRAM h02bzfe

!      H02BZF Example Main Program

!      .. Use Statements ..
       USE nag_library, ONLY : h02bbf, h02bzf, nag_wp
       USE h02bzfe_mod, ONLY : nin, nout, outsol
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Local Scalars ..
       REAL (KIND=nag_wp)                  :: bigbnd, inival, objmip, tolfes,  &
                                              toliv
       INTEGER                             :: i, ifail, intfst, itmax, j, lda, &
                                              liwork, lrwork, m, maxdpt,       &
                                              maxnod, msglvl, n
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE     :: a(:,:), bl(:), bu(:), clamda(:), &
                                              cvec(:), rwork(:), x(:)
       INTEGER, ALLOCATABLE                :: intvar(:), istate(:), iwork(:)
       CHARACTER (8), ALLOCATABLE          :: names(:)
!      .. Intrinsic Functions ..
       INTRINSIC                              min
!      .. Executable Statements ..
       WRITE (nout,*) 'H02BZF Example Program Results'

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

       READ (nin,*) n, m
       lda = m
       ALLOCATE (a(lda,n),bl(n+m),bu(n+m),clamda(n+m),cvec(n),x(n),intvar(n), &
          istate(n+m),names(n+m))

       READ (nin,*) itmax, msglvl
       READ (nin,*) maxnod
       READ (nin,*) intfst, maxdpt
       READ (nin,*) tolfes, toliv
       READ (nin,*) cvec(1:n)
       READ (nin,*) (names(j),a(1:m,j),j=1,n)
       READ (nin,*) bigbnd
       READ (nin,*) bl(1:n)
       READ (nin,*) (names(n+i),bl(n+i),i=1,m)
       READ (nin,*) bu(1:n+m)
       READ (nin,*) intvar(1:n)
       READ (nin,*) x(1:n)

       liwork = (25+n+m)*maxdpt + 5*n + m + 4
       lrwork = maxdpt*(n+1) + 2*min(n,m+1)**2 + 14*n + 12*m
       ALLOCATE (iwork(liwork),rwork(lrwork))

!      Solve the IP problem using H02BBF

       ifail = -1
       CALL h02bbf(itmax,msglvl,n,m,a,lda,bl,bu,intvar,cvec,maxnod,intfst, &
          maxdpt,toliv,tolfes,bigbnd,x,objmip,iwork,liwork,rwork,lrwork,ifail)

       SELECT CASE (ifail)
       CASE (0,7,9)
          WRITE (nout,99999) 'IP objective value = ', objmip

!         Get information about the solution

          ifail = 0
          CALL h02bzf(n,m,bl,bu,clamda,istate,iwork,liwork,rwork,lrwork,ifail)

!         Print the solution

          CALL outsol(n,m,a,lda,bl,bu,x,istate,clamda,bigbnd,names,nout)

!         Increase the energy requirements and solve the modified IP
!         problem using the current IP solution as the starting point

          inival = bl(n+1)
          READ (nin,*) bl(n+1)
          WRITE (nout,99998) 'Increase the energy requirements from', inival, &
             'to', bl(n+1)

          ifail = -1
          CALL h02bbf(itmax,msglvl,n,m,a,lda,bl,bu,intvar,cvec,maxnod,intfst, &
             maxdpt,toliv,tolfes,bigbnd,x,objmip,iwork,liwork,rwork,lrwork, &
             ifail)

          SELECT CASE (ifail)
          CASE (0,7,9)
             WRITE (nout,99999) 'IP objective value = ', objmip

!            Get information about the solution

             ifail = 0
             CALL h02bzf(n,m,bl,bu,clamda,istate,iwork,liwork,rwork,lrwork, &
                ifail)

!            Print the solution

             CALL outsol(n,m,a,lda,bl,bu,x,istate,clamda,bigbnd,names,nout)

          END SELECT

       END SELECT

99999  FORMAT (//1X,A,1P,G16.4)
99998  FORMAT (//1X,A,1X,1P,G11.4,2X,A,1X,1P,G11.4)
    END PROGRAM h02bzfe
