! D03PCA Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module d03pcae_mod ! D03PCA 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, npde = 2 Contains Subroutine pdedef(npde,t,x,u,ux,p,q,r,ires,iuser,ruser) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: t, x Integer, Intent (Inout) :: ires Integer, Intent (In) :: npde ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: p(npde,npde), q(npde), r(npde) Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde) Integer, Intent (Inout) :: iuser(*) ! .. Local Scalars .. Real (Kind=nag_wp) :: alpha ! .. Executable Statements .. alpha = ruser(1) q(1) = 4.0_nag_wp*alpha*(u(2)+x*ux(2)) q(2) = 0.0_nag_wp r(1) = x*ux(1) r(2) = ux(2) - u(1)*u(2) p(1,1:2) = 0.0_nag_wp p(2,1) = 0.0_nag_wp p(2,2) = 1.0_nag_wp - x*x Return End Subroutine pdedef Subroutine bndary(npde,t,u,ux,ibnd,beta,gamma,ires,iuser,ruser) ! .. Scalar Arguments .. Real (Kind=nag_wp), Intent (In) :: t Integer, Intent (In) :: ibnd, npde Integer, Intent (Inout) :: ires ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: beta(npde), gamma(npde) Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Real (Kind=nag_wp), Intent (In) :: u(npde), ux(npde) Integer, Intent (Inout) :: iuser(*) ! .. Executable Statements .. If (ibnd==0) Then beta(1) = 0.0_nag_wp beta(2) = 1.0_nag_wp gamma(1) = u(1) gamma(2) = -u(1)*u(2) Else beta(1) = 1.0_nag_wp beta(2) = 0.0_nag_wp gamma(1) = -u(1) gamma(2) = u(2) End If Return End Subroutine bndary Subroutine uinit(u,x,npts,iuser,ruser) ! Routine for PDE initial conditon ! .. Scalar Arguments .. Integer, Intent (In) :: npts ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Real (Kind=nag_wp), Intent (Out) :: u(2,npts) Real (Kind=nag_wp), Intent (In) :: x(npts) Integer, Intent (Inout) :: iuser(*) ! .. Local Scalars .. Real (Kind=nag_wp) :: alpha Integer :: i ! .. Executable Statements .. alpha = ruser(1) Do i = 1, npts u(1,i) = 2.0_nag_wp*alpha*x(i) u(2,i) = 1.0_nag_wp End Do Return End Subroutine uinit End Module d03pcae_mod Program d03pcae ! D03PCA Example Main Program ! .. Use Statements .. Use nag_library, Only: d03pca, d03pzf, nag_wp, x01aaf Use d03pcae_mod, Only: bndary, nin, nout, npde, pdedef, uinit ! .. Implicit None Statement .. Implicit None ! .. Local Scalars .. Real (Kind=nag_wp) :: acc, alpha, hx, pi, piby2, tout, & ts Integer :: i, ifail, ind, intpts, it, & itask, itrace, itype, m, neqn, & niw, npts, nw, nwk ! .. Local Arrays .. Real (Kind=nag_wp) :: ruser(1), rwsav(1100) Real (Kind=nag_wp), Allocatable :: u(:,:), uout(:,:,:), w(:), x(:), & xout(:) Integer :: iuser(1), iwsav(505) Integer, Allocatable :: iw(:) Logical :: lwsav(100) Character (80) :: cwsav(10) ! .. Intrinsic Procedures .. Intrinsic :: real, sin ! .. Executable Statements .. Write (nout,*) 'D03PCA Example Program Results' ! Skip heading in data file Read (nin,*) Read (nin,*) intpts, npts, itype neqn = npde*npts niw = neqn + 24 nwk = (10+6*npde)*neqn nw = nwk + (21+3*npde)*npde + 7*npts + 54 Allocate (u(npde,npts),uout(npde,intpts,itype),w(nw),x(npts), & xout(intpts),iw(niw)) Read (nin,*) xout(1:intpts) Read (nin,*) acc, alpha Read (nin,*) m, itrace ruser(1) = alpha ind = 0 itask = 1 ! Set spatial mesh points piby2 = 0.5_nag_wp*x01aaf(pi) hx = piby2/real(npts-1,kind=nag_wp) x(1) = 0.0_nag_wp x(npts) = 1.0_nag_wp Do i = 2, npts - 1 x(i) = sin(hx*real(i-1,kind=nag_wp)) End Do ! Set initial conditions Read (nin,*) ts, tout ! Set the initial values Call uinit(u,x,npts,iuser,ruser) Do it = 1, 5 tout = 10.0_nag_wp*tout ! ifail: behaviour on error exit ! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft ifail = 0 Call d03pca(npde,m,ts,tout,pdedef,bndary,u,npts,x,acc,w,nw,iw,niw, & itask,itrace,ind,iuser,ruser,cwsav,lwsav,iwsav,rwsav,ifail) If (it==1) Then Write (nout,99999) acc, alpha Write (nout,99998) xout(1:6) End If ! Interpolate at required spatial points ifail = 0 Call d03pzf(npde,m,u,npts,x,xout,intpts,itype,uout,ifail) Write (nout,99996) tout, uout(1,1:intpts,1) Write (nout,99995) uout(2,1:intpts,1) End Do ! Print integration statistics Write (nout,99997) iw(1), iw(2), iw(3), iw(5) 99999 Format (//' Accuracy requirement = ',E12.5/' Parameter ALPHA =', & ' ',E12.3/) 99998 Format (' T / X ',6F8.4/) 99997 Format (' Number of integration steps in time ', & I4/' Number of residual evaluations of resulting ODE system', & I4/' Number of Jacobian evaluations ', & I4/' Number of iterations of nonlinear solver ',I4) 99996 Format (1X,F7.4,' U(1)',6F8.4) 99995 Format (9X,'U(2)',6F8.4/) End Program d03pcae