! E05USF Example Program Text ! Mark 24 Release. NAG Copyright 2012. Module e05usfe_mod ! E05USF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. Use nag_library, Only: nag_wp ! .. Implicit None Statement .. Implicit None Contains Subroutine objfun(mode,m,n,ldfjsl,needfi,x,f,fjsl,nstate,iuser,ruser) ! Evaluates the subfunctions and their 1st derivatives. ! .. Parameters .. Real (Kind=nag_wp), Parameter :: a(44) = (/8._nag_wp,8._nag_wp, & 10._nag_wp,10._nag_wp,10._nag_wp,10._nag_wp,12._nag_wp,12._nag_wp, & 12._nag_wp,12._nag_wp,14._nag_wp,14._nag_wp,14._nag_wp,16._nag_wp, & 16._nag_wp,16._nag_wp,18._nag_wp,18._nag_wp,20._nag_wp,20._nag_wp, & 20._nag_wp,22._nag_wp,22._nag_wp,22._nag_wp,24._nag_wp,24._nag_wp, & 24._nag_wp,26._nag_wp,26._nag_wp,26._nag_wp,28._nag_wp,28._nag_wp, & 30._nag_wp,30._nag_wp,30._nag_wp,32._nag_wp,32._nag_wp,34._nag_wp, & 36._nag_wp,36._nag_wp,38._nag_wp,38._nag_wp,40._nag_wp,42._nag_wp/) ! .. Scalar Arguments .. Integer, Intent (In) :: ldfjsl, m, n, needfi, nstate Integer, Intent (Inout) :: mode ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: f(m) Real (Kind=nag_wp), Intent (Inout) :: fjsl(ldfjsl,*), ruser(*) Real (Kind=nag_wp), Intent (In) :: x(n) Integer, Intent (Inout) :: iuser(*) ! .. Local Scalars .. Real (Kind=nag_wp) :: temp Integer :: i ! .. Intrinsic Procedures .. Intrinsic :: exp ! .. Executable Statements .. loop: Do i = 1, m temp = exp(-x(2)*(a(i)-8._nag_wp)) If (mode==0 .Or. mode==2) Then f(i) = x(1) + (0.49_nag_wp-x(1))*temp End If If (needfi==i) Then Exit loop End If If (mode==1 .Or. mode==2) Then fjsl(i,1) = 1._nag_wp - temp fjsl(i,2) = -(0.49_nag_wp-x(1))*(a(i)-8._nag_wp)*temp End If End Do loop Return End Subroutine objfun Subroutine confun(mode,ncnln,n,ldcjsl,needc,x,c,cjsl,nstate,iuser,ruser) ! Evaluates the nonlinear constraints and their 1st derivatives. ! .. Scalar Arguments .. Integer, Intent (In) :: ldcjsl, n, ncnln, nstate Integer, Intent (Inout) :: mode ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: c(ncnln) Real (Kind=nag_wp), Intent (Inout) :: cjsl(ldcjsl,*), 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.1 of the E04USA document). cjsl(1:ncnln,1:n) = 0._nag_wp End If If (needc(1)>0) Then If (mode==0 .Or. mode==2) Then c(1) = -0.09_nag_wp - x(1)*x(2) + 0.49_nag_wp*x(2) End If If (mode==1 .Or. mode==2) Then cjsl(1,1) = -x(2) cjsl(1,2) = -x(1) + 0.49_nag_wp End If End If Return End Subroutine confun Subroutine start(npts,quas,n,repeat1,bl,bu,iuser,ruser,mode) ! Sets an initial point. ! A typical user-defined start procedure. ! .. Scalar Arguments .. Integer, Intent (Inout) :: mode Integer, Intent (In) :: n, npts Logical, Intent (In) :: repeat1 ! .. Array Arguments .. Real (Kind=nag_wp), Intent (In) :: bl(n), bu(n) Real (Kind=nag_wp), Intent (Inout) :: quas(n,npts), ruser(*) Integer, Intent (Inout) :: iuser(*) ! .. Executable Statements .. ! quas is pre-assigned to zero. quas(1,1) = 0.4_nag_wp quas(2,2) = 1._nag_wp Return End Subroutine start End Module e05usfe_mod Program e05usfe ! E05USF Example Main Program ! .. Use Statements .. Use nag_library, Only: dgemv, e05usf, e05zkf, nag_wp Use e05usfe_mod, Only: confun, objfun, start ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Integer, Parameter :: liopts = 740, lopts = 485, & m = 44, n = 2, nb = 1, & nclin = 1, ncnln = 1, nin = 5, & nout = 6, npts = 3 Integer, Parameter :: sdfjac = n Integer, Parameter :: lda = nclin Integer, Parameter :: ldc = ncnln Integer, Parameter :: ldcjac = ncnln Integer, Parameter :: ldclda = n + nclin + ncnln Integer, Parameter :: ldfjac = m Integer, Parameter :: ldx = n Integer, Parameter :: listat = n + nclin + ncnln Logical, Parameter :: repeat1 = .True. ! .. Local Scalars .. Integer :: i, ifail, j, k, l, sda, sdcjac ! .. Local Arrays .. Real (Kind=nag_wp), Allocatable :: a(:,:), bl(:), bu(:), c(:,:), & cjac(:,:,:), clamda(:,:), & f(:,:), fjac(:,:,:), work(:), & x(:,:), y(:) Real (Kind=nag_wp) :: objf(nb), opts(lopts), ruser(1) Integer :: info(nb), iopts(liopts), & iter(nb), iuser(1) Integer, Allocatable :: istate(:,:) ! .. Intrinsic Procedures .. Intrinsic :: max ! .. Executable Statements .. Write (nout,*) 'E05USF Example Program Results' Flush (nout) ! Skip heading in data file. Read (nin,*) If (nclin>0) Then sda = n Else sda = 1 End If If (ncnln>0) Then sdcjac = n Else sdcjac = 0 End If Allocate (a(lda,sda),bl(n+nclin+ncnln),bu(n+nclin+ncnln),y(m),c(ldc,nb), & cjac(ldcjac,sdcjac,nb),f(m,nb),fjac(ldfjac,sdfjac,nb), & clamda(ldclda,nb),istate(listat,nb),x(ldx,nb),work(max(1,nclin))) If (nclin>0) Then Read (nin,*)(a(i,1:sda),i=1,nclin) End If Read (nin,*) y(1:m) Read (nin,*) bl(1:(n+nclin+ncnln)) Read (nin,*) bu(1:(n+nclin+ncnln)) ! Initialize the solver. ifail = 0 Call e05zkf('Initialize = E05USF',iopts,liopts,opts,lopts,ifail) ! Solve the problem. ifail = -1 Call e05usf(m,n,nclin,ncnln,a,lda,bl,bu,y,confun,objfun,npts,x,ldx, & start,repeat1,nb,objf,f,fjac,ldfjac,sdfjac,iter,c,ldc,cjac,ldcjac, & sdcjac,clamda,ldclda,istate,listat,iopts,opts,iuser,ruser,info,ifail) Select Case (ifail) Case (0) l = nb Case (8) l = info(nb) Write (nout,99999) iter(nb) Case Default Go To 100 End Select loop: Do i = 1, l Write (nout,99998) i Write (nout,99997) info(i) Write (nout,99996) 'Varbl' Do j = 1, n Write (nout,99995) 'V', j, istate(j,i), x(j,i), clamda(j,i) End Do If (nclin>0) Then Write (nout,99996) 'L Con' ! Below is a call to the level 2 BLAS routine DGEMV. ! This performs the matrix vector multiplication A*X ! (linear constraint values) and puts the result in ! the first NCLIN locations of WORK. Call dgemv('N',nclin,n,1.0_nag_wp,a,lda,x(1,i),1,0.0_nag_wp,work,1) Do k = n + 1, n + nclin j = k - n Write (nout,99995) 'L', j, istate(k,i), work(j), clamda(k,i) End Do End If If (ncnln>0) Then Write (nout,99996) 'N Con' Do k = n + nclin + 1, n + nclin + ncnln j = k - n - nclin Write (nout,99995) 'N', j, istate(k,i), c(j,i), clamda(k,i) End Do End If Write (nout,99994) objf(i) Write (nout,99993) Write (nout,99992)(clamda(k,i),k=1,n+nclin+ncnln) If (l==1) Then Exit loop End If Write (nout,*) Write (nout,*) & ' ------------------------------------------------------ ' End Do loop 100 Continue 99999 Format (1X,I20,'starting points converged') 99998 Format (/1X,'Solution number',I16) 99997 Format (/1X,'Local minimization exited with code',I5) 99996 Format (/1X,A,2X,'Istate',3X,'Value',9X,'Lagr Mult'/) 99995 Format (1X,A,2(1X,I3),4X,F12.4,2X,F12.4) 99994 Format (/1X,'Final objective value = ',1X,F12.4) 99993 Format (/1X,'QP multipliers') 99992 Format (1X,F12.4) End Program e05usfe