! D03PJA Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE d03pjae_mod ! D03PJA 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 INTEGER, PARAMETER :: itrace = 0, ncode = 1, nin = 5, & nout = 6, npde = 1, nxi = 1 CONTAINS SUBROUTINE uvinit(npde,npts,x,u,ncode,v,iuser,ruser) ! Routine for PDE initial values (start time is 0.1D-6) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ncode, npde, npts ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*) REAL (KIND=nag_wp), INTENT (OUT) :: u(npde,npts), v(ncode) REAL (KIND=nag_wp), INTENT (IN) :: x(npts) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. REAL (KIND=nag_wp) :: ts INTEGER :: i ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. ts = ruser(1) v(1) = ts DO i = 1, npts u(1,i) = exp(ts*(one-x(i))) - one END DO RETURN END SUBROUTINE uvinit SUBROUTINE odedef(npde,t,ncode,v,vdot,nxi,xi,ucp,ucpx,rcp,ucpt,ucptx,f, & ires,iuser,ruser) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: t INTEGER, INTENT (INOUT) :: ires INTEGER, INTENT (IN) :: ncode, npde, nxi ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: f(ncode) REAL (KIND=nag_wp), INTENT (IN) :: rcp(npde,*), ucp(npde,*), & ucpt(npde,*), ucptx(npde,*), & ucpx(npde,*), v(ncode), & vdot(ncode), xi(nxi) REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Executable Statements .. IF (ires==1) THEN f(1) = vdot(1) - v(1)*ucp(1,1) - ucpx(1,1) - one - t ELSE IF (ires==-1) THEN f(1) = vdot(1) END IF RETURN END SUBROUTINE odedef SUBROUTINE pdedef(npde,t,x,nptl,u,ux,ncode,v,vdot,p,q,r,ires,iuser, & ruser) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: t INTEGER, INTENT (INOUT) :: ires INTEGER, INTENT (IN) :: ncode, npde, nptl ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: p(npde,npde,nptl), & q(npde,nptl), r(npde,nptl) REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: u(npde,nptl), ux(npde,nptl), & v(ncode), vdot(ncode), x(nptl) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. INTEGER :: i ! .. Executable Statements .. DO i = 1, nptl p(1,1,i) = v(1)*v(1) r(1,i) = ux(1,i) q(1,i) = -x(i)*ux(1,i)*v(1)*vdot(1) END DO RETURN END SUBROUTINE pdedef SUBROUTINE bndary(npde,t,u,ux,ncode,v,vdot,ibnd,beta,gamma,ires,iuser, & ruser) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: t INTEGER, INTENT (IN) :: ibnd, ncode, 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), v(ncode), & vdot(ncode) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. beta(1) = one IF (ibnd==0) THEN gamma(1) = -v(1)*exp(t) ELSE gamma(1) = -v(1)*vdot(1) END IF RETURN END SUBROUTINE bndary SUBROUTINE exact(time,npts,x,u) ! Exact solution (for comparison purposes) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: time INTEGER, INTENT (IN) :: npts ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: u(npts) REAL (KIND=nag_wp), INTENT (IN) :: x(npts) ! .. Local Scalars .. INTEGER :: i ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. DO i = 1, npts u(i) = exp(time*(one-x(i))) - one END DO RETURN END SUBROUTINE exact END MODULE d03pjae_mod PROGRAM d03pjae ! D03PJA Example Main Program ! .. Use Statements .. USE nag_library, ONLY : d03pja USE d03pjae_mod, ONLY : bndary, exact, itrace, nag_wp, ncode, nin, & nout, npde, nxi, odedef, pdedef, uvinit ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: tout INTEGER :: i, ifail, ind, it, itask, itol, & latol, lenode, lrtol, m, nbkpts, & nel, neqn, niw, npl1, npoly, & npts, nw, nwkres LOGICAL :: theta CHARACTER (1) :: laopt, norm ! .. Local Arrays .. REAL (KIND=nag_wp) :: algopt(30), ruser(1), & rwsav(1100), xi(nxi) REAL (KIND=nag_wp), ALLOCATABLE :: atol(:), exy(:), rtol(:), u(:), & w(:), x(:), xbkpts(:) INTEGER :: iuser(1), iwsav(505) INTEGER, ALLOCATABLE :: iw(:) LOGICAL :: lwsav(100) CHARACTER (80) :: cwsav(10) ! .. Intrinsic Functions .. INTRINSIC mod, real ! .. Executable Statements .. WRITE (nout,*) 'D03PJA Example Program Results' ! Skip heading in data file READ (nin,*) READ (nin,*) m, nbkpts, npoly nel = nbkpts - 1 npts = nel*npoly + 1 neqn = npde*npts + ncode npl1 = npoly + 1 nwkres = 3*npl1*npl1 + npl1*(npde*npde+6*npde+nbkpts+1) + 8*npde + & nxi*(5*npde+1) + ncode + 3 lenode = 11*neqn + 50 nw = neqn*neqn + neqn + nwkres + lenode niw = 25*neqn + 24 ALLOCATE (exy(nbkpts),u(neqn),w(nw),x(npts),xbkpts(nbkpts),iw(niw)) READ (nin,*) itol latol = 1 lrtol = 1 IF (itol>2) latol = neqn IF (mod(itol,2)==0) lrtol = neqn ALLOCATE (atol(latol),rtol(lrtol)) READ (nin,*) atol(1:latol), rtol(1:lrtol) ! Set break-points DO i = 1, nbkpts xbkpts(i) = real(i-1,kind=nag_wp)/real(nbkpts-1,kind=nag_wp) END DO READ (nin,*) xi(1:nxi) READ (nin,*) norm, laopt ind = 0 itask = 1 ! Set theta to .TRUE. if the Theta integrator is required theta = .FALSE. algopt(1:30) = 0.0E0_nag_wp IF (theta) THEN algopt(1) = 2.0E0_nag_wp END IF ! Loop over output value of t ruser(1) = 1.0E-4_nag_wp tout = 0.2E0_nag_wp DO it = 1, 5 ! ifail: behaviour on error exit ! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft ifail = 0 CALL d03pja(npde,m,ruser(1),tout,pdedef,bndary,u,nbkpts,xbkpts, & npoly,npts,x,ncode,odedef,nxi,xi,neqn,uvinit,rtol,atol,itol,norm, & laopt,algopt,w,nw,iw,niw,itask,itrace,ind,iuser,ruser,cwsav, & lwsav,iwsav,rwsav,ifail) IF (it==1) THEN WRITE (nout,99999) npoly, nel WRITE (nout,99996) atol, npts WRITE (nout,99998) (xbkpts(i),i=1,7,2), xbkpts(nbkpts) END IF ! Check against the exact solution CALL exact(tout,nbkpts,xbkpts,exy) WRITE (nout,99997) ruser(1) WRITE (nout,99994) (u(i),i=1,6*npoly+1,2*npoly), u(npts:neqn) WRITE (nout,99993) (exy(i),i=1,7,2), exy(nbkpts), ruser(1) tout = 2.0E0_nag_wp*tout END DO WRITE (nout,99995) iw(1), iw(2), iw(3), iw(5) 99999 FORMAT (' Degree of Polynomial =',I4,' No. of elements =',I4/) 99998 FORMAT (' X ',5F9.3/) 99997 FORMAT (' T = ',F6.3) 99996 FORMAT (//' Simple coupled PDE using BDF '/' Accuracy require', & 'ment =',E10.3,' Number of points = ',I4/) 99995 FORMAT (' Number of integration steps in time = ',I6/' Number o', & 'f function evaluations = ',I6/' Number of Jacobian eval', & 'uations =',I6/' Number of iterations = ',I6) 99994 FORMAT (1X,'App. sol. ',F7.3,4F9.3,' ODE sol. =',F8.3) 99993 FORMAT (1X,'Exact sol. ',F7.3,4F9.3,' ODE sol. =',F8.3/) END PROGRAM d03pjae