! E04YAF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e04yafe_mod ! E04YAF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: liw = 1, mdec = 15, ndec = 3, & nin = 5, nout = 6 INTEGER, PARAMETER :: ldfjac = mdec INTEGER, PARAMETER :: lw = 3*ndec + mdec + mdec*ndec ! .. Local Arrays .. REAL (KIND=nag_wp) :: t(mdec,ndec), y(mdec) CONTAINS SUBROUTINE lsqfun(iflag,m,n,xc,fvec,fjac,ldfjac,iw,liw,w,lw) ! Routine to evaluate the residuals and their 1st derivatives ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (INOUT) :: iflag INTEGER, INTENT (IN) :: ldfjac, liw, lw, m, n ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (INOUT) :: fjac(ldfjac,n), w(lw) REAL (KIND=nag_wp), INTENT (OUT) :: fvec(m) REAL (KIND=nag_wp), INTENT (IN) :: xc(n) INTEGER, INTENT (INOUT) :: iw(liw) ! .. Local Scalars .. REAL (KIND=nag_wp) :: denom, dummy INTEGER :: i ! .. Executable Statements .. DO i = 1, m denom = xc(2)*t(i,2) + xc(3)*t(i,3) IF (iflag/=1) THEN fvec(i) = xc(1) + t(i,1)/denom - y(i) END IF IF (iflag/=0) THEN fjac(i,1) = 1.0E0_nag_wp dummy = -1.0E0_nag_wp/(denom*denom) fjac(i,2) = t(i,1)*t(i,2)*dummy fjac(i,3) = t(i,1)*t(i,3)*dummy END IF END DO RETURN END SUBROUTINE lsqfun END MODULE e04yafe_mod PROGRAM e04yafe ! E04YAF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : e04yaf, nag_wp USE e04yafe_mod, ONLY : ldfjac, liw, lsqfun, lw, mdec, ndec, nin, nout, & t, y ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. INTEGER :: i, ifail, m, n ! .. Local Arrays .. REAL (KIND=nag_wp) :: fjac(ldfjac,ndec), fvec(mdec), & w(lw), x(ndec) INTEGER :: iw(liw) ! .. Executable Statements .. WRITE (nout,*) 'E04YAF Example Program Results' ! Skip heading in data file READ (nin,*) n = ndec m = mdec ! Observations of TJ (J = 1, 2, ..., n) are held in T(I, J) ! (I = 1, 2, ..., m) DO i = 1, m READ (nin,*) y(i), t(i,1:n) END DO ! Set up an arbitrary point at which to check the 1st ! derivatives x(1:n) = (/ 0.19E0_nag_wp, -1.34E0_nag_wp, 0.88E0_nag_wp/) WRITE (nout,*) WRITE (nout,*) 'The test point is' WRITE (nout,99999) x(1:n) ifail = -1 CALL e04yaf(m,n,lsqfun,x,fvec,fjac,ldfjac,iw,liw,w,lw,ifail) IF (ifail>=0 .AND. ifail/=1) THEN SELECT CASE (ifail) CASE (0) WRITE (nout,*) WRITE (nout,*) & '1st derivatives are consistent with residual values' CASE (2) WRITE (nout,*) WRITE (nout,*) 'Probable error in calculation of 1st derivatives' END SELECT WRITE (nout,*) WRITE (nout,*) 'At the test point, LSQFUN gives' WRITE (nout,*) WRITE (nout,*) ' Residuals 1st derivatives' WRITE (nout,99998) (fvec(i),fjac(i,1:n),i=1,m) END IF 99999 FORMAT (1X,4F10.5) 99998 FORMAT (1X,1P,4E15.3) END PROGRAM e04yafe