NAG Library Manual, Mark 30.2
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   F02FJF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module f02fjfe_mod

!     F02FJF 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                           :: dot, image, monit
!     .. Parameters ..
      Real (Kind=nag_wp), Parameter    :: half = 0.5_nag_wp
      Real (Kind=nag_wp), Parameter, Public :: zero = 0.0_nag_wp
      Integer, Parameter, Public       :: nin = 5, nout = 6
    Contains
      Function dot(iflag,n,z,w,ruser,lruser,iuser,liuser)
!       This function implements the dot product - transpose(W)*B*Z.
!       DOT assumes that N is at least 3.

!       .. Function Return Value ..
        Real (Kind=nag_wp)             :: dot
!       .. Scalar Arguments ..
        Integer, Intent (Inout)        :: iflag
        Integer, Intent (In)           :: liuser, lruser, n
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: ruser(lruser)
        Real (Kind=nag_wp), Intent (In) :: w(n), z(n)
        Integer, Intent (Inout)        :: iuser(liuser)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: s
        Integer                        :: i
!       .. Executable Statements ..
        s = zero
        s = s + (z(1)-half*z(2))*w(1)
        s = s + (-half*z(n-1)+z(n))*w(n)
        Do i = 2, n - 1
          s = s + (-half*z(i-1)+z(i)-half*z(i+1))*w(i)
        End Do
        dot = s
!       Set iflag negative to terminate execution for any reason.
        iflag = 0
        Return
      End Function dot
      Subroutine image(iflag,n,z,w,ruser,lruser,iuser,liuser)
!       This routine solves  A*W = B*Z  for W.
!       The routine assumes that N is at least 3.

!       The data A, NNZ, LA, IROW, ICOL, IPIV and ISTR on exit from
!       F11JAF have been packed into the xUSER communication arrays in
!       the following way:
!       IUSER(1:2) = (/NNZ, LA/)
!       RUSER(1:LA) = A
!       IUSER(3:(2*LA+2*N+3)) = (/IROW, ICOL, IPIV, ISTR/)
!       We'll also use RUSER((LA+1):(LA+N)) as space for F11JCF's dummy
!       arg. B, and RUSER((LA+N+1):(LA+7*N+120)) as space for F11JCF's
!       dummy arg. WORK

!       .. Use Statements ..
        Use nag_library, Only: f11jcf, x02ajf
!       .. Scalar Arguments ..
        Integer, Intent (Inout)        :: iflag
        Integer, Intent (In)           :: liuser, lruser, n
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Inout) :: ruser(lruser)
        Real (Kind=nag_wp), Intent (Out) :: w(n)
        Real (Kind=nag_wp), Intent (In) :: z(n)
        Integer, Intent (Inout)        :: iuser(liuser)
!       .. Local Scalars ..
        Real (Kind=nag_wp)             :: rnorm, tol
        Integer                        :: ifail, itn, j, la, lwork, maxitn,    &
                                          nnz
        Character (2)                  :: method
!       .. Executable Statements ..
        nnz = iuser(1)
        la = iuser(2)

!       Form B*Z in RUSER((LA+1):(LA+N)) and initialize W to
!       zero.
        w(1:n) = zero
        ruser(la+1) = z(1) - half*z(2)
        Do j = 2, n - 1
          ruser(la+j) = -half*z(j-1) + z(j) - half*z(j+1)
        End Do
        ruser(la+n) = -half*z(n-1) + z(n)

!       Call F11JCF to solve the equations  A*W = B*Z.
        method = 'CG'
        tol = x02ajf()
        maxitn = 100
        lwork = 6*n + 120

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 1
        Call f11jcf(method,n,nnz,ruser,la,iuser(3),iuser(la+3),iuser(2*la+3),  &
          iuser(2*la+n+3),ruser(la+1),tol,maxitn,w,rnorm,itn,ruser(la+n+1),    &
          lwork,ifail)

        If (ifail>0) Then
          iflag = -ifail
        End If
        Return
      End Subroutine image
      Subroutine monit(istate,nextit,nevals,nevecs,k,f,d)
!       Monitoring routine for F02FJF.

!       .. Parameters ..
        Integer, Parameter             :: nout = 6
!       .. Scalar Arguments ..
        Integer, Intent (In)           :: istate, k, nevals, nevecs, nextit
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (In) :: d(k), f(k)
!       .. Local Scalars ..
        Integer                        :: i
!       .. Executable Statements ..
        If (istate/=0) Then
          Write (nout,*)
          Write (nout,99999) '  ISTATE = ', istate, ' NEXTIT = ', nextit
          Write (nout,99999) '  NEVALS = ', nevals, ' NEVECS = ', nevecs
          Write (nout,*) '       F           D'
          Write (nout,99998)(f(i),d(i),i=1,k)
        End If
        Return

99999   Format (1X,A,I4,A,I4)
99998   Format (1X,1P,E11.3,3X,E11.3)
      End Subroutine monit
    End Module f02fjfe_mod
    Program f02fjfe

!     F02FJF Example Main Program

!     .. Use Statements ..
      Use f02fjfe_mod, Only: dot, image, monit, nin, nout, zero
      Use nag_library, Only: f02fjf, f06fef, f11jaf, nag_wp, x04cbf
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: dscale, dtol, tol
      Integer                          :: i, ifail, k, l, la, ldx, lfill,      &
                                          liuser, liwork, lruser, lwork, m, n, &
                                          nnz, nnzc, noits, novecs, npivm
      Character (1)                    :: mic, pstrat
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: a(:), d(:), ruser(:), work(:),       &
                                          x(:,:)
      Integer, Allocatable             :: icol(:), ipiv(:), irow(:), istr(:),  &
                                          iuser(:), iwork(:)
      Character (1)                    :: clabs(1), rlabs(1)
!     .. Executable Statements ..
      Write (nout,*) 'F02FJF Example Program Results'
      Write (nout,*)
      Flush (nout)
!     Skip heading in data file
      Read (nin,*)
      Read (nin,*) n, m, k, tol
      la = 10*n
      ldx = n
      liuser = 2*la + 2*n + 3
      lruser = la + 7*n + 120
      lwork = 5*k + 2*n
      Allocate (a(la),d(n),ruser(lruser),work(lwork),x(ldx,k),icol(la),        &
        ipiv(n),irow(la),istr(n+1),iuser(liuser))

!     Set up the sparse symmetric coefficient matrix A.
      l = 0
!     First entry:
      i = 1
      l = l + 1
      a(l) = 1.0_nag_wp
      irow(l) = i
      icol(l) = i
!     Remaining entries:
      Do i = 2, n
        If (i>=5) Then
          l = l + 1
          a(l) = -0.25_nag_wp
          irow(l) = i
          icol(l) = i - 4
        End If
        l = l + 1
        a(l) = -0.25_nag_wp
        irow(l) = i
        icol(l) = i - 1
        l = l + 1
        a(l) = 1.0_nag_wp
        irow(l) = i
        icol(l) = i
      End Do
      nnz = l

!     Call F11JAF to find an incomplete Cholesky factorization of A.
      lfill = 2
      liwork = 2*la - 3*nnz + 7*n + 1
      Allocate (iwork(liwork))
      dtol = zero
      mic = 'M'
      dscale = zero
      pstrat = 'M'

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call f11jaf(n,nnz,a,la,irow,icol,lfill,dtol,mic,dscale,pstrat,ipiv,istr, &
        nnzc,npivm,iwork,liwork,ifail)

!     Call F02FJF to find eigenvalues and eigenvectors.

      noits = 1000
      novecs = 0

!     Communicate A, NNZ, LA, IROW, ICOL, IPIV and ISTR to IMAGE
!     thread-safely using RUSER and IUSER.
!     In addition to using RUSER for storing A, we'll also use
!     7*N+120 elements of RUSER in place of local arrays in IMAGE.

!     Initialized A goes into ruser.
      ruser(1:nnz+nnzc) = a(1:nnz+nnzc)

!     NNZ, LA, IROW, ICOL, IPIV and ISTR go into IUSER, in that order.
!     Only the first NNZ+NNZC elements of IROW and ICOL will have been
!     initialized:
      iuser(1) = nnz
      iuser(2) = la
      iuser(3:2+nnz+nnzc) = irow(1:nnz+nnzc)
      iuser(la+3:la+2+nnz+nnzc) = icol(1:nnz+nnzc)
      iuser(2*la+3:2*la+2+n) = ipiv(1:n)
      iuser(liuser-n:liuser) = istr(1:n+1)

      ifail = -1
      Call f02fjf(n,m,k,noits,tol,dot,image,monit,novecs,x,ldx,d,work,lwork,   &
        ruser,lruser,iuser,liuser,ifail)

      If (ifail>=0) Then
        If (ifail/=1 .And. ifail<=4 .And. m>=1) Then
          Do i = 1, m
            d(i) = 1.0_nag_wp/d(i)
          End Do
          Write (nout,*) 'Final results'
          Write (nout,*)
          Write (nout,*) '  Eigenvalues'
          Write (nout,99999) d(1:m)
          Write (nout,*)
          Flush (nout)
!         Normalize eigenvectors
          Do i = 1, m
            Call f06fef(n,x(1,i),x(1,i),1)
          End Do
          Call x04cbf('General',' ',n,m,x,ldx,'1P,E12.3','  Eigenvectors','N', &
            rlabs,'N',clabs,80,0,ifail)
        End If
      End If

99999 Format (1X,1P,4E12.3)
    End Program f02fjfe