! E04DJF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e04djfe_mod ! E04DJF 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, ninopt = 7, nout = 6 CONTAINS SUBROUTINE objfn2(mode,n,x,objf,objgrd,nstate,iuser,ruser) ! Routine to evaluate F(x) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: objf INTEGER, INTENT (INOUT) :: mode INTEGER, INTENT (IN) :: n, nstate ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: objgrd(n) REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. REAL (KIND=nag_wp) :: x1, x2 ! .. Intrinsic Functions .. INTRINSIC exp ! .. Executable Statements .. x1 = x(1) x2 = x(2) objf = exp(x1)*(4.0_nag_wp*x1**2+2.0_nag_wp*x2**2+4.0_nag_wp*x1*x2+ & 2.0_nag_wp*x2+1.0_nag_wp) RETURN END SUBROUTINE objfn2 SUBROUTINE objfn1(mode,n,x,objf,objgrd,nstate,iuser,ruser) ! Routine to evaluate F(x) and approximate its 1st derivatives ! .. Use Statements .. USE nag_library, ONLY : e04xaf ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: objf INTEGER, INTENT (INOUT) :: mode INTEGER, INTENT (IN) :: n, nstate ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: objgrd(n) REAL (KIND=nag_wp), INTENT (INOUT) :: ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Local Scalars .. REAL (KIND=nag_wp) :: epsrf INTEGER :: ifail, imode, iwarn, ldh, & msglvl ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: h(:,:), hcntrl(:), hforw(:), & work(:), xcopy(:) INTEGER, ALLOCATABLE :: info(:) ! .. Executable Statements .. SELECT CASE (mode) CASE (0) ! Evaluate F(x) only CALL objfn2(mode,n,x,objf,objgrd,nstate,iuser,ruser) CASE (2) ! Evaluate F(x) and approximate its 1st derivatives imode = 0 ldh = n ALLOCATE (info(n),hforw(n),hcntrl(n),h(ldh,1),work(n),xcopy(n)) xcopy(1:n) = x(1:n) hforw(1:n) = 0.0_nag_wp msglvl = 0 epsrf = 0.0_nag_wp ifail = 1 CALL e04xaf(msglvl,n,epsrf,xcopy,imode,objfn2,ldh,hforw,objf, & objgrd,hcntrl,h,iwarn,work,iuser,ruser,info,ifail) END SELECT RETURN END SUBROUTINE objfn1 END MODULE e04djfe_mod PROGRAM e04djfe ! E04DJF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : e04dgf, e04djf, e04dkf, x04abf, x04acf, x04baf USE e04djfe_mod, ONLY : nag_wp, nin, ninopt, nout, objfn1 ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. CHARACTER (*), PARAMETER :: fname = 'e04djfe.opt' ! .. Local Scalars .. REAL (KIND=nag_wp) :: objf INTEGER :: ifail, inform, iter, mode, n, & outchn CHARACTER (80) :: rec ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: objgrd(:), work(:), x(:) REAL (KIND=nag_wp) :: ruser(1) INTEGER :: iuser(1) INTEGER, ALLOCATABLE :: iwork(:) ! .. Executable Statements .. WRITE (rec,99998) 'E04DJF Example Program Results' CALL x04baf(nout,rec) ! Skip heading in data file READ (nin,*) READ (nin,*) n ALLOCATE (iwork(n+1),objgrd(n),x(n),work(13*n)) ! Set the unit number for advisory messages to OUTCHN outchn = nout CALL x04abf(1,outchn) READ (nin,*) x(1:n) ! Set two options using E04DKF CALL e04dkf(' Verify Level = -1 ') CALL e04dkf(' Maximum Step Length = 100.0 ') ! Open the options file for reading mode = 0 ifail = 0 CALL x04acf(ninopt,fname,mode,ifail) ! Read the options file for the remaining options CALL e04djf(ninopt,inform) IF (inform/=0) THEN WRITE (rec,99999) 'E04DJF terminated with INFORM = ', inform CALL x04baf(nout,rec) GO TO 20 END IF ! Solve the problem ifail = -1 CALL e04dgf(n,objfn1,iter,objf,objgrd,x,iwork,work,iuser,ruser,ifail) 20 CONTINUE 99999 FORMAT (1X,A,I5) 99998 FORMAT (1X,A) END PROGRAM e04djfe