! D02JBF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE d02jbfe_mod ! D02JBF 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 FUNCTION cf(i,j,x) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Function Return Value .. REAL (KIND=nag_wp) :: cf ! .. Parameters .. INTEGER, PARAMETER :: n = 2 REAL (KIND=nag_wp), PARAMETER :: a(n,n) = & reshape((/0.0E0_nag_wp,-1.0E0_nag_wp,1.0E0_nag_wp,0.0E0_nag_wp/),(/n,n/)) REAL (KIND=nag_wp), PARAMETER :: r(n) = (/ 0.0E0_nag_wp, & 1.0E0_nag_wp/) ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: x INTEGER, INTENT (IN) :: i, j ! .. Intrinsic Functions .. INTRINSIC reshape ! .. Executable Statements .. IF (j>0) cf = a(i,j) IF (j==0) cf = r(i) RETURN END FUNCTION cf SUBROUTINE bc(i,j,rhs) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: rhs INTEGER, INTENT (IN) :: i INTEGER, INTENT (OUT) :: j ! .. Executable Statements .. rhs = 0.0E0_nag_wp IF (i>1) THEN j = -1 ELSE j = 1 END IF RETURN END SUBROUTINE bc END MODULE d02jbfe_mod PROGRAM d02jbfe ! D02JBF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : d02jbf, e02akf, nag_wp USE d02jbfe_mod, ONLY : bc, cf, nin, nout ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: dx, x, x0, x1 INTEGER :: i, ia1, ifail, j, k1, k1max, kp, & kpmax, ldc, liw, lw, m, n ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: c(:,:), w(:), y(:) INTEGER, ALLOCATABLE :: iw(:) ! .. Intrinsic Functions .. INTRINSIC real ! .. Executable Statements .. WRITE (nout,*) 'D02JBF Example Program Results' ! Skip heading in data file READ (nin,*) ! n: order of the system of differential equations ! k1: number of coefficients to be returned ! kp: number of collocation points READ (nin,*) n, k1max, kpmax ldc = k1max liw = n*(k1max+2) lw = 2*n*(kpmax+1)*(n*k1max+1) + 7*n*k1max ALLOCATE (iw(liw),c(ldc,n),w(lw),y(n)) ! x0: left-hand boundary, x1: right-hand boundary. READ (nin,*) x0, x1 WRITE (nout,*) WRITE (nout,*) ' KP K1 Chebyshev coefficients' DO kp = 10, kpmax, 5 DO k1 = 4, k1max, 2 ! ifail: behaviour on error exit ! =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft ifail = 0 CALL d02jbf(n,cf,bc,x0,x1,k1,kp,c,ldc,w,lw,iw,liw,ifail) WRITE (nout,99999) kp, k1, c(1:k1,1) WRITE (nout,99998) (c(1:k1,j),j=2,n) WRITE (nout,*) END DO END DO k1 = 8 m = 9 ia1 = 1 WRITE (nout,99997) 'Last computed solution evaluated at', m, & ' equally spaced points' WRITE (nout,*) WRITE (nout,99996) ' X ', (j,j=1,n) dx = (x1-x0)/real(m-1,kind=nag_wp) x = x0 DO i = 1, m DO j = 1, n ifail = 0 CALL e02akf(k1,x0,x1,c(1,j),ia1,ldc,x,y(j),ifail) END DO WRITE (nout,99995) x, y(1:n) x = x + dx END DO 99999 FORMAT (1X,2(I3,1X),8F8.4) 99998 FORMAT (9X,8F8.4) 99997 FORMAT (1X,A,I5,A) 99996 FORMAT (1X,A,2(' Y(',I1,')')) 99995 FORMAT (1X,3F10.4) END PROGRAM d02jbfe