! F02WGF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE f02wgfe_mod ! F02WGF 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 ! Matrix vector subroutines SUBROUTINE av(iflag,m,n,x,ax,iuser,ruser) ! Computes w <- A*x or w <- Trans(A)*x. ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. REAL (KIND=nag_wp), PARAMETER :: one = 1.0_nag_wp REAL (KIND=nag_wp), PARAMETER :: zero = 0.0_nag_wp ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: iflag INTEGER, INTENT (IN) :: m, n ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: ax(*), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(*) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. REAL (KIND=nag_wp) :: h, k, s, t INTEGER :: i, j ! .. Intrinsic Functions .. INTRINSIC min, real ! .. Executable Statements .. h = one/real(m+1,kind=nag_wp) k = one/real(n+1,kind=nag_wp) IF (iflag==1) THEN ax(1:m) = zero t = zero DO j = 1, n t = t + k s = zero DO i = 1, min(j,m) s = s + h ax(i) = ax(i) + k*s*(t-one)*x(j) END DO DO i = j + 1, m s = s + h ax(i) = ax(i) + k*t*(s-one)*x(j) END DO END DO ELSE ax(1:n) = zero t = zero DO j = 1, n t = t + k s = zero DO i = 1, min(j,m) s = s + h ax(j) = ax(j) + k*s*(t-one)*x(i) END DO DO i = j + 1, m s = s + h ax(j) = ax(j) + k*t*(s-one)*x(i) END DO END DO END IF RETURN END SUBROUTINE av END MODULE f02wgfe_mod PROGRAM f02wgfe ! F02WGF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : f02wgf, nag_wp USE f02wgfe_mod, ONLY : av, nin, nout ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. INTEGER :: i, ifail, k, ldu, ldv, m, n, & nconv, ncv ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: resid(:), sigma(:), u(:,:), v(:,:) REAL (KIND=nag_wp) :: ruser(1) INTEGER :: iuser(1) ! .. Executable Statements .. WRITE (nout,*) 'F02WGF Example Program Results' WRITE (nout,*) ! Skip heading in data file READ (nin,*) READ (nin,*) m, n, k, ncv ldu = m ldv = n ALLOCATE (resid(ncv),sigma(ncv),u(ldu,ncv),v(ldv,ncv)) ! ifail: behaviour on error exit ! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft ifail = 0 CALL f02wgf(m,n,k,ncv,av,nconv,sigma,u,ldu,v,ldv,resid,iuser,ruser, & ifail) ! Print computed residuals WRITE (nout,*) ' Singular Value Residual' WRITE (nout,99999) (sigma(i),resid(i),i=1,nconv) 99999 FORMAT (1X,F10.5,8X,G10.2) END PROGRAM f02wgfe