Program e04ndae ! E04NDA Example Program Text ! Mark 24 Release. NAG Copyright 2012. ! .. Use Statements .. Use nag_library, Only: dgemv, e04nca, e04nda, e04nea, e04wbf, nag_wp, & x04abf, x04acf, x04baf ! .. Implicit None Statement .. Implicit None ! .. Parameters .. Real (Kind=nag_wp), Parameter :: one = 1.0_nag_wp Real (Kind=nag_wp), Parameter :: zero = 0.0_nag_wp Integer, Parameter :: inc1 = 1, iset = 1, lcwsav = 1, & liwsav = 610, llwsav = 120, & lrwsav = 475, nin = 5, ninopt = 7, & nout = 6 Character (*), Parameter :: fname = 'e04ndae.opt' ! .. Local Scalars .. Real (Kind=nag_wp) :: obj Integer :: i, ifail, inform, iter, j, lda, ldc, & liwork, lwork, m, mode, n, nclin, & outchn, sdc Character (80) :: rec ! .. Local Arrays .. Real (Kind=nag_wp), Allocatable :: a(:,:), b(:), bl(:), bu(:), c(:,:), & clamda(:), cvec(:), work(:), x(:) Real (Kind=nag_wp) :: rwsav(lrwsav) Integer, Allocatable :: istate(:), iwork(:), kx(:) Integer :: iwsav(liwsav) Logical :: lwsav(llwsav) Character (80) :: cwsav(lcwsav) ! .. Intrinsic Procedures .. Intrinsic :: max ! .. Executable Statements .. Write (rec,99993) 'E04NDA Example Program Results' Call x04baf(nout,rec) ! Skip heading in data file Read (nin,*) Read (nin,*) m, n, nclin liwork = n ldc = max(1,nclin) lda = max(1,m) If (nclin>0) Then sdc = n Else sdc = 1 End If ! This particular example problem is of type QP2, so we allocate ! A(LDA,N), CVEC(N), B(1) and define LWORK as below If (nclin>0) Then lwork = 2*n**2 + 10*n + 6*nclin Else lwork = 10*n End If Allocate (istate(n+nclin),kx(n),iwork(liwork),c(ldc,sdc),bl(n+nclin), & bu(n+nclin),cvec(n),x(n),a(lda,n),b(1),clamda(n+nclin),work(lwork)) Read (nin,*) cvec(1:n) Read (nin,*)(a(i,1:n),i=1,m) Read (nin,*)(c(i,1:sdc),i=1,nclin) Read (nin,*) bl(1:(n+nclin)) Read (nin,*) Read (nin,*) bu(1:(n+nclin)) Read (nin,*) Read (nin,*) x(1:n) ! Set the unit number for advisory messages to OUTCHN outchn = nout Call x04abf(iset,outchn) ! Initialise E04NCA ifail = 0 Call e04wbf('E04NCA',cwsav,lcwsav,lwsav,llwsav,iwsav,liwsav,rwsav, & lrwsav,ifail) ! Set one option using E04NEA Call e04nea(' Problem Type = QP2 ',lwsav,iwsav,rwsav,inform) If (inform/=0) Then Write (rec,99999) ' ** E04NEA terminated with INFORM = ', inform Call x04baf(nout,rec) Go To 100 End If ! 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 e04nda(ninopt,lwsav,iwsav,rwsav,inform) If (inform/=0) Then Write (rec,99999) ' ** E04NDA terminated with INFORM =', inform Call x04baf(nout,rec) Go To 100 End If ! Solve the problem ifail = -1 Call e04nca(m,n,nclin,ldc,lda,c,bl,bu,cvec,istate,kx,x,a,b,iter,obj, & clamda,iwork,liwork,work,lwork,lwsav,iwsav,rwsav,ifail) Select Case (ifail) Case (0:5,7:) Write (rec,'()') Call x04baf(nout,rec) Write (rec,99998) Call x04baf(nout,rec) Write (rec,'()') Call x04baf(nout,rec) Do i = 1, n Write (rec,99997) i, istate(i), x(i), clamda(i) Call x04baf(nout,rec) End Do If (nclin>0) Then ! C*x --> work. ! The NAG name equivalent of dgemv is f06paf Call dgemv('N',nclin,n,one,c,ldc,x,inc1,zero,work,inc1) Write (rec,'()') Call x04baf(nout,rec) Write (rec,'()') Call x04baf(nout,rec) Write (rec,99996) Call x04baf(nout,rec) Write (rec,'()') Call x04baf(nout,rec) Do i = n + 1, n + nclin j = i - n Write (rec,99995) j, istate(i), work(j), clamda(i) Call x04baf(nout,rec) End Do End If Write (rec,'()') Call x04baf(nout,rec) Write (rec,'()') Call x04baf(nout,rec) Write (rec,99994) obj Call x04baf(nout,rec) End Select 100 Continue 99999 Format (1X,A,I5) 99998 Format (1X,'Varbl',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99997 Format (1X,'V',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99996 Format (1X,'L Con',2X,'Istate',3X,'Value',9X,'Lagr Mult') 99995 Format (1X,'L',2(1X,I3),4X,1P,G14.6,2X,1P,G12.4) 99994 Format (1X,'Final objective value = ',G15.7) 99993 Format (1X,A) End Program e04ndae