! F02WGF Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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. ! .. 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 Procedures .. 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