! G05ZQF Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module g05zqfe_mod ! G05ZQF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. Use nag_library, Only: nag_wp ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: even = 1 Contains Subroutine cov2(t1,t2,gamma,iuser,ruser) ! .. Implicit None Statement .. Implicit None ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (Out) :: gamma Real (Kind=nag_wp), Intent (In) :: t1, t2 ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Integer, Intent (Inout) :: iuser(*) ! .. Local Scalars .. Real (Kind=nag_wp) :: l1, l2, nu, rnorm, tl1, tl2 Integer :: norm ! .. Intrinsic Procedures .. Intrinsic :: abs, exp, sqrt ! .. Executable Statements .. ! Covariance parameters stored in ruser array. norm = iuser(1) l1 = ruser(1) l2 = ruser(2) nu = ruser(3) tl1 = abs(t1)/l1 tl2 = abs(t2)/l2 If (norm==1) Then rnorm = tl1 + tl2 Else If (norm==2) Then rnorm = sqrt(tl1**2+tl2**2) End If gamma = exp(-(rnorm**nu)) Return End Subroutine cov2 End Module g05zqfe_mod Program g05zqfe ! G05ZQF Example Main Program ! .. Use Statements .. Use nag_library, Only: g05zqf, nag_wp Use g05zqfe_mod, Only: cov2, even ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: nin = 5, nout = 6 ! .. Local Scalars .. Real (Kind=nag_wp) :: l1, l2, nu, rho, var, xmax, & xmin, ymax, ymin Integer :: approx, icorr, icount, ifail, & norm, pad ! .. Local Arrays .. Real (Kind=nag_wp) :: eig(3), ruser(3) Real (Kind=nag_wp), Allocatable :: lam(:), xx(:), yy(:) Integer :: iuser(1), m(2), maxm(2), ns(2) ! .. Executable Statements .. Write (nout,*) 'G05ZQF Example Program Results' Write (nout,*) ! Get problem specifications from data file Call read_input_data(norm,l1,l2,nu,var,xmin,xmax,ymin,ymax,ns,maxm, & icorr,pad) ! Put covariance parameters in communication arrays iuser(1) = norm ruser(1) = l1 ruser(2) = l2 ruser(3) = nu Allocate (lam(maxm(1)*maxm(2)),xx(ns(1)),yy(ns(2))) ! Get square roots of the eigenvalues of the embedding matrix ifail = 0 Call g05zqf(ns,xmin,xmax,ymin,ymax,maxm,var,cov2,even,pad,icorr,lam,xx, & yy,m,approx,rho,icount,eig,iuser,ruser,ifail) ! Output results Call display_results(approx,m,rho,eig,icount,lam) Contains Subroutine read_input_data(norm,l1,l2,nu,var,xmin,xmax,ymin,ymax,ns, & maxm,icorr,pad) ! .. Implicit None Statement .. Implicit None ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (Out) :: l1, l2, nu, var, xmax, xmin, & ymax, ymin Integer, Intent (Out) :: icorr, norm, pad ! .. Array Arguments .. Integer, Intent (Out) :: maxm(2), ns(2) ! .. Executable Statements .. ! Skip heading in data file Read (nin,*) ! Read in norm, l1, l2 and nu for cov2 function Read (nin,*) norm, l1, l2, nu ! Read in variance of random field Read (nin,*) var ! Read in domain endpoints Read (nin,*) xmin, xmax Read (nin,*) ymin, ymax ! Read in number of sample points in each direction Read (nin,*) ns(1), ns(2) ! Read in maximum size of embedding matrix Read (nin,*) maxm(1), maxm(2) ! Read in choice of scaling in case of approximation Read (nin,*) icorr ! Read in choice of padding Read (nin,*) pad Return End Subroutine read_input_data Subroutine display_results(approx,m,rho,eig,icount,lam) ! .. Implicit None Statement .. Implicit None ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: rho Integer, Intent (In) :: approx, icount ! .. Array Arguments .. Real (Kind=nag_wp), Intent (In) :: eig(3) Integer, Intent (In) :: m(2) Real (Kind=nag_wp), Intent (In) :: lam(m(1),m(2)) ! .. Local Scalars .. Integer :: i ! .. Executable Statements .. ! Display size of embedding matrix Write (nout,*) Write (nout,99999) 'Size of embedding matrix = ', m(1)*m(2) ! Display approximation information if approximation used Write (nout,*) If (approx==1) Then Write (nout,*) 'Approximation required' Write (nout,*) Write (nout,99998) 'RHO = ', rho Write (nout,99997) 'EIG = ', eig(1:3) Write (nout,99999) 'ICOUNT = ', icount Else Write (nout,*) 'Approximation not required' End If ! Display square roots of the eigenvalues of the embedding matrix Write (nout,*) Write (nout,*) 'Square roots of eigenvalues of embedding matrix:' Write (nout,*) Do i = 1, m(1) Write (nout,99996) lam(i,1:m(2)) End Do Return 99999 Format (1X,A,I7) 99998 Format (1X,A,F10.5) 99997 Format (1X,A,3(F10.5,1X)) 99996 Format (1X,8F8.4) End Subroutine display_results End Program g05zqfe