! G02HBF Example Program Text ! Mark 24 Release. NAG Copyright 2012. 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 ! .. Parameters .. Real (Kind=nag_wp), Parameter :: 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 :: 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 nag_library, Only: g02hbf, nag_wp, x04abf, x04ccf Use g02hbfe_mod, Only: iset, nin, nout, one, ucv ! .. 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