! E04UDF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE e04udfe_mod ! E04UDF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: iset = 1, nin = 5, ninopt = 7, & nout = 6 CONTAINS SUBROUTINE objfun(mode,n,x,objf,objgrd,nstate,iuser,ruser) ! Routine to evaluate objective function and its 1st derivatives. ! .. 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 (INOUT) :: objgrd(n), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) ! .. Executable Statements .. IF (mode==0 .OR. mode==2) THEN objf = x(1)*x(4)*(x(1)+x(2)+x(3)) + x(3) END IF IF (mode==1 .OR. mode==2) THEN objgrd(1) = x(4)*(2.0E0_nag_wp*x(1)+x(2)+x(3)) objgrd(2) = x(1)*x(4) objgrd(3) = x(1)*x(4) + 1.0E0_nag_wp objgrd(4) = x(1)*(x(1)+x(2)+x(3)) END IF RETURN END SUBROUTINE objfun SUBROUTINE confun(mode,ncnln,n,ldcj,needc,x,c,cjac,nstate,iuser,ruser) ! Routine to evaluate the nonlinear constraints and their 1st ! derivatives. ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: ldcj, n, ncnln, nstate INTEGER, INTENT (INOUT) :: mode ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (OUT) :: c(ncnln) REAL (KIND=nag_wp), INTENT (INOUT) :: cjac(ldcj,n), ruser(*) REAL (KIND=nag_wp), INTENT (IN) :: x(n) INTEGER, INTENT (INOUT) :: iuser(*) INTEGER, INTENT (IN) :: needc(ncnln) ! .. Executable Statements .. IF (nstate==1) THEN ! First call to CONFUN. Set all Jacobian elements to zero. ! Note that this will only work when 'Derivative Level = 3' ! (the default; see Section 11.2). cjac(1:ncnln,1:n) = 0.0E0_nag_wp END IF IF (needc(1)>0) THEN IF (mode==0 .OR. mode==2) THEN c(1) = x(1)**2 + x(2)**2 + x(3)**2 + x(4)**2 END IF IF (mode==1 .OR. mode==2) THEN cjac(1,1) = 2.0E0_nag_wp*x(1) cjac(1,2) = 2.0E0_nag_wp*x(2) cjac(1,3) = 2.0E0_nag_wp*x(3) cjac(1,4) = 2.0E0_nag_wp*x(4) END IF END IF IF (needc(2)>0) THEN IF (mode==0 .OR. mode==2) THEN c(2) = x(1)*x(2)*x(3)*x(4) END IF IF (mode==1 .OR. mode==2) THEN cjac(2,1) = x(2)*x(3)*x(4) cjac(2,2) = x(1)*x(3)*x(4) cjac(2,3) = x(1)*x(2)*x(4) cjac(2,4) = x(1)*x(2)*x(3) END IF END IF RETURN END SUBROUTINE confun END MODULE e04udfe_mod PROGRAM e04udfe ! E04UDF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : e04ucf, e04udf, e04uef, nag_wp, x04abf, x04acf, & x04baf USE e04udfe_mod, ONLY : confun, iset, nin, ninopt, nout, objfun ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. CHARACTER (*), PARAMETER :: fname = 'e04udfe.opt' ! .. Local Scalars .. REAL (KIND=nag_wp) :: objf INTEGER :: i, ifail, inform, iter, lda, & ldcj, ldr, liwork, lwork, mode, & n, nclin, ncnln, outchn, sda, & sdcjac CHARACTER (80) :: rec ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: a(:,:), bl(:), bu(:), c(:), & cjac(:,:), clamda(:), objgrd(:), & r(:,:), work(:), x(:) REAL (KIND=nag_wp) :: ruser(1) INTEGER, ALLOCATABLE :: istate(:), iwork(:) INTEGER :: iuser(1) ! .. Intrinsic Functions .. INTRINSIC max ! .. Executable Statements .. WRITE (rec,99998) 'E04UDF Example Program Results' CALL x04baf(nout,rec) ! Skip heading in data file READ (nin,*) READ (nin,*) n, nclin, ncnln liwork = 3*n + nclin + 2*ncnln lda = max(1,nclin) IF (nclin>0) THEN sda = n ELSE sda = 1 END IF ldcj = max(1,ncnln) IF (ncnln>0) THEN sdcjac = n ELSE sdcjac = 1 END IF ldr = n IF (ncnln==0 .AND. nclin>0) THEN lwork = 2*n**2 + 20*n + 11*nclin ELSE IF (ncnln>0 .AND. nclin>=0) THEN lwork = 2*n**2 + n*nclin + 2*n*ncnln + 20*n + 11*nclin + 21*ncnln ELSE lwork = 20*n END IF ALLOCATE (istate(n+nclin+ncnln),iwork(liwork),a(lda,sda), & bl(n+nclin+ncnln),bu(n+nclin+ncnln),c(max(1, & ncnln)),cjac(ldcj,sdcjac),clamda(n+nclin+ncnln),objgrd(n),r(ldr,n), & x(n),work(lwork)) IF (nclin>0) THEN READ (nin,*) (a(i,1:sda),i=1,nclin) END IF READ (nin,*) bl(1:(n+nclin+ncnln)) READ (nin,*) bu(1:(n+nclin+ncnln)) READ (nin,*) x(1:n) ! Set the unit number for advisory messages to OUTCHN outchn = nout CALL x04abf(iset,outchn) ! Set three options using E04UEF CALL e04uef(' Infinite Bound Size = 1.0D+25 ') CALL e04uef(' Print Level = 1 ') CALL e04uef(' Verify Level = -1 ') ! 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 e04udf(ninopt,inform) IF (inform/=0) THEN WRITE (rec,99999) 'E04UDF terminated with ' // 'INFORM = ', inform CALL x04baf(nout,rec) END IF ! Solve the problem ifail = 0 CALL e04ucf(n,nclin,ncnln,lda,ldcj,ldr,a,bl,bu,confun,objfun,iter, & istate,c,cjac,clamda,objf,objgrd,r,x,iwork,liwork,work,lwork,iuser, & ruser,ifail) 99999 FORMAT (1X,A,I5) 99998 FORMAT (1X,A) END PROGRAM e04udfe