! Mark 24 Release. NAG Copyright 2012. Module e04mxfe_mod ! E04MXF 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, lencw = 600, & leniw = 600, lenrw = 600, & mpslst = 1, nin = 7, nout = 6 Logical, Parameter :: readints = .False. Character (*), Parameter :: fname = 'e04mxfe.opt' Contains Subroutine qphx(ncolh,x,hx,nstate,cuser,iuser,ruser) ! Subroutine to compute H*x. ! Note: IUSER and RUSER contain the following data: ! RUSER(1:NNZH) = H(1:NNZH) ! IUSER(1:NCOLH+1) = ICCOLH(1:NCOLH+1) ! IUSER(NCOLH+2:NNZH+NCOLH+1) = IROWH(1:NNZH) ! .. Scalar Arguments .. Integer, Intent (In) :: ncolh, nstate ! .. Array Arguments .. Real (Kind=nag_wp), Intent (Out) :: hx(ncolh) Real (Kind=nag_wp), Intent (Inout) :: ruser(*) Real (Kind=nag_wp), Intent (In) :: x(ncolh) Integer, Intent (Inout) :: iuser(*) Character (8), Intent (Inout) :: cuser(*) ! .. Local Scalars .. Integer :: end, icol, idx, irow, start ! .. Executable Statements .. hx(1:ncolh) = 0.0E0_nag_wp Do icol = 1, ncolh start = iuser(icol) end = iuser(icol+1) - 1 Do idx = start, end irow = iuser(ncolh+1+idx) hx(irow) = hx(irow) + x(icol)*ruser(idx) If (irow/=icol) Then hx(icol) = hx(icol) + x(irow)*ruser(idx) End If End Do End Do Return End Subroutine qphx End Module e04mxfe_mod Program e04mxfe ! .. Use Statements .. Use nag_library, Only: e04mxf, e04npf, e04nqf, e04ntf, nag_wp, x04acf, & x04adf Use e04mxfe_mod, Only: fname, lencw, leniw, lenrw, mpslst, nin, nout, & qphx, readints ! .. Implicit None Statement .. Implicit None ! .. Local Scalars .. Real (Kind=nag_wp) :: obj, objadd, sinf Integer :: i, ifail, iobj, lenc, lintvar, & m, maxlintvar, maxm, maxn, & maxncolh, maxnnz, maxnnzh, & minmax, mode, n, ncolh, ninf, & nname, nnz, nnzh, ns Character (1) :: start ! .. Local Arrays .. Real (Kind=nag_wp), Allocatable :: a(:), bl(:), bu(:), c(:), h(:), & pi(:), rc(:), ruser(:), rw(:), & x(:) Real (Kind=nag_wp) :: rdummy(1) Integer, Allocatable :: helast(:), hs(:), iccola(:), & iccolh(:), intvar(:), irowa(:), & irowh(:), iuser(:), iw(:) Integer :: idummy(1) Character (8) :: cdummy(1), cuser(1), pnames(5) Character (8), Allocatable :: crname(:), cw(:) ! .. Intrinsic Procedures .. Intrinsic :: max, min ! .. Executable Statements .. Write (nout,*) 'E04MXF Example Program Results' ! Initialize pnames(1:5) = ' ' maxm = 0 maxn = 0 maxnnz = 0 maxnnzh = 0 maxncolh = 0 If (readints) Then maxlintvar = 0 Else maxlintvar = -1 End If ! Open the data file for reading mode = 0 ifail = 0 Call x04acf(nin,fname,mode,ifail) ! Call e04mxf in query mode ifail = 0 Call e04mxf(nin,maxn,maxm,maxnnz,maxncolh,maxnnzh,maxlintvar,mpslst,n,m, & nnz,ncolh,nnzh,lintvar,iobj,rdummy,idummy,idummy,rdummy,rdummy,pnames, & nname,cdummy,rdummy,idummy,idummy,minmax,idummy,ifail) ! Close the data file ifail = 0 Call x04adf(nin,ifail) ! set maxm maxn and maxnnz maxm = m maxn = n maxnnz = nnz maxnnzh = nnzh maxncolh = ncolh If (readints) Then maxlintvar = lintvar Else maxlintvar = -1 End If ! Allocate memory Allocate (irowa(maxnnz),iccola(maxn+1),a(maxnnz),bl(maxn+maxm), & bu(maxn+maxm),crname(maxn+maxm),irowh(maxnnzh),iccolh(maxncolh+1), & h(maxnnzh),intvar(maxlintvar)) ! Open the data file for reading mode = 0 ifail = 0 Call x04acf(nin,fname,mode,ifail) ! Call e04mxf to read the problem ifail = 0 Call e04mxf(nin,maxn,maxm,maxnnz,maxncolh,maxnnzh,maxlintvar,mpslst,n,m, & nnz,ncolh,nnzh,lintvar,iobj,a,irowa,iccola,bl,bu,pnames,nname,crname, & h,irowh,iccolh,minmax,intvar,ifail) ! Close the data file ifail = 0 Call x04adf(nin,ifail) ! Data has been read. Set up and run the solver Allocate (iw(leniw),rw(lenrw),cw(lencw)) ! Call e04npf to initialize workspace ifail = 0 Call e04npf(cw,lencw,iw,leniw,rw,lenrw,ifail) ! By default E04NQF does not print monitoring ! information. Set the print file unit or the summary ! file unit to get information. ifail = 0 Call e04ntf('Print file',nout,cw,iw,rw,ifail) ! We have no explicit objective vector so set LENC = 0; the ! objective vector is stored in row IOBJ of ACOL. lenc = 0 objadd = 0.0E0_nag_wp start = 'C' Allocate (c(max(1,lenc)),helast(n+m),x(n+m),pi(m),rc(n+m),hs(n+m),iuser( & ncolh+1+nnzh),ruser(nnzh)) helast(1:n+m) = 0 hs(1:n+m) = 0 Do i = 1, n + m x(i) = min(max(0.0E0_nag_wp,bl(i)),bu(i)) End Do If (ncolh>0) Then ! Store the non zeros of H in ruser for use by qphx ruser(1:nnzh) = h(1:nnzh) ! Store iccolh and irowh in iuser for use by qphx iuser(1:ncolh+1) = iccolh(1:ncolh+1) iuser(ncolh+2:nnzh+ncolh+1) = irowh(1:nnzh) End If ! Call e04nqf to solve the problem ifail = 0 Call e04nqf(start,qphx,m,n,nnz,nname,lenc,ncolh,iobj,objadd,pnames(1),a, & irowa,iccola,bl,bu,c,crname,helast,hs,x,pi,rc,ns,ninf,sinf,obj,cw, & lencw,iw,leniw,rw,lenrw,cuser,iuser,ruser,ifail) End Program e04mxfe