Mercurial > hg > octave-lyh
changeset 3044:8ec2d00e20e5
[project @ 1997-06-06 21:53:38 by jwe]
| author | jwe |
|---|---|
| date | Fri, 06 Jun 1997 22:03:24 +0000 |
| parents | 9a5525df1c21 |
| children | d2046ca9a380 |
| files | ChangeLog PROJECTS README.NLP acconfig.h libcruft/ChangeLog libcruft/Makefile.in libcruft/STOP.patch libcruft/configure.in libcruft/fsqp/COPYRIGHT libcruft/fsqp/Makefile.in libcruft/fsqp/README libcruft/fsqp/README.MISSING libcruft/fsqp/Version libcruft/fsqp/check.f libcruft/fsqp/di1.f libcruft/fsqp/diagnl.f libcruft/fsqp/dir.f libcruft/fsqp/dqp.f libcruft/fsqp/error.f libcruft/fsqp/estlam.f libcruft/fsqp/fool.f libcruft/fsqp/fsqpd.f libcruft/fsqp/fsqpd1.f libcruft/fsqp/grcnfd.f libcruft/fsqp/grobfd.f libcruft/fsqp/hesian.f libcruft/fsqp/indexs.f libcruft/fsqp/initpt.f libcruft/fsqp/lfuscp.f libcruft/fsqp/macros.tex libcruft/fsqp/manua2.tex libcruft/fsqp/manual.sty libcruft/fsqp/manual.tex libcruft/fsqp/matrcp.f libcruft/fsqp/matrvc.f libcruft/fsqp/nullvc.f libcruft/fsqp/out.f libcruft/fsqp/ql0001.f libcruft/fsqp/ql0002.f libcruft/fsqp/resign.f libcruft/fsqp/sampl1.for libcruft/fsqp/sampl2.for libcruft/fsqp/sampl3.for libcruft/fsqp/sbout1.f libcruft/fsqp/sbout2.f libcruft/fsqp/scaprd.f libcruft/fsqp/shift.f libcruft/fsqp/slope.f libcruft/fsqp/small.f libcruft/fsqp/step.f libcruft/npsol/Makefile.in libcruft/npsol/README.MISSING libcruft/npsol/chcore.f libcruft/npsol/chfd.f libcruft/npsol/chkgrd.f libcruft/npsol/chkjac.f libcruft/npsol/cmalf.f libcruft/npsol/cmalf1.f libcruft/npsol/cmchk.f libcruft/npsol/cmperm.f libcruft/npsol/cmprt.f libcruft/npsol/cmqmul.f libcruft/npsol/cmr1md.f libcruft/npsol/cmrswp.f libcruft/npsol/cmtsol.f libcruft/npsol/dcond.f libcruft/npsol/dddiv.f libcruft/npsol/ddiv.f libcruft/npsol/ddscl.f libcruft/npsol/dgeap.f libcruft/npsol/dgeapq.f libcruft/npsol/dgeqr.f libcruft/npsol/dgeqrp.f libcruft/npsol/dgrfg.f libcruft/npsol/dload.f libcruft/npsol/dnorm.f libcruft/npsol/drot3.f libcruft/npsol/drot3g.f libcruft/npsol/dssq.f libcruft/npsol/icopy.f libcruft/npsol/idrank.f libcruft/npsol/iload.f libcruft/npsol/lsadd.f libcruft/npsol/lsadds.f libcruft/npsol/lsbnds.f libcruft/npsol/lschol.f libcruft/npsol/lscore.f libcruft/npsol/lscrsh.f libcruft/npsol/lsdel.f libcruft/npsol/lsdflt.f libcruft/npsol/lsfeas.f libcruft/npsol/lsfile.f libcruft/npsol/lsgetp.f libcruft/npsol/lsgset.f libcruft/npsol/lskey.f libcruft/npsol/lsloc.f libcruft/npsol/lsmove.f libcruft/npsol/lsmuls.f libcruft/npsol/lsoptn.f libcruft/npsol/lsprt.f libcruft/npsol/lssetx.f libcruft/npsol/lssol.f libcruft/npsol/mcenv1.f libcruft/npsol/mcenv2.f libcruft/npsol/mceps.f libcruft/npsol/mchpar.f libcruft/npsol/mcmin.f libcruft/npsol/mcsmal.f libcruft/npsol/mcstor.f libcruft/npsol/npalf.f libcruft/npsol/npchkd.f libcruft/npsol/npcore.f libcruft/npsol/npcrsh.f libcruft/npsol/npdflt.f libcruft/npsol/npfd.f libcruft/npsol/npfeas.f libcruft/npsol/npfile.f libcruft/npsol/npiqp.f libcruft/npsol/npkey.f libcruft/npsol/nploc.f libcruft/npsol/npmrt.f libcruft/npsol/npoptn.f libcruft/npsol/npprt.f libcruft/npsol/nprset.f libcruft/npsol/npsetx.f libcruft/npsol/npsol.f libcruft/npsol/npsrch.f libcruft/npsol/npupdt.f libcruft/npsol/opfile.f libcruft/npsol/oplook.f libcruft/npsol/opnumb.f libcruft/npsol/opscan.f libcruft/npsol/optokn.f libcruft/npsol/opuppr.f libcruft/npsol/srchc.f libcruft/npsol/srchq.f libcruft/qpsol/Makefile.in libcruft/qpsol/README.MISSING libcruft/qpsol/addcon.f libcruft/qpsol/alloc.f libcruft/qpsol/axpy.f libcruft/qpsol/bdpert.f libcruft/qpsol/bndalf.f libcruft/qpsol/chkdat.f libcruft/qpsol/condvc.f libcruft/qpsol/copymx.f libcruft/qpsol/copyvc.f libcruft/qpsol/delcon.f libcruft/qpsol/dot.f libcruft/qpsol/dscale.f libcruft/qpsol/elm.f libcruft/qpsol/elmgen.f libcruft/qpsol/etagen.f libcruft/qpsol/findp.f libcruft/qpsol/getlam.f libcruft/qpsol/lpbgst.f libcruft/qpsol/lpcore.f libcruft/qpsol/lpcrsh.f libcruft/qpsol/lpdump.f libcruft/qpsol/lpgrad.f libcruft/qpsol/lpprt.f libcruft/qpsol/prtsol.f libcruft/qpsol/qpchkp.f libcruft/qpsol/qpcolr.f libcruft/qpsol/qpcore.f libcruft/qpsol/qpcrsh.f libcruft/qpsol/qpdump.f libcruft/qpsol/qpgrad.f libcruft/qpsol/qpprt.f libcruft/qpsol/qpsol.f libcruft/qpsol/quotnt.f libcruft/qpsol/refgen.f libcruft/qpsol/rot3.f libcruft/qpsol/rotgen.f libcruft/qpsol/rsolve.f libcruft/qpsol/sscale.f libcruft/qpsol/tqadd.f libcruft/qpsol/tsolve.f libcruft/qpsol/v2norm.f libcruft/qpsol/zerovc.f libcruft/qpsol/zyprod.f octMakefile.in test/octave.test/npsol/npsol-1.m test/octave.test/npsol/npsol-2.m test/octave.test/npsol/npsol.exp |
| diffstat | 185 files changed, 21 insertions(+), 30857 deletions(-) [+] |
line wrap: on
line diff
--- a/ChangeLog +++ b/ChangeLog @@ -1,5 +1,15 @@ Fri Jun 6 15:20:42 1997 John W. Eaton <jwe@bevo.che.wisc.edu> + * octMakefile.in (dist, binary-dist): Don't worry about npsol or qpsol. + * configure.in: Don't create libcruft/fsqp/Makefile, + libcruft/npsol/Makefile, or libcruft/qpsol/Makefile. + + * octMakefile.in (DISTFILES): Don't distribute MAKEINFO.PATCH. + + * octMakefile.in (DISTFILES): Don't distribute README.NLP. + * configure.in: Delete checks for FSQP, NPSOL, and QPSOL. + * acconfig.h: Delete undefs for FSQP, NPSOL, and QPSOL. + * readline: Update to new version (2.1). Thu Jun 5 01:38:04 1997 John W. Eaton <jwe@bevo.che.wisc.edu>
--- a/PROJECTS +++ b/PROJECTS @@ -51,32 +51,10 @@ * Implement the following functions: -- ppval -- cross -- dot - * Allow user-supplied gradient information to be passed to NPSOL. - - * Actually allow control of the derivative level in NPSOL. It can - be changed with npsol_options(), but then NPSOL::do_minimize() - sets it based on whether gradient and jacobian functions are - available. - * When constructing NLConst (and other) objects, make sure that there are sufficient checks to ensure that the dimensions all conform. - * Support for FSQP. - - * Convert FSQP style NLP statement to NPSOL style. - - * Convert NPSOL style NLP statement to FSQP style. - - Look for linear equality constraints, extract corresponding rows - of C. The rest are inequality constraints. - - Look for Nonlinear equality constraints and set up a vector of - pointers for shuffling. - - Transform lb <= C*x <= ub, lb != ub, to C*x - ub <= 0 and - lb - C*x <= 0. Likewise for lb <= g(x) <= ub. - - Call FSQP. - - * Optional inputs for fsqp. - * Allow parameters to be passed through the call to fsolve() to the user-supplied function for Matlab compatibility. Don't place an upper limit on the number of arguments.
deleted file mode 100644 --- a/README.NLP +++ /dev/null @@ -1,19 +0,0 @@ -If you don't have NPSOL but you still want to be able to solve NLPs, -or if you don't have QPSOL but you still want to solve QPs, you'll -need to find replacements or order them from Stanford. If you know of -a freely redistributable replacement, please let us know--we might be -interested in distributing it with Octave. - -You can get more information about NPSOL and QPSOL from - - Stanford University - Office of Technology Licensing - 857 Serra Street - Stanford CA 94305-6225 - Tel: (415) 723-0651 - Fax: (415) 725-7295 - -Octave may soon support FSQP, an NLP solver from Andre Tits -(andre@src.umd.edu) of the University of Maryland. FSQP is available -free of charge to academic sites, but can not be redistributed to -third parties.
--- a/acconfig.h +++ b/acconfig.h @@ -21,9 +21,6 @@ upper case. */ #undef F77_UPPERCASE_NAMES -/* Define if you don't have FSQP. */ -#undef FSQP_MISSING - /* Define if your system has a single-arg prototype for gettimeofday. */ #undef GETTIMEOFDAY_NO_TZ @@ -66,18 +63,12 @@ /* Define (to string::npos) if <string> doesn't. */ #undef NPOS -/* Define if you don't have NPSOL. */ -#undef NPSOL_MISSING - /* Define to compile smaller kernel. */ #undef OCTAVE_LITE /* Define if this is Octave. */ #undef OCTAVE_SOURCE -/* Define if you don't have QPSOL. */ -#undef QPSOL_MISSING - /* Define if your struct rusage only has time information. */ #undef RUSAGE_TIMES_ONLY
--- a/libcruft/ChangeLog +++ b/libcruft/ChangeLog @@ -1,3 +1,8 @@ +Fri Jun 6 16:49:22 1997 John W. Eaton <jwe@bevo.che.wisc.edu> + + * fsqp, npsol, qpsol: Delete directories. + * Makefile.in (CRUFT_DIRS): Delete fsqp, npsol, and qpsol from list. + Thu Jun 5 01:40:36 1997 John W. Eaton <jwe@bevo.che.wisc.edu> * Makefile.in, Makerules.in: Make building of static library optional.
--- a/libcruft/Makefile.in +++ b/libcruft/Makefile.in @@ -24,8 +24,8 @@ # generate a new configure script in the top-level directory (edit # configure.in and run autoconf). -CRUFT_DIRS = balgen blas dassl eispack fftpack fsqp lapack linpack \ - minpack misc npsol odepack qpsol quadpack ranlib slatec-fn \ +CRUFT_DIRS = balgen blas dassl eispack fftpack lapack linpack \ + minpack misc odepack quadpack ranlib slatec-fn \ villad SUBDIRS = $(CRUFT_DIRS)
--- a/libcruft/STOP.patch +++ b/libcruft/STOP.patch @@ -63,60 +63,6 @@ 1999 FORMAT(' I1MACH - I OUT OF BOUNDS',I10) ! CALL XSTOPX (' ') END -diff -rc libcruft.orig/npsol/mcenv2.f libcruft/npsol/mcenv2.f -*** libcruft.orig/npsol/mcenv2.f Sun Oct 25 23:36:33 1992 ---- libcruft/npsol/mcenv2.f Mon Jun 7 14:36:21 1993 -*************** -*** 134,140 **** - END IF - ELSE - WRITE( NOUT, 9999 ) -! STOP - END IF - ELSE - IF( NGPMIN.EQ.GPMIN )THEN ---- 134,140 ---- - END IF - ELSE - WRITE( NOUT, 9999 ) -! CALL XSTOPX (' ') - END IF - ELSE - IF( NGPMIN.EQ.GPMIN )THEN -*************** -*** 148,154 **** - END IF - ELSE - WRITE( NOUT, 9999 ) -! STOP - END IF - IF( NGNMIN.EQ.GNMIN )THEN - LEMIN2 = NGNMIN ---- 148,154 ---- - END IF - ELSE - WRITE( NOUT, 9999 ) -! CALL XSTOPX (' ') - END IF - IF( NGNMIN.EQ.GNMIN )THEN - LEMIN2 = NGNMIN -*************** -*** 161,167 **** - END IF - ELSE - WRITE( NOUT, 9999 ) -! STOP - END IF - LEMIN = MAX( LEMIN1, LEMIN2 ) - END IF ---- 161,167 ---- - END IF - ELSE - WRITE( NOUT, 9999 ) -! CALL XSTOPX (' ') - END IF - LEMIN = MAX( LEMIN1, LEMIN2 ) - END IF diff -rc libcruft.orig/odepack/xerrwv.f libcruft/odepack/xerrwv.f *** libcruft.orig/odepack/xerrwv.f Wed Feb 19 23:50:24 1992 --- libcruft/odepack/xerrwv.f Mon Jun 7 14:38:00 1993
deleted file mode 100644 --- a/libcruft/configure.in +++ /dev/null @@ -1,33 +0,0 @@ -dnl configure.in -dnl -dnl Process this file with autoconf to produce a configure script. -dnl -dnl Copyright (C) 1996, 1997 John W. Eaton -### -### This file is part of Octave. -### -### Octave is free software; you can redistribute it and/or modify it -### under the terms of the GNU General Public License as published by the -### Free Software Foundation; either version 2, or (at your option) any -### later version. -### -### Octave is distributed in the hope that it will be useful, but WITHOUT -### ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or -### FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -### for more details. -### -### You should have received a copy of the GNU General Public License -### along with Octave; see the file COPYING. If not, write to the Free -### Software Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. - -AC_REVISION() -AC_PREREQ(2.0) -AC_INIT(misc/xstopx.f) - -AC_PROG_INSTALL - -AC_OUTPUT(Makefile Makerules blas/Makefile balgen/Makefile - dassl/Makefile eispack/Makefile fftpack/Makefile fsqp/Makefile - lapack/Makefile linpack/Makefile minpack/Makefile misc/Makefile - npsol/Makefile odepack/Makefile qpsol/Makefile quadpack/Makefile - ranlib/Makefile slatec-fn/Makefile villad/Makefile)
deleted file mode 100644 --- a/libcruft/fsqp/COPYRIGHT +++ /dev/null @@ -1,41 +0,0 @@ -Date: Sat, 30 May 92 11:37:56 EDT -To: fsqp_sites@src.umd.edu -From: Andre Tits <andre@src.umd.edu> -Subject: FSQP 3.0 1/12: COPYRIGHT - - Conditions for External Use - - - 1. The FSQP routines may not be distributed to third parties. - Interested parties should contact the authors directly. - 2. If modifications are performed on the routines, these - modifications shall be communicated to the authors. The - modified routines will remain the sole property of the - authors. - 3. Due acknowledgment must be made of the use of the FSQP - routines in research reports or publications. A copy of - such reports or publications should be forwarded to the - authors. - 4. The FSQP routines may not be used for commercial - applications, unless this has been agreed upon with the - authors in writing. - -Copyright (c) 1989 --- 1992 by Jian L. Zhou and Andre L. Tits. -All rights Reserved. - - - Enquiries should be directed to - - Prof. Andre L. Tits - Electrical Engineering Dept. - and Systems Research Center - University of Maryland - College Park, Md 20742 - U. S. A. - - Phone: 301-405-3669 - Fax: 301-405-6707 - E-mail: andre@src.umd.edu - - -
deleted file mode 100644 --- a/libcruft/fsqp/Makefile.in +++ /dev/null @@ -1,23 +0,0 @@ -# -# Makefile for octave's libcruft/fsqp directory -# -# John W. Eaton -# jwe@bevo.che.wisc.edu -# University of Wisconsin-Madison -# Department of Chemical Engineering - -TOPDIR = ../.. - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ - -SPECIAL = COPYRIGHT README Version macros.tex manua2.tex \ - manual.sty manual.tex sampl1.for sampl2.for sampl3.for - -EXTERNAL_DISTFILES = Makefile.in COPYRIGHT README README.MISSING \ - ql0001.f ql0002.f - -include $(TOPDIR)/Makeconf - -include ../Makerules
deleted file mode 100644 --- a/libcruft/fsqp/README +++ /dev/null @@ -1,48 +0,0 @@ -Date: Sat, 30 May 92 11:37:57 EDT -To: fsqp_sites@src.umd.edu -From: Andre Tits <andre@src.umd.edu> -Subject: FSQP 3.0 2/12: README - -The FSQP distribution consists of the following files: - COPYRIGHT - README (this file) - Version* - fsqpd.f - macros.tex - manual.sty - manual.tex - manua2.tex - qld.f - sampl1.f - sampl2.f - sampl3.f -We suggest that you keep all these files in a dedicated subdirectory. - -All the FSQP routines are in fsqpd.f. FSQP requires a quadratic -program solver. As distributed, it calls QLD (written by -Klaus Schittkowski, provided in file qld.f for the user's convenience). -Three sample test problems are given in sampl1.f, sampl2.f and sampl3.f. -Thus, for example, to run sample1.f one should use the following -compiling sequence on a UNIX-based system - - f77 sampl1.f fsqpd.f qld.f - -The results obtained should be compared with those given in the -User's Guide. - -The User's Guide is provided in latex format (files manual.tex, -manua2.tex, macros.tex and manual.sty). It provides detailed information -concerning FSQP and its use. Simply type - - latex manual.tex - -with files manua2.tex, manual.sty and macros.tex present -in the same directory. - -Finally, the file Versionx.x lists the enhancements in the -successive versions of FSQP. - -Please send us your comments. Any feedback is highly appreciated. - - -
deleted file mode 100644 --- a/libcruft/fsqp/README.MISSING +++ /dev/null @@ -1,29 +0,0 @@ -If it were freely redistributable, the source for Tits and Zhou's -nonlinear programming solver FSQP would be in this directory. - -Unfortunately, if you want octave to use FSQP to solve constrained -nonlinear optimization problems, you must get the source from the -FSQP authors. Enquiries should be directed to: - - Prof. Andre L. Tits - Electrical Engineering Dept. - and Systems Research Center - University of Maryland - College Park, MD 20742 - USA - - Phone: 301-405-3669 - Fax: 301-405-6707 - E-mail: andre@src.umd.edu - -As of November, 1992, the routines were available free of charge to -academic sites. I do not know what the distribution terms are for -others. See the file COPYRIGHT in the directory for more information. - - - - - - - -
deleted file mode 100644 --- a/libcruft/fsqp/Version +++ /dev/null @@ -1,142 +0,0 @@ - Enhancements in successive versions of FSQP - -Version 3.3 : April 1993 - 1. If the user so requests (via "mode"), during the line search, - FSQP will now evaluate objectives only after having determined - that all constraints are satisfied. This is of value when some - objective functions are not defined outside the feasible set. - 2. The reserved common block "fsqpst" is no longer used by FSQP. - Instead, a new reserved common block "fsqpus" is provided to - give the users a choice of several possible stopping criteria. - (As a side-effect, the user is not allowed any more to have - his/her own block data; see Section 4 of the manual for details.) - 3. Some imperfections are fixed (e.g., comparision of double - precision number to hard zero, and incorrect checking of value - of "mode"). - -Version 3.2 : March 1993 - 1. The user is given the option to print output at every Nth iteration - and at the end, where N is a multiple of 10. - -Version 3.1a : January 1993 - 1. Bugs are fixed (with the help of Yaguang Yang). These bugs - have to do with finding a feasible point. There should be - no effect if the user's problem does not contain both nonlinear - and linear equality constraints. - -Version 3.1 : November 1992 - 1. Possible division by zero is avoided. - 2. Objective and constraint values at initial feasible point - are printed out if iprint >=1. - 3. Estimates of Lagrange multipliers are made available on output - even when execution is terminated abnormally in phase 2. - 4. Incorrect descriptions of nineq, neq, iwsize and nwsize in - the user's manual and in the comments in fsqpd.f are corrected. - -Version 3.0d : October 1992 - 1. Some imperfections (identified by WATFOR) are cleaned up. - 2. Erroneous declaration of dummy argument in sampl*.f are corrected. - -Version 3.0c : September 1992 - 1. A bug in identifying the active set of objectives is fixed. - (Thanks go to Yaguang Yang.) - 2. Some imperfections (identified by WATFOR) are cleaned up. - (Thanks go to Jaroslav Dolezal and Jiri Fidler - at CZ Academy of Sciences.) - -Version 3.0b : August 1992 - 1. A bug in assigning iskip(*) is fixed. This has to do with - finding a feasible point. - 2. Other bugs associated with nonlinear equality constraints - are fixed. The effect is on nonmonotone line search. - (Thanks go to Yaguang Yang at the Institute for Systems Research, - University of Maryland at College Park.) - -Version 3.0a : June 1992 - 1. A bug in check.f is fixed and a typo is corrected. - 2. A bug in initpt.f is fixed. - 3. Printout message is adjusted for various situations. - 4. Computation of initial equality constraint violation is corrected. - (Thanks go to Jaroslav Dolezal and Jiri Fidler - at CZ Academy of Sciences) - 5. An output error for function values is corrected. - -Version 3.0 : June 1992 - 1. FSQP now also handles nonlinear equality constraints. - "Semi-feasibility" for these constraints is maintained in - the following sense: given a scalar constraint h(x)=0, - if h(x0)<=0 (resp. >=0), then h(xk)<=0 (resp. >=0) for all k. - 2. An option is added to allow users to have their own stopping - criterion. - 3. The interface for QPSOL is no longer part of the standard - distribution (but it is still available on request). - 4. Objective and constraints now must be provided in Fortran - "subroutines" rather than "functions". - 5. Concerning the default stopping criterion, the norm requirement - on the Kuhn-Tucker vector is replaced by a norm requirement on - the Newton direction. - 6. The meaning of "mode" is redefined to encompass several attributes. - 7. The argument list to call FSQPD is modified. - 8. The Hessian matrix is reset to the identity whenever - the line search fails to complete after a specified number - of step reductions, provided the last reset occurred at least - 5*nparam iterations earlier (it used to be 1*nparam). - -Version 2.4b : November 1991 - 1. Bugs are fixed that affected the computation of a feasible point - and the initialization of iskp. (Thanks go to Klaus Schittkowski - at U Bayreuth and John Hauser at USC.) - -Version 2.4a : November 1991 - Mostly fixes on problems uncovered by Roque Donizete de Oliveira (Michigan. -) - 1. A bug is fixed that affected the multipliers given on output. - 2. A few unused statements are commented out. - 3. small() is modified to avoid too small a number on machines - that use extra-length registers for internal computations - (with Roque's help). - -Version 2.4 : October 1991 - 1. The Hessian matrix is reset to the identity whenever - the line search fails to complete after a specified number - of step reductions, provided the last reset occurred at least - nparam iterations earlier. - -Version 2.3B : September 1991 - 1. A bug is fixed in reordering active functions. - -Version 2.3A : September 1991 - 1. A bug is fixed in reordering active functions. - -Version 2.3 : July 1991 - 1. KKT multipliers at the solution point are provided on output. - 2. Bugs are fixed and code is adapted to be accepted by - some "tough" compilers (with the help of K. Schittkowski). - -Version 2.2 : June 1991 - 1. In computing d~, only the most "active" constraints and - objectives are taken into account, thus reducing the - number of function evaluations. - 2. Refinements of nonmonotone line search are implemented - for minimax problems without nonlinear constraints. - 3. Line search is more efficient. - 4. A bug is fixed in the computation of d~ in mode=1. - 5. The calling sequences of both gradcn and gradob are - simplified. - -Version 2.1 : April 1991 - 1. FSQP can use either of two quadratic programming codes: - QPSOL or QLD. - 2. Reorder constraints and objectives to enable more efficient - line search. - - -Version 2.0B : March 1991: Bugs are fixed -Version 2.0A : October 1990: Bugs are fixed -Version 2.0 : August 1990 - 1. Extension to the solution of constrained minimax problems. - - -Version 1.0B : June 1990: Bugs are fixed -Version 1.0A : December 1989: Bugs are fixed -Version 1.0 : August 1989
deleted file mode 100644 --- a/libcruft/fsqp/check.f +++ /dev/null @@ -1,77 +0,0 @@ - subroutine check(nparam,nf,Linfty,nAD,nineq,nnl,neq,neqn, - * mode,modem,lstype,eps,bigbnd,bl,bu) -c -c FSQP Version 3.3 : check input data -c -c implicit real*8(a-h,o-z) - integer nparam,nf,nineq,nnl,neq,neqn,mode,modem,lstype - double precision bigbnd,eps - double precision bl(nparam),bu(nparam) - logical Linfty,nAD -c - integer io,iprint,ipspan,ipyes,info,idum1,idum2,idum3 - double precision epsmac,dummy1,dummy2,dummy3 - common /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,idum2,idum3, - * /fsqpp3/epsmac,dummy1,dummy2,dummy3 -c - integer i - double precision bli,bui -c - if (nparam.le.0) - * call error('nparam should be positive! ',info,io) - if (nf.lt.0) - * call error('nf should not be negative! ',info,io) - if (nnl.lt.0) - * call error('nineqn should not be negative! ',info,io) - if (nineq.lt.nnl) - * call error('nineq should be no smaller than nineqn!',info,io) - if (neqn.lt.0) - * call error('neqn should not be negative! ',info,io) - if (neq.lt.neqn) - * call error('neq should not be smaller than neqn ',info,io) - if (nparam.le.neq) - * call error('FSQPD deals with nparam larger than neq ',info,io) - if (iprint.lt.0.or.iprint.gt.3) - * call error('iprint is not a valid number ',info,io) - if (eps.gt.epsmac) goto 10 - call error('eps should be bigger than epsmac! ',info,io) - write(io,9902) epsmac - 10 if(mode.ge.200) then - lstype=2 - mode=mode-100 - else - lstype=1 - endif - if (.not.(mode.eq.100.or.mode.eq.101.or. - * mode.eq.110.or.mode.eq.111)) - * call error('mode is not properly specified! ',info,io) - if (info.eq.0) goto 20 - write(io,9903) - goto 9000 -c - 20 do 30 i=1,nparam - bli=bl(i) - bui=bu(i) - if (bli.le.bui) goto 25 - write(io,9901) - info=7 - 25 if (info.ne.0) goto 9000 - if (bli.lt.(-bigbnd)) bl(i)=-bigbnd - if (bui.gt.bigbnd) bu(i)=bigbnd - 30 continue -c - i=mode-100 - if(i.lt.10) then - modem=0 - else - modem=1 - i=i-10 - endif - if(i.eq.0) Linfty=.false. - if(i.eq.1) Linfty=.true. -c - 9000 return - 9901 format(1x,'lower bounds should be smaller than upper bounds',/) - 9902 format(1x,'epsmac = ',e22.14,' which is machine dependent',/) - 9903 format(1x,'Error: Input parameters are not consistent',/) - end
deleted file mode 100644 --- a/libcruft/fsqp/di1.f +++ /dev/null @@ -1,83 +0,0 @@ -c - subroutine di1(nparam,nqpram,nob,nobL,nineqn,neq,neqn,ncnstr, - * nclin,nctotl,nrowa,infoqp,mode,iw,leniw,x0,d0, - * xl,xu,f,fM,gradf,grdpsf,g,gradg,cvec,a,bl,bu, - * clamda,bj,hess1,x,w,lenw) -c implicit real*8(a-h,o-z) - integer nparam,nqpram,nob,nobL,nineqn,neq,neqn,ncnstr,nclin, - * nctotl,nrowa,infoqp,mode,leniw,lenw,iw(leniw) - double precision fM - double precision x0(nparam),d0(nparam),xl(nparam),xu(nparam), - * f(1),gradf(nparam,1),grdpsf(nparam),g(1), - * gradg(nparam,1),cvec(1),a(nrowa,1), - * bl(1),bu(1),clamda(1),bj(1), - * hess1(nparam+1,nparam+1),x(1),w(lenw) -c double precision x0(nparam),d0(nparam),xl(nparam),xu(nparam), -c * f(nob),gradf(nparam,nob),grdpsf(nparam),g(ncnstr), -c * gradg(nparam,ncnstr),cvec(nqpram),a(nrowa,nqpram), -c * bl(nctotl),bu(nctotl),clamda(nctotl+nqpram),bj(nrowa), -c * hess1(nparam+1,nparam+1),x(nqpram),w(lenw) -c - integer io,idum1,idum2,idum3,idum4,idum5,idum6,idum7 - double precision epsmac,rteps,dumm1,dumm2,bigbnd,dummy - common /fsqpp2/io,idum1,idum2,idum3,idum4,idum5,idum6,idum7, - * /fsqpp3/epsmac,rteps,dumm1,dumm2, - * /fsqpq1/bigbnd,dummy -c -c bj(1) is equivalent to bl(nparam+3) -c - integer i,ii,iout,j,mnn - double precision x0i,eta -c - iout=io - if(mode.eq.0) eta=0.1d0 - if(mode.eq.1) eta=3.d0 - do 100 i=1,nparam - x0i=x0(i) - bl(i)=xl(i)-x0i - bu(i)=xu(i)-x0i - if(mode.eq.0) cvec(i)=-eta*d0(i) - if(mode.eq.1) cvec(i)=0.d0 - 100 continue - bl(nqpram)=-bigbnd - bu(nqpram)=bigbnd - cvec(nqpram)=1.d0 - ii=ncnstr-nineqn - do 400 i=1,ncnstr - bj(i)=-g(ncnstr+1-i) - do 300 j=1,nparam - 300 a(i,j)=-gradg(j,ncnstr+1-i) - a(i,nqpram)=0.d0 - if((i.gt.(neq-neqn).and.i.le.neq).or.i.gt.ii) a(i,nqpram)=1.d0 - 400 continue - if(mode.eq.1) goto 610 - do 600 i=1,nob - ii=ncnstr+i - bj(ii)=fM-f(i) - do 500 j=1,nparam - a(ii,j)=-gradf(j,i)+grdpsf(j) - if(nobL.gt.nob) a(ii+nob,j)=gradf(j,i)+grdpsf(j) - 500 continue - a(ii,nqpram)=1.d0 - if(nobL.gt.nob) a(ii+nob,nqpram)=1.d0 - 600 continue - 610 call diagnl(nqpram,eta,hess1) - call nullvc(nqpram,x) - hess1(nqpram,nqpram)=0.d0 -c -Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c -c The following modification is done inside QP0001 -c for the ease of interfacing with QPSOL -c -c hess1(nqpram,nqpram)=qleps -C - mnn=nclin+2*nqpram - iw(1)=1 - call QL0001(nclin,neq-neqn,nrowa,nqpram,nparam+1,mnn,hess1,cvec,A, - * bj,bL,bU,X,clamda,iout,infoqp,0,w,lenw,iw,leniw) -C -Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c - return - end
deleted file mode 100644 --- a/libcruft/fsqp/diagnl.f +++ /dev/null @@ -1,22 +0,0 @@ -c=== subroutines used in FSQPD 3.3 ===============================c -c c -c diagnl error estlam fool indexs lfuscp matrcp matrvc c -c nullvc resign sbout1 sbout2 scaprd shift slope small c -c c -c==================================================================c -c - subroutine diagnl(nrowa,diag,a) -c implicit real*8(a-h,o-z) - integer nrowa,i,j - double precision a(nrowa,1),diag -c double precision a(nrowa,nrowa),diag -c -c set a=diag*I, the diagonal matrix -c - do 200 i=1,nrowa - do 100 j=i,nrowa - a(i,j)=0.d0 - 100 a(j,i)=0.d0 - 200 a(i,i)=diag - return - end
deleted file mode 100644 --- a/libcruft/fsqp/dir.f +++ /dev/null @@ -1,417 +0,0 @@ - subroutine dir(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl, - * nrowa,feasb,steps,epskt,epseqn,sktnom,scvneq,Ck, - * d0nm,grdftd,xl,xu,indxob,indxcn,iact,iskp,iskip, - * istore,iw,leniw,x,di,d,g,gradg,f,fM,fMp,psf, - * gradf,grdpsf,penp,a,bl,bu,clamda,cllamd,cvec,bj, - * hess,hess1,w,lenw,backup,signeq,obj,constr) -c -c FSQP Version 3.3 : computation of a search direction -c -c implicit real*8(a-h,o-z) - integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl,nrowa, - * iskp,leniw,lenw - integer indxob(1),indxcn(1),iact(1),iskip(1), - * istore(1),iw(leniw) -c integer indxob(nob),indxcn(ncnstr),iact(nob+nineqn+neqn),iskip(1), -c * istore(nineqn+nob+neqn),iw(leniw) - double precision steps,epskt,epseqn,sktnom,Ck,d0nm,grdftd, - * fM,fMp,psf,scvneq - double precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1), - * d(nparam+1),g(1),gradg(nparam,1),f(1), - * gradf(nparam,1),grdpsf(nparam),penp(1), - * a(nrowa,nparam+1),bl(1),bu(1),clamda(1),cllamd(1), - * cvec(nparam+1),bj(nrowa),hess(nparam,nparam), - * hess1(nparam+1,nparam+1),w(lenw), - * backup(1),signeq(1) -c double precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1), -c * d(nparam+1),g(ncnstr),gradg(nparam,ncnstr),f(nob), -c * gradf(nparam,nob), -c * grdpsf(nparam),penp(neqn),a(nrowa,nparam+1),bl(nctotl), -c * bu(nctotl),clamda(nctotl+nparam+1),cllamd(nctotl), -c * cvec(nparam+1),bj(nrowa),hess(nparam,nparam), -c * hess1(nparam+1,nparam+1),w(lenw), -c * backup(nob+ncnstr),signeq(neqn) - external obj,constr - logical feasb -c - integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info, - * ipd,iter,nstop,initvl,lstype - double precision epsmac,rteps,udelta,valnom,bigbnd,tolfea, - * objeps,objrep,gLgeps - logical dlfeas,local,update,first,lqpsl,ld0 - common /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop, - * /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl, - * /fsqpp3/epsmac,rteps,udelta,valnom - * /fsqpq1/bigbnd,tolfea, - * /fsqplo/dlfeas,local,update,first, - * /fsqpqp/lqpsl,ld0 - common /fsqpus/objeps,objrep,gLgeps -c -c bj(1) is equivalent to bl(nparam+3) -c - integer i,j,k,kk,ncg,ncf,nqprm0,nclin0,nctot0,infoqp,nqprm1,ncl, - * nclin1,nctot1,ncc,nff,nrowa0,nrowa1,ninq,nobb,nobbL,nncn - double precision fmxl,vv,dx,dmx,dnm1,dnm,v0,v1,vk,temp1,temp2, - * theta,rhol,rhog,rho,grdfd0,grdfd1,dummy,grdgd0,grdgd1, - * thrshd,sign,scaprd,slope,lfuscp,dsqrt,dmin1,dmax1,dabs, - * adummy(1),dnmtil - logical ltem1,ltem2 -c - ncg=0 - ncf=0 - iskp=0 - ncl=nnineq-nineqn - local=.false. - update=.false. - lqpsl=.false. - thrshd=tolfea -c - if(nobL.eq.1) goto 10 - nqprm0=nparam+1 - nclin0=ncnstr+nobL - goto 20 - 10 nqprm0=nparam - nclin0=ncnstr - 20 nctot0=nqprm0+nclin0 - vv=0.d0 - nrowa0=max0(nclin0,1) - do 25 i=1,ncnstr - if(feasb) then - if(i.gt.nineqn.and.i.le.nnineq) iskip(nnineq+2-i)=i - iw(i)=i - else if(.not.feasb) then - if(i.le.ncl) iskip(ncl+2-i)=nineqn+i - if(i.le.ncl) iw(i)=nineqn+i - if(i.gt.ncl) iw(i)=nineqn+neqn+i - endif - 25 continue - do 27 i=1,nob - 27 iw(ncnstr+i)=i - ld0=.true. - call nullvc(nparam,cvec) - call dqp(nparam,nqprm0,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nclin0, - * nctot0,nrowa0,infoqp,iw,leniw,x,di,xl,xu,feasb,f,fM, - * gradf,grdpsf,g,gradg,a,cvec,bl,bu,clamda,cllamd,bj, - * hess,hess1,di,w,lenw,vv,0) - ld0=.false. - if(infoqp.eq.0) goto 30 - info=5 - if(.not.feasb) info=2 - nstop=0 - goto 9000 -c -c reorder indexes of constraints and objectives -c - 30 if(nn.le.1) goto 45 - j=1 - k=nn - do 40 i=nn,1,-1 - if(lfuscp(cllamd(nqprm0+indxcn(i)),thrshd).ne.0) then - iact(j)=indxcn(i) - j=j+1 - else - iact(k)=indxcn(i) - k=k-1 - endif - 40 continue - 45 if(nobL.le.1) goto 60 - j=nn+1 - k=nn+nob - do 50 i=nob,1,-1 - kk=nqprm0+ncnstr - ltem1=lfuscp(cllamd(kk+i),thrshd).ne.0 - ltem2=nobL.ne.nob.and.(lfuscp(cllamd(kk+i+nob),thrshd).ne.0) - if(ltem1.or.ltem2) then - iact(j)=i - j=j+1 - else - iact(k)=i - k=k-1 - endif - 50 continue -c - 60 vv=f(iact(nn+1)) - d0nm=dsqrt(scaprd(nparam,di,di)) - if(.not.first.or.nclin0.ne.0) goto 110 - dx=dsqrt(scaprd(nparam,x,x)) - dmx=dmax1(dx,1.d0) - if(d0nm.le.dmx) goto 110 - do 100 i=1,nparam - 100 di(i)=di(i)*dmx/d0nm - d0nm=dmx - 110 call matrvc(nparam,nparam,nparam,nparam,hess,di,w) - if(nn.eq.0) grdftd=-scaprd(nparam,w,di) - sktnom=dsqrt(scaprd(nparam,w,w)) - if(gLgeps.gt.0.d0.and.sktnom.le.gLgeps) goto 115 - if(d0nm.gt.epskt) goto 120 - 115 if(neqn.ne.0.and.scvneq.gt.epseqn) goto 120 - nstop=0 - if(.not.feasb) info=2 - if(iprint.lt.3.or.ipyes.gt.0) goto 9000 - if(nobL.eq.1) nff=1 - if(nobL.gt.1) nff=2 - call sbout1(io,nparam,'multipliers for x ',dummy,cllamd,2,2) - if(ncnstr.ne.0) call sbout1(io,ncnstr,' for g ', - * dummy,cllamd(nparam+nff),2,2) - if(nobL.gt.1) call sbout1(io,nob,' for f ', - * dummy,cllamd(nparam+nff+ncnstr),2,2) - goto 9000 - 120 if(iprint.lt.3.or.ipyes.gt.0) goto 125 - call sbout1(io,nparam,'d0 ',dummy,di,2,2) - call sbout1(io,0,'d0norm ',d0nm,adummy,1,2) - call sbout1(io,0,'ktnorm ',sktnom,adummy,1,2) -c -c single objective without nonlinear constraints requires -c no d1 and dtilde; multi-objectives without nonlinear -c constraints requires no d1 -c - 125 call nullvc(nparam,w) - if(nn.ne.0) grdftd=slope(nob,nobL,neqn,nparam,feasb,f,gradf, - * grdpsf,di,w,fM,dummy,0) - if(nn.eq.0.and.nobL.eq.1) goto 1130 - if(nn.ne.0) goto 130 - dnm=d0nm - rho=0.d0 - rhog=0.d0 - goto 310 -c -c compute modified first order direction d1 -c - 130 nqprm1=nparam+1 - if(mode.eq.0) nclin1=ncnstr+nobL - if(mode.eq.1) nclin1=ncnstr - nctot1=nqprm1+nclin1 - nrowa1=max0(nclin1,1) - ninq=nnineq - call di1(nparam,nqprm1,nob,nobL,nineqn,neq,neqn,ncnstr,nclin1, - * nctot1,nrowa1,infoqp,mode,iw,leniw,x,di,xl,xu,f,fM, - * gradf,grdpsf,g,gradg,cvec,a,bl,bu,clamda,bj,hess1,d, - * w,lenw) - if(infoqp.eq.0) goto 140 - info=6 - if(.not.feasb) info=2 - nstop=0 - goto 9000 - 140 dnm1=dsqrt(scaprd(nparam,d,d)) - if(iprint.lt.3.or.ipyes.gt.0) goto 145 - call sbout1(io,nparam,'d1 ',dummy,d,2,2) - call sbout1(io,0,'d1norm ',dnm1,adummy,1,2) - 145 if(mode.eq.1) goto 150 - v0=d0nm**2.1 - v1=dmax1(dble(0.5),dble(dnm1**2.5)) - rho=v0/(v0+v1) - rhog=rho - goto 250 - 150 vk=dmin1(Ck*d0nm**2,d0nm) - rhol=0.d0 - do 200 i=1,nn - grdgd0=scaprd(nparam,gradg(1,indxcn(i)),di) - grdgd1=scaprd(nparam,gradg(1,indxcn(i)),d) - temp1=vk+g(indxcn(i))+grdgd0 - temp2=grdgd1-grdgd0 - if(temp1.le.0.d0) goto 200 - if(temp2.ge.0.d0) goto 190 - rhol=dmax1(rhol,-temp1/temp2) - if(rhol.lt.1.d0) goto 200 - 190 rhol=1.0d0 - goto 210 - 200 continue - 210 theta=0.2d0 - if(rhol.ne.0.d0) goto 220 -c -c to check if rhol is reset -c - rhog=0.d0 - rho=0.d0 - dnm=d0nm - goto 310 - 220 if(nobL.gt.1) goto 230 - grdfd0=grdftd - grdfd1=scaprd(nparam,gradf(1,1),d) - grdfd1=grdfd1-scaprd(nparam,grdpsf,d) - temp1=grdfd1-grdfd0 - if(temp1.le.0.d0) then - rhog=rhol - else - rhog=dmin1(rhol,(theta-1.d0)*grdfd0/temp1) - endif - goto 240 - 230 rhog=slope(nob,nobL,neqn,nparam,feasb,f,gradf(1,1),grdpsf, - * di,d,fM,theta,mode) - rhog=dmin1(rhol,rhog) - 240 rho=rhog - if (steps.eq.1.d0.and.rhol.lt.0.5d0) rho=rhol - 250 continue - do 300 i=1,nparam - if (rho.ne.rhog) cvec(i)=di(i) - di(i)=(1.d0-rho)*di(i)+rho*d(i) - 300 continue - dnm=dsqrt(scaprd(nparam,di,di)) - if(iprint.lt.3.or.mode.eq.1.or.nn.eq.0.or.ipyes.gt.0) goto 310 - call sbout1(io,0,'rho ',rho,adummy,1,2) - call sbout1(io,nparam,'d ',dummy,di,2,2) - call sbout1(io,0,'dnorm ',dnm,adummy,1,2) - 310 continue - 320 do 400 i=1,nob - 400 bl(i)=f(i) - if (rho.eq.1.d0) goto 510 - if(nn.eq.0.or.iprint.ne.3.or.mode.eq.0.or.ipyes.gt.0) goto 410 - call sbout1(io,0,'Ck ',Ck,adummy,1,2) - call sbout1(io,0,'rhol ',rho,adummy,1,2) - call sbout1(io,nparam,'dl ',dummy,di,2,2) - call sbout1(io,0,'dlnorm ',dnm,adummy,1,2) - 410 if(mode.eq.0) goto 510 - local=.true. - call step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg,ncf, - * indxob,indxcn,iact,iskp,iskip,istore,feasb,grdftd, - * f,fM,fMp,psf,penp,steps,scvneq,bu,x,di,d,g,w, - * backup,signeq,obj,constr) - if(update) goto 9000 - local=.false. - if(rho.eq.rhog.or.nn.eq.0) goto 510 - do 500 i=1,nparam - 500 di(i)=(1-rhog)*cvec(i)+rhog*d(i) - dnm=dsqrt(scaprd(nparam,di,di)) - 510 if (nn.eq.0.or.iprint.lt.3.or.mode.eq.0.or.ipyes.gt.0) goto 520 - call sbout1(io,0,'rhog ',rhog,adummy,1,2) - call sbout1(io,nparam,'dg ',dummy,di,2,2) - call sbout1(io,0,'dgnorm ',dnm,adummy,1,2) - 520 if(rho.ne.0.d0) grdftd=slope(nob,nobL,neqn,nparam,feasb,bl, - * gradf,grdpsf,di,d,fM,theta,0) - if(mode.eq.1.and.rho.eq.rhog) goto 610 - do 600 i=1,nparam - 600 bu(i)=x(i)+di(i) - 610 if(rho.ne.rhog) ncg=0 - ncc=ncg+1 - fmxl=-bigbnd - ninq=ncg - nncn=ncg - j=0 -c -c iskip(1) --- iskip(iskp) store the indexes of linear inequality -c constraints that are not to be used to compute d~ -c iskip(nnineq-nineqn+1) --- iskip(nnineq-ncn+1-iskp) store those -c that are to be used to compute d~ -c - do 700 i=ncc,ncnstr - kk=iact(i) - if(i.gt.nn) kk=indxcn(i) - if(kk.le.nineqn.or.kk.gt.nnineq) goto 615 - iskip(ncl+1-j)=kk - j=j+1 - 615 if(kk.gt.nnineq) goto 617 - temp1=-0.2d0*(dnm*dsqrt(scaprd(nparam,gradg(1,kk),gradg(1,kk)))) - temp2=cllamd(nqprm0+kk) - if(temp2.eq.0.d0.and.g(kk).lt.temp1) goto 620 - 617 ninq=ninq+1 - iw(ninq)=kk - if(feasb.and.kk.le.nineqn) istore(kk)=1 - call constr(nparam,kk,bu,g(kk)) - if(.not.feasb.or.feasb.and.kk.gt.nnineq) goto 700 - if(kk.le.nineqn) nncn=ninq - fmxl=dmax1(fmxl,g(kk)) - if(.not.feasb) goto 618 - if(kk.le.nineqn.or.kk.gt.nnineq.and.kk.le.(nnineq+neqn)) - * ncallg=ncallg+1 - 618 if(dabs(fmxl).gt.bigbnd) goto 1130 - goto 700 - 620 if(kk.le.nineqn) goto 700 - iskp=iskp+1 - iskip(iskp)=kk - j=j-1 - 700 continue - if(neqn.ne.0) call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1), - * gradg(1,nnineq+1),signeq,10,20) - ninq=ninq-neq - if(ncg.eq.0) goto 810 - do 800 i=1,ncg - iw(i)=iact(i) - istore(iact(i))=1 - fmxl=dmax1(fmxl,g(iact(i))) - if(dabs(fmxl).gt.bigbnd) goto 1130 - 800 continue - 810 if(nobL.gt.1) goto 820 - iw(1+ninq+neq)=1 - nobb=nob - goto 1110 - 820 if(rho.ne.rhog) ncf=0 - nff=ncf+1 - nobb=ncf - sign=1.d0 - fmxl=-bigbnd - if(cllamd(nqprm0+ncnstr+iact(nn+1)).lt.0.d0) sign=-1.d0 - do 1000 i=nff,nob - kk=iact(nn+i) - if(.not.feasb) kk=iact(i) - if(feasb) k=nn+1 - if(.not.feasb) k=1 - do 900 j=1,nparam - 900 w(j)=sign*gradf(j,iact(k))-gradf(j,kk) - temp1=dabs(f(kk)-sign*vv) - temp2=dnm*dsqrt(scaprd(nparam,w,w)) - if(temp1.eq.0.d0.or.temp2.eq.0.d0) goto 910 - temp1=temp1/temp2 - temp2=cllamd(nqprm0+ncnstr+kk) - if(temp2.eq.0.d0.and.temp1.gt.0.2d0) goto 1000 - 910 nobb=nobb+1 - if(feasb) then - iw(nobb+ninq+neq)=kk - istore(nineqn+kk)=1 - else - iw(nobb+ninq)=kk - istore(kk)=1 - endif - if(.not.feasb) goto 920 - call obj(nparam,kk,bu,f(kk)) - ncallf=ncallf+1 - if(nobL.ne.nob) fmxl=dmax1(fmxl,-f(kk)) - goto 930 - 920 call constr(nparam,indxob(kk),bu,f(kk)) - ncallg=ncallg+1 - 930 fmxl=dmax1(fmxl,f(kk)) - if(dabs(fmxl).gt.bigbnd) goto 1130 - 1000 continue - if(ncf.eq.0) goto 1110 - do 1100 i=1,ncf - iw(ninq+neq+i)=iact(i+nn) - istore(nineqn+iact(i+nn))=1 - fmxl=dmax1(fmxl,f(iact(i+nn))) - if(nobL.ne.nob) fmxl=dmax1(fmxl,-f(iact(i+nn))) - if(dabs(fmxl).gt.bigbnd) goto 1130 - 1100 continue - 1110 call matrvc(nparam,nparam,nparam,nparam,hess,di,cvec) - vv=-dmin1(0.01d0*dnm,dnm**2.5) -c -c compute a correction dtilde to d=(1-rho)d0+rho*d1 -c - if(nobL.ne.nob) nobbL=2*nobb - if(nobL.eq.nob) nobbL=nobb - if(nobbL.eq.1) goto 1115 - nqprm0=nparam+1 - nclin0=ninq+neq+nobbL - goto 1117 - 1115 nqprm0=nparam - nclin0=ninq+neq - 1117 nctot0=nqprm0+nclin0 - nrowa0=max0(nclin0,1) - i=ninq+neq - call dqp(nparam,nqprm0,nobb,nobbL,nncn,neq,neqn,nn,i,nclin0, - * nctot0,nrowa0,infoqp,iw,leniw,x,di,xl,xu,feasb,f,fmxl, - * gradf,grdpsf,g,gradg,a,cvec,bl,bu,clamda,cllamd,bj, - * hess,hess1,d,w,lenw,vv,1) - if(infoqp.ne.0) goto 1130 - dnmtil=dsqrt(scaprd(nparam,d,d)) - if(dnmtil.gt.dnm) goto 1130 - if(dnmtil.eq.0.d0) goto 1119 - do 1118 i=1,nineqn+nob - 1118 istore(i)=0 - 1119 if(iprint.lt.3.or.ipyes.gt.0) goto 9000 - call sbout1(io,nparam,'dtilde ',dummy,d,2,2) - call sbout1(io,0,'dtnorm ',dnmtil,adummy,1,2) - goto 9000 -c - 1130 do 1200 i=1,nparam - 1200 d(i)=0.d0 - dnmtil=0.d0 - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/dqp.f +++ /dev/null @@ -1,126 +0,0 @@ -c - subroutine dqp(nparam,nqpram,nob,nobL,nineqn,neq,neqn,nn,ncnstr, - * nclin,nctotl,nrowa,infoqp,iw,leniw,x0,di,xl,xu, - * feasb,f,fM,gradf,grdpsf,g,gradg,a,cvec,bl,bu, - * clamda,cllamd,bj,hess,hess1,x,w,lenw,vv,job) -c implicit double precision(a-h,o-z) - integer nparam,nqpram,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nclin, - * nctotl,nrowa,infoqp,leniw,lenw,job - integer iw(leniw) - double precision fM,vv - double precision x0(nparam),di(1),xl(nparam),xu(nparam), - * f(1),gradf(nparam,1),grdpsf(nparam),g(1), - * gradg(nparam,1), - * a(nrowa,1),cvec(1),bl(1),bu(1),clamda(1), - * cllamd(1),bj(1),hess(nparam,nparam), - * hess1(nparam+1,nparam+1),x(1),w(lenw) -c double precision x0(nparam),di(nqpram),xl(nparam),xu(nparam), -c * f(nob),gradf(nparam,nob),grdpsf(nparam),g(ncnstr), -c * gradg(nparam,ncnstr), -c * a(nrowa,nqpram),cvec(nqpram),bl(nctotl),bu(nctotl), -c * clamda(nctotl+nqpram),cllamd(nctotl),bj(nrowa), -c * hess(nparam,nparam),hess1(nparam+1,nparam+1), -c * x(nqpram),w(lenw) - logical feasb -c - integer io,idum1,idum2,idum3,idum4,idum5,idum6,idum7 - double precision bigbnd,dummy,epsmac,rteps,dummy1,dummy2 - common /fsqpp2/io,idum1,idum2,idum3,idum4,idum5,idum6,idum7, - * /fsqpp3/epsmac,rteps,dummy1,dummy2, - * /fsqpq1/bigbnd,dummy -c -c bj(1) is equivalent to bl(nparam+3) -c -c job=0 : compute d0; job=1 : compute d~ -c - integer i,ii,j,iout,mnn,nqnp - double precision x0i,xdi -c - iout=io - do 100 i=1,nparam - x0i=x0(i) - if(job.eq.1) xdi=di(i) - if(job.eq.0) xdi=0.d0 - bl(i)=xl(i)-x0i-xdi - bu(i)=xu(i)-x0i-xdi - cvec(i)=cvec(i)-grdpsf(i) - 100 continue - if(nobL.eq.1) goto 110 - bl(nqpram)=-bigbnd - bu(nqpram)=bigbnd - 110 ii=ncnstr-nn -c -c constraints are assigned to a in reverse order -c - do 300 i=1,ncnstr - x0i=vv - if(i.le.(neq-neqn).or.(i.gt.neq.and.i.le.(ncnstr-nineqn))) - * x0i=0.d0 - if(.not.feasb) x0i=0.d0 - bj(i)=x0i-g(iw(ncnstr+1-i)) - do 200 j=1,nparam - 200 a(i,j)=-gradg(j,iw(ncnstr+1-i)) - if(nobL.gt.1) a(i,nqpram)=0.d0 - 300 continue - if(nobL.eq.1) goto 510 - do 500 i=1,nob - ii=ncnstr+i - bj(ii)=fM-f(iw(ii)) - if(nobL.gt.nob) bj(ii+nob)=fM+f(iw(ii)) - do 400 j=1,nparam - a(ii,j)=-gradf(j,iw(ii)) - if(nobL.gt.nob) a(ii+nob,j)=gradf(j,iw(ii)) - 400 continue - a(ii,nqpram)=1.d0 - if(nobL.gt.nob) a(ii+nob,nqpram)=1.d0 - 500 continue - cvec(nqpram)=1.d0 - goto 610 - 510 do 600 i=1,nparam - 600 cvec(i)=cvec(i)+gradf(i,1) - 610 call matrcp(nparam,hess,nparam+1,hess1) - call nullvc(nqpram,x) -c -Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -C -c The following modification is done inside QP0001 -c for the ease of interfacing with QPSOL -c -c if(hess1(nqpram,nqpram).lt.qleps) hess1(nqpram,nqpram)=qleps -C - iw(1)=1 - mnn=nclin+2*nqpram - call QL0001(nclin,neq-neqn,nrowa,nqpram,nparam+1,mnn,hess1,cvec,A, - * bj,bL,bU,X,clamda,iout,infoqp,0,w,lenw,iw,leniw) -C -Ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -C - if(infoqp.ne.0.or.job.eq.1) goto 9000 - do 700 i=1,nqpram - ii=nclin+i - if(clamda(ii).eq.0.d0.and.clamda(ii+nqpram).eq.0.d0) then - goto 700 - else if(clamda(ii).ne.0.d0) then - clamda(ii)=-clamda(ii) - else - clamda(ii)=clamda(ii+nqpram) - endif - 700 continue - nqnp=nqpram+ncnstr - do 800 i=1,nctotl - if(i.le.nqpram) then - ii=nclin+i - else if(i.gt.nqpram.and.i.le.nqnp) then - ii=nqnp+1-i - else if(i.gt.nqnp) then - ii=i-nqpram - endif - cllamd(i)=clamda(ii) - 800 continue - if(nobL.eq.nob) goto 9000 - do 900 i=1,nob - ii=i+nqpram+ncnstr - cllamd(ii)=cllamd(ii)-cllamd(ii+nob) - 900 continue - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/error.f +++ /dev/null @@ -1,11 +0,0 @@ -c - subroutine error(string,inform,io) -c implicit real*8 (a-h,o-z) - integer inform,io - character*40 string -c - write(io,9900) string - 9900 format(1x,a40) - inform=7 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/estlam.f +++ /dev/null @@ -1,31 +0,0 @@ -c - subroutine estlam(nparam,neq,ifail,iout,bigbnd,hess,cvec,a,b, - * gradh,psb,bl,bu,x,w,lenw,iw,leniw) - integer nparam,neq,ifail,iout,lenw,leniw,iw(leniw) - double precision bigbnd,hess(neq,1),cvec(1),a(1),b(1), - * gradh(nparam,1),psb(1),bl(1),bu(1), - * x(1),w(lenw) -c double precision bigbnd,hess(neq,neq),cvec(neq),a(1),b(1), -c * gradh(nparam,neq),psb(nparam),bl(1),bu(1), -c * x(neq),w(lenw) -c -c compute an estimate of multipliers for updating penalty parameter -c - integer i,j - double precision scaprd -c - do 200 i=1,neq - bl(i)=-bigbnd - bu(i)=bigbnd - cvec(i)=scaprd(nparam,gradh(1,i),psb) - x(i)=0.d0 - do 100 j=i,neq - hess(i,j)=scaprd(nparam,gradh(1,i),gradh(1,j)) - 100 hess(j,i)=hess(i,j) - 200 continue - iw(1)=1 - call ql0001(0,0,1,neq,neq,2*neq,hess,cvec,a,b,bl,bu,x,w, - c iout,ifail,0,w(2),lenw-1,iw,leniw) -c - return - end
deleted file mode 100644 --- a/libcruft/fsqp/fool.f +++ /dev/null @@ -1,7 +0,0 @@ -c - subroutine fool(x,y,z) - double precision x,y,z -c - z=x*y+y - return - end
deleted file mode 100644 --- a/libcruft/fsqp/fsqpd.f +++ /dev/null @@ -1,703 +0,0 @@ -c THIS SOFTWARE MAY NOT BE COPIED TO MACHINES OUTSIDE THE SITE FOR -c WHICH IT HAD BEEN PROVIDED. SEE "Conditions for External Use" -c BELOW FOR MORE DETAILS. INDIVIDUALS INTERESTED IN OBTAINING -c THE SOFTWARE SHOULD CONTACT THE AUTHORS. -c - subroutine FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epseqn,udelta,bl,bu,x, - * f,g,iw,iwsize,w,nwsize,obj,constr,gradob,gradcn) -c -c implicit real*8(a-h,o-z) - integer nparam,nf,neqn,nineqn,nineq,neq,mode,iprint,miter,inform, - * iwsize,nwsize - integer iw(iwsize) - double precision bl(nparam),bu(nparam),x(nparam), - * f(1),g(1),w(nwsize) -c double precision bl(nparam),bu(nparam),x(nparam), -c * f(nf),g(nineq+neq),w(nwsize) - double precision bigbnd,eps,epseqn,udelta - external obj,constr,gradob,gradcn -c -c**********************************************************************c -c c -c brief specification of various arrays and parameters in the calling c -c sequence. See manual for more detailed description. c -c c -c nparam : number of variables c -c nf : number of objective functions c -c nineqn : number of nonlinear inequality constraints c -c nineq : number of inequality constraints c -c neqn : number of nonlinear equality constraints c -c neq : number of equality constraints c -c mode : mode=CBA specifies job options as described below: c -c A = 0 : ordinary minimax problems c -c = 1 : ordinary minimax problems with each individual c -c function replaced by its absolute value, ie, c -c an L_infty problem c -c B = 0 : monotone decrease of objective function c -c after each iteration c -c = 1 : monotone decrease of objective function after c -c at most four iterations c -c C = 1 : during line search, the function that rejected c -c the previous step size is checked first; c -c all functions of the same type ("objective" or c -c "constraints") as the latter will then be checked c -c first c -c C = 2 : all contraints will be checked first at every trial c -c point during the line search c -c iprint : print level indicator with the following options c -c iprint=0: no normal output except error information c -c (this option is imposed during phase 1) c -c iprint=1: a final printout at a local solution c -c iprint=2: a brief printout at the end of each iteration c -c iprint=3: detailed infomation is printed out at the end c -c of each iteration for debugging purpose c -c iprint=10*N+M: N any positive integer, M=2 or 3. c -c Information corresponding to iprint=M will be c -c displayed at every 10*Nth iterations at the last c -c iteration c -c miter : maximum number of iterations allowed by the user to solve c -c the problem c -c inform : status report at the end of execution c -c inform= 0:normal termination c -c inform= 1:no feasible point found for linear constraints c -c inform= 2:no feasible point found for nonlinear constraints c -c inform= 3:no solution has been found within miter iterations -c inform= 4:stepsize is smaller than machine precision before c -c a successful new iterate is found c -c inform= 5:failure of the QP solver in attempting to c -c construct d0. A more robust QP solver may succeed.c -c inform= 6:failure of the QP solver in attempting to c -c construct d1. A more robust QP solver may succeed.c -c inform= 7:inconsistent input data c -c bigbnd : plus infinity c -c eps : stopping criterion that ensures at a solution, the norm of c -c the Newton direction vector is smaller than eps c -c epseqn : tolerance of the violation of nonlinear equality constraintsc -c allowed by the user at an optimal solution c -c udelta : perturbation size in computing gradients by finite c -c difference and the true perturbation is determined by c -c sign(x_i) X max{udelta, rteps X max{1, |x_i|}} for each c -c component of x, where rteps is the square root of machine c -c precision -c bl : array of dimension nparam,containing lower bound of x c -c bu : array of dimension nparam,containing upper bound of x c -c x : array of dimension nparam,containing initial guess in input c -c and final iterate at the end of execution c -c f : array of dimension max{1,nf}, containing objective values c -c at x in output c -c g : array of dimension max{1,nineq+neq}, containing constraint c -c values at x in output c -c iw : integer working space of dimension iwsize c -c iwsize : length of integer array iw c -c w : double precision working space of dimension nwsize. c -c at output, it contains lagrange multipliers c -c nwsize : length of double precision array w c -c obj : subroutine that returns the value of objective functions c -c one upon each call c -c constr : subroutine that returns the value of constraints c -c one upon each call c -c gradob : subroutine that computes gradients of f, alternatively c -c it can be replaced by grobfd that computes finite c -c difference approximations c -c gradcn : subroutine that computes gradients of g, alternatively c -c it can be replaced by grcnfd that computes finite c -c difference approximations c -c c -cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc -c c -c c -c FSQP Version 3.3 c -c c -c Jian L. Zhou and Andre L. Tits c -c Institute for Systems Research c -c and c -c Electrical Engineering Department c -c University of Maryland c -c College Park, Md 20742 c -c c -c April, 1993 c -c c -c c -c The purpose of FSQP is to solve general nonlinear constrained c -c minimax optimization problems of the form c -c c -c (A=0 in mode) minimize max_i f_i(x) for i=1,...,n_f c -c or c -c (A=1 in mode) minimize max_j |f_i(x)| for i=1,...,n_f c -c s.t. bl <= x <= bu c -c g_j(x) <= 0, for j=1,...,nineqn c -c A_1 x - B_1 <= 0 c -c c -c h_i(x) = 0, for i=1,...,neqn c -c A_2 x - B_2 = 0 c -c c -c c -c c -c Conditions for External Use c -c =========================== c -c c -c 1. The FSQP routines may not be distributed to third parties. c -c Interested parties should contact the authors directly. c -c 2. If modifications are performaed on the routines, these c -c modifications will remain the sole property of the authors. c -c 3. Due acknowledgment must be made of the use of the FSQP routines c -c in research reports or publications. A copy of such reports or c -c publications should be forwarded to the authors. c -c 4. The FSQP routines may not be used in industrial production, c -c unless this has been agreed upon with the authors in writing. c -c c -c Copyright (c) 1989 --- 1993 by Jian L. Zhou and Andre L. Tits. c -c All Rights Reserved. c -c c -c c -c Enquiries should be directed to: c -c c -c Prof. Andre L. Tits c -c Electrical Engineering Dept. c -c and Institute for Systems Research c -c University of Maryland c -c College Park, Md 20742 c -c U. S. A. c -c c -c Phone : 301-405-3669 c -c Fax : 301-405-6707 c -c E-mail: andre@eng.umd.edu c -c c -c c -c Enhancements in successive versions of FSQP c -c =========================================== c -c c -c Version 3.3 : April 1993 c -c 1. If the user so requests (via "mode"), during the line search, c -c FSQP will now evaluate objectives only after having c -c determined that all constraints are satisfied. This is of c -c value when some objective functions are not defined outside c -c the feasible set. c -c 2. The reserved common block "fsqpst" is no longer used by FSQP. c -c Instead, a new reserved common block "fsqpus" is provided to c -c give the users a choice of several possible stopping criteria.c -c (As a side-effect, the user is not allowed any more to have c -c his/her own block data; see Section 4 of the manual for c -c details.) c -c 3. Some imperfections are fixed (e.g., comparision of double c -c precision number to hard zero, and incorrect checking of c -c value of "mode"). c -c c -c Version 3.2 : March 1993 c -c 1. The user is given the option to print output at every Nth c -c iteration and at the end, where N is a multiple of 10. c -c c -c Version 3.1a : January 1993 c -c 1. Bugs are fixed. This has to do with finding a feasible point c -c (with the help of Yaguang Yang). There should be no effect c -c if the user's problem does not contain both nonlinear and c -c linear equality constraints. c -c c -c Version 3.1 : November 1992 c -c 1. Possible division by zero is avoided. c -c 2. Objective and constraint values values at initial feasible c -c point is printed out if iprint >=1. c -c 3. Estimates of Lagrange multipliers are made available on outputc -c even when execution is terminated abnormally in phase 2. c -c 4. Incorrect descriptions of nineq, neq, iwsize and nwsize in thec -c user's manual and in the comments in fsqpd.f are corrected. c -c c -c Version 3.0d : October 1992 c -c 1. Some imperfections (identified by WATFOR) are cleaned up. c -c 2. Erroneous declaration of dummy argument in sampl*.f's c -c are corrected. c -c c -c Version 3.0c : September 1992 c -c 1. A bug in identifying active set of objectives fixed. c -c (Thanks go to Yaguang Yang.) c -c 2. Some imperfections (identified by WATFOR) are cleaned up. c -c (Thanks go to Jaroslav Dolezal and Jiri Fidler c -c at CZ Academy of Sciences.) c -c c -c Version 3.0b : August 1992 c -c 1. A bug in assigning iskip(*) is fixed. This has to do with c -c finding a feasible point. c -c 2. Other bugs associated with nonlinear equality constraints c -c are fixed. The effect is on nonmonotone line search. c -c (Thanks go to Yaguang Yang at Institute for Systems Research c -c the University of Maryland at College Park.) c -c c -c c -c Version 3.0a : June 1992 c -c 1. A bug in check.f is fixed and a typo is corrected. c -c 2. A bug in initpt.f is fixed. c -c 3. Printout message is adjusted for various situations. c -c 4. Computation of initial equality constraint violation is c -c corrected. (Thanks go to Jaroslav Dolezal and Jiri Fidler c -c at CZ Academy of Sciences) c -c 5. An output error for function values is corrected. c -c c -c Version 3.0 : June 1992 c -c 1. FSQP now also handles nonlinear equality constraints. c -c "Semi-feasibility" for these constraints is maintained in c -c the following sense: given a scalar constraint h(x)=0, c -c if h(x0)<=0 (resp. >=0), then h(xk)<=0 (resp. >=0) for all k. c -c 2. An option is added to allow users to have their own stopping c -c criterion. c -c 3. The interface for QPSOL is no longer part of the standard c -c distribution (but it is still available on request). c -c 4. Objective and constraints now must be provided in Fortran c -c "subroutines" rather than "functions". c -c 5. Concerning the default stopping criterion, the norm c -c requirement on the Kuhn-Tucker vector is replaced by a norm c -c requirement on Newton direction. c -c 6. The meaning of "mode" is redefined to encompass several c -c attributes. c -c 7. The argument list to call FSQPD is modified. c -c 8. The Hessian matrix is reset to the identity whenever c -c the line search fails to complete after a specified number c -c of step reductions, provided the last reset occurred at least c -c 5*nparam iterations earlier (it used to be 1*nparam). c -c c -c Version 2.4b : November 1991 c -c 1. Bugs are fixed that affected the computation of a feasible c -c point and the initialization of iskp. (Thanks go to c -c Klaus Schittkowski at U Bayreuth and John Hauser at USC.) c -c c -c Version 2.4a : November 1991 c -c 1. A bug is fixed that affected the multipliers given on output. c -c 2. A few unused statements are commented out. c -c 3. small() is modified to avoid too small a number on machines c -c that use extra-length registers for internal computations c -c (with the help of Roque Donizete de Oliveira at Michigan). c -c c -c Version 2.4 : October 1991 c -c 1. The Hessian matrix is reset to the identity whenever c -c the line search fails to complete after a specified number c -c of step reductions, provided the last reset occurred at least c -c nparam iterations earlier. c -c c -c Version 2.3b : September 1991 c -c 1. A bug is fixed in the reordering of active functions. c -c c -c Version 2.3a : September 1991 c -c 1. A bug is fixed in the reordering of active functions. c -c c -c Version 2.3 : July 1991 c -c 1. Lagrange multipliers at the solution point are provided on c -c output. c -c 2. Bugs are fixed and code is adapted to be accepted by c -c some "tough" compilers (with the help of K. Schittkowski). c -c c -c Version 2.2 : June 1991 c -c 1. In computing d~, only the most "active" constraints and c -c objectives are taken into account, thus reducing the c -c number of function evaluations. c -c 2. Refinements of nonmonotone line search are implemented c -c for minimax problems without nonlinear constraints. c -c 3. Line search is more efficient. c -c 4. A bug is fixed in the computation of d~ in mode=1*. c -c 5. The calling sequences of gradcn and gradob are simplified. c -c c -c Version 2.1 : April 1991 c -c 1. FSQP can use either of two quadratic programming codes: c -c QPSOL or QLD. c -c 2. Reorder constraints and objectives to enable more efficient c -c line search. c -c c -c Version 2.0B : March 1991: Bugs are fixed c -c Version 2.0A : October 1990: Bugs are fixed c -c Version 2.0 : August 1990 c -c 1. Extension to the solution of constrained minimax problems. c -c c -c Version 1.0B : June 1990: Bugs are fixed c -c Version 1.0A : December 1989: Bugs are fixed c -c Version 1.0 : August 1989 c -c c -c References: c -c [1] E. Panier and A. Tits, `On Combining Feasibility, Descent and c -c Superlinear Convergence In Inequality Constrained Optimization',c -c Mathematical Programming 59(1993), 261-276. c -c [2] J. F. Bonnans, E. Panier, A. Tits and J. Zhou, `Avoiding the c -c Maratos Effect by Means of a Nonmonotone Line search: II. c -c Inequality Problems - Feasible Iterates', SIAM J. Numer. Anal. c -c 29(1992), 1187-1202. c -c [3] J.L. Zhou and A. Tits, `Nonmonotone Line Search for Minimax c -c Problems', J. Optim. Theory Appl.76(1993), 455-476. c -c [4] J.L. Zhou and A. Tits, `User's Guide for FSQP Version 3.3: c -c A Fortran Code for Solving Optimization Programs, Possibly c -c Minimax,with General Inequality Constraints and Linear Equality c -c Constraints, Generating Feasible Iterates', Institute for c -c Systems Research, University of Maryland,Technical Report c -c SRC-TR-92-107r3, College Park, MD 20742, 1993. c -c [5] D.Q. Mayne and E. Polak, `Feasible Directions Algorithms for c -c Optimization Problems with Equality and Inequality Constraints',c -c Mathematical Programming 11(1976) c -c c -cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc -c - integer i,io,ipp,iter,j,ncallg,ncallf,ncnstr,nclin,nctotl,leniw, - * lenw,nwx,nwbl,nwbu,nwgrg,nwgpf,nwpenp,nwa,nwcvec,nwhess, - * nwcla,nww,nrowa,modd,nppram,iwnob,iwncn,iwia,iwisp,iwist, - * iwiw,nwdi,nwd,nwff,nwgrf,nwclla,nwhes1,nwsp,nwbak,nwsg,M, - * maxit,nob,nobL,nnineq,info,idummy,nshift,max0,modem,lstype, - * nstop,initvl,nn,nnn,nwgm,ipsp,ipspan,ipyes,iprnto,mod - double precision epsmac,QLeps,small,xi,gi,gmax,dummy,big,tolfea, - * rteps,epskt,upert,valnom,dsqrt,dmax1 - logical feasbl,feasb,prnt,nspace,Linfty,nAD - common /fsqpp1/nnineq,M,ncallg,ncallf,modd,lstype,nstop, - * /fsqpp2/io,ipp,ipsp,ipyes,info,idummy,iter,initvl, - * /fsqpp3/epsmac,rteps,upert,valnom - * /fsqpq1/big,tolfea,/fsqpq2/maxit - common /CMACHE/QLeps -c -c compute the machine precision -c - io=6 -c iwiw=6*nparam+8*max0(1,nineq+neq)+7*max0(nf,1)+30 -c i=nineq+neq+1 -c nww=4*nparam**2+5*i*nparam+3*(nf+1)*nparam+26*(nparam+nf+1) -c * +45*i+100 -c if(iwsize.ge.iwiw.and.nwsize.ge.nww) goto 10 -c if(iwsize.lt.iwiw) write(io,9906) iwiw -c if(nwsize.lt.nww) write(io,9907) nww -c info=7 -c goto 9000 -c - 10 iter=0 - nstop=1 - nn=nineqn+neqn - epsmac=small() - QLeps=epsmac - tolfea=epsmac*1.d+02 - big=bigbnd - rteps=dsqrt(epsmac) - upert=udelta -c - i=mod(iprint,10) - ipspan=max0(iprint-i,1) - iprnto=iprint - if(iprint.ge.10) iprint=i - if(iprint.lt.2) ipspan=1 - if(ipspan.lt.10) ipyes=0 - nob=0 - gmax=-bigbnd - info=0 - ipsp=ipspan - ipp=iprint - ncnstr=nineq+neq - nnineq=nineq -c -c check input data -c - if(iprint.gt.0) write(io,9900) - call check(nparam,nf,Linfty,nAD,nineq,nineqn,neq,neqn, - * mode,modem,nwa,eps,bigbnd,bl,bu) - if(info.eq.7) goto 9000 - lstype=nwa -c - maxit=max0(max0(miter,10*max0(nparam,ncnstr)),1000) - feasbl=.true. - feasb=.true. - prnt=.false. - nspace=.false. - nppram=nparam+1 - nshift=nparam**2+nppram**2 -c -c check whether x is within bounds -c - do 100 i=1,nparam - xi=x(i) - if(bl(i).le.xi.and.bu(i).ge.xi) goto 100 - feasbl=.false. - goto 110 - 100 continue - 110 nclin=ncnstr-nn -c -c check whether linear constraints are feasible -c - if(nclin.eq.0) goto 210 - do 200 i=1,nclin - j=i+nineqn - if(j.le.nineq) then - call constr(nparam,j,x,gi) - if(gi.le.epsmac) goto120 - feasbl=.false. - else if(j.gt.nineq) then - call constr(nparam,j+neqn,x,gi) - if(dabs(gi).le.epsmac) goto 120 - feasbl=.false. - endif - 120 g(j)=gi - 200 continue - 210 if(feasbl) goto 240 - if(iprint.le.0) goto 230 - write(io,9901) - call sbout1(io,nparam,'x ',dummy,x,2,1) - prnt=.true. - 230 nctotl=nparam+nclin - leniw=max0(2*nparam+2*nctotl+3,2*nclin+2*nparam+6) - if(leniw.le.iwsize)then - leniw=iwsize - else - write(io,9906) leniw - info=7 - nspace=.true. - endif - nwx=1 - nwbl=nwx+nparam - nwbu=nwbl+nctotl+4 - nwgrg=nwbu+nctotl+2 - nwa=nwgrg+nclin*nparam+1 - nwcvec=nwa+nparam*nclin+1 - nwhess=nwcvec+nparam - nwcla=nwhess+nparam*nparam - nww=nwcla+nctotl+nparam - lenw=2*nparam**2+10*nparam+2*nctotl+1 - if((nww+lenw).le.nwsize) then - lenw=nwsize-nww - if(.not.nspace) goto 235 - write(io,9909) - goto 9000 - else - write (io,9907) nww+lenw - write(io,9909) - info=7 - goto 9000 - endif -c -c attempt to generate a point satisfying all linear constraints -c - 235 nrowa=max0(nclin,1) - call initpt(nparam,nineqn,neq,neqn,nclin,nctotl,nrowa,x,bl,bu, - * iw,leniw,w(nwx),w(nwbl),w(nwbu),g(nineqn+1),w(nwgrg), - * w(nwa),w(nwcvec),w(nwhess),w(nwcla),w(nwbl+nparam+3), - * w(nww),lenw,constr,gradcn) - if(info.ne.0) goto 9000 - 240 do 245 i=1, neq-neqn - 245 g(nineq+neqn+i)=g(nineq+i) - if(nn.ne.0) goto 510 - goto 605 -c - 290 do 300 i=1,nob - 300 w(i+nineqn+nshift)=w(i+nshift) - nob=0 -c - 510 continue - if(info.eq.-1) goto 540 - do 520 i=1,nineqn - call constr(nparam,i,x,w(i+nineqn+nshift)) - if(w(i+nineqn+nshift).gt.0.d0) feasb=.false. - 520 continue - ncallg=nineqn - if(feasb) goto 540 -c -c set indxob(i) in phase 1 -c - do 530 i=1,nineqn - nob=nob+1 - iw(nob)=i - w(nob+nshift)=w(i+nineqn+nshift) - gmax=dmax1(gmax,w(nob+nshift)) - 530 continue - goto 580 - 540 do 550 i=1,nineqn - g(i)=w(i+nineqn+nshift) - iw(nineqn+i+1)=i - 550 continue - do 560 i=1,neq-neqn - g(i+nineq+neqn)=g(i+nineq) - 560 continue - do 570 i=1,neqn - j=i+nineq - call constr(nparam,j,x,g(j)) - iw(nineqn+nineqn+i+1)=j - 570 continue - ncallg=ncallg+neqn - 580 continue -c - 605 if(iprint.le.0.or..not.feasb.or.prnt) goto 610 - write(io,9902) - call sbout1(io,nparam,'x ',dummy,x,2,1) - prnt=.true. - 610 if(nob.ne.0) goto 620 - if(iprint.le.0) goto 615 - if(info.eq.0) goto 613 - write(io,9904) ncallg - if(ipp.eq.0) write(io,9910) iter - if(ipp.gt.0) write(io,9910) iter-1 - if(ipp.eq.0) iter=iter+1 - 613 if(.not.feasb.or.feasbl) goto 614 - write(io,9903) - call sbout1(io,nparam,'x ',dummy,x,2,1) - 614 if(info.eq.0.and.prnt.and.feasb) goto 615 - write(io,9903) - call sbout1(io,nparam,'x ',dummy,x,2,1) - 615 feasb=.true. - feasbl=.true. - 620 nspace=.false. - if(ipp.le.0.or.feasb.or.prnt) goto 630 - write(io,9901) - call sbout1(io,nparam,'x ',dummy,x,2,1) - prnt=.true. - 630 if(nob.eq.0) nob=1 -c -c set indxcn(1)--indxcn(ncnstr) -c - if(feasb) nnn=nn - if(.not.feasb) nnn=0 - do 700 i=1,nnn - 700 iw(nob+i)=iw(nineqn+i+1) - 710 do 800 i=1,nineq-nineqn - 800 iw(nob+nnn+i)=nineqn+i - do 805 i=1,neq-neqn - if(feasb) iw(nob+nineq+neqn+i)=nineq+neqn+i - if(.not.feasb) iw(nineq+i)=nineq+neqn+i - 805 continue - if(.not.feasb) goto 810 - nob=nf - info=0 - ipp=iprint - ipsp=ipspan - modd=modem - epskt=eps - if(Linfty) nobL=2*nob - if(.not.Linfty) nobL=nob - if(nob.ne.0) goto 910 - write(io,9908) - goto 9000 - 810 ipp=0 - ipsp=1 - modd=0 - nobL=nob - info=-1 - epskt=1.d-10 - 910 nctotl=nppram+ncnstr+nobL - iwnob=1 - if(feasb) iwncn=iwnob+1 - if(.not.feasb) iwncn=iwnob+nob - iwia=iwncn+ncnstr - iwisp=iwia+nn+nob - iwist=iwisp+nnineq-nineqn+1 - iwiw=iwist+nn+nob - leniw=2*(ncnstr+nobL)+2*nppram+6 -c - if((iwiw+leniw).le.iwsize) then - leniw=iwsize-iwiw - else - write (io,9906) iwiw+leniw - info=7 - nspace=.true. - endif - M=4 - if(modem.eq.1.and.nn.eq.0) M=3 - nwhess=1 - nwhes1=nwhess+nparam**2 - nwff=nwhes1+nppram**2 - nwx=nwff+nob+1 - nwdi=nwx+nppram - nwd=nwdi+nppram - nwgm=nwd+nppram - nwgrg=nwgm+max0(1,4*neqn) - nwgrf=nwgrg+ncnstr*nparam+1 - nwgpf=nwgrf+nparam*nob+1 - nwpenp=nwgpf+nparam - nwa=nwpenp+neqn+1 - nwbl=nwa+(ncnstr+nobL)*(nppram+1) - nwbu=nwbl+nctotl+4 - nwcla=nwbu+nctotl+2 - nwclla=nwcla+nctotl+nppram - nwcvec=nwclla+nctotl - nwsp=nwcvec+nppram - nwbak=nwsp+M+1 - nwsg=nwbak+nob+ncnstr+1 - nww=nwsg+neqn+1 - lenw=2*nppram*nppram+10*nppram+6*(ncnstr+nobL+1) -c - if((nww+lenw).le.nwsize) then - lenw=nwsize-nww - if(.not.nspace) goto 920 - write(io,9909) - goto 9000 - else - write (io,9907) nww+lenw - write(io,9909) - info=7 - goto 9000 - endif -c - 920 do 1000 i=nwx,nwx+nparam-1 - 1000 w(i)=x(i-nwx+1) - w(nwx+nparam)=gmax - if(.not.feasb) goto 1150 - do 1100 i=1,neqn - if(g(i+nineq).gt.0d0) w(nwsg+i-1)=-1.d0 - if(g(i+nineq).le.0d0) w(nwsg+i-1)=1.d0 - 1100 continue -c -c either attempt to generate a point satisfying all constraints -c or try to solve the original problem -c - 1150 nrowa=max0(ncnstr+nobL,1) - call FSQPD1(miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr,nctotl, - * nrowa,feasb,epskt,epseqn,bl,bu,iw(iwnob),iw(iwncn), - * iw(iwia),iw(iwisp),iw(iwist),iw(iwiw),leniw,w(nwx), - * w(nwdi),w(nwd),g,w(nwgm),w(nwgrg),w(nwff),w(nwgrf), - * w(nwgpf),w(nwpenp),w(nwa),w(nwbl),w(nwbu),w(nwcla), - * w(nwclla),w(nwcvec),w(nwbl+nparam+3),w(nwhess), - * w(nwhes1),w(nwsp),w(nwbak),w(nwsg),w(nww),lenw, - * obj,constr,gradob,gradcn) - do 1200 i=1,nparam - 1200 x(i)=w(nwx+i-1) - if(info.eq.-1) goto 290 - if(info.eq.0.or.feasb) goto 1220 - info=2 - write(io,9905) - goto 9000 - 1220 do 1300 i=1,nf - 1300 f(i)=w(nwff+i-1) - if(nobL.eq.1) idummy=0 - if(nobL.gt.1) idummy=1 - if(nf.eq.1) nob=0 - do 1400 i=1,nparam+ncnstr+nob - j=i - if(i.gt.nparam.and.i.le.(nparam+ncnstr)) - * j=nparam+iw(iwncn+i-nparam) - if(i.le.nparam) then - w(i)=w(nwclla+j-1) - else if(i.gt.nparam) then - if(i.le.(nparam+ncnstr)) j=nparam+iw(iwncn+i-1-nparam) - w(i)=w(nwclla+j-1+idummy) - endif - 1400 continue -c - 9000 inform=info - iprint=iprnto - return - 9900 format(1x,// 1x,' FSQP Version 3.3 (Released April 1993)' - * / 1x,' Copyright (c) 1989 --- 1993 ' - * / 1x,' J.L. Zhou and A.L. Tits ' - * / 1x,' All Rights Reserved ',//) - 9901 format(1x,'The given initial point is infeasible for inequality', - * /10x,'constraints and linear equality constraints:') - - 9902 format(1x,'The given initial point is feasible for inequality', - * /8x,'constraints and linear equality constraints:') - 9903 format(1x,'Starting from the generated point feasible for', - * ' inequality', - * /10x,'constraints and linear equality constraints:') - 9904 format(1x,'To generate a point feasible for nonlinear inequality', - * /1x,'constraints and linear equality constraints,', - * ' ncallg = ',i10) - 9905 format(1x,'Error: No feasible point is found for nonlinear', - * ' inequality', - * /8x,'constraints and linear equality constraints'/) - 9906 format(1x,'iwsize should be bigger than', i20) - 9907 format(1x,'nwsize should be bigger than', i20) - 9908 format(1x,'current feasible iterate with no objective specified'/) - 9909 format(1x,/) - 9910 format(43x,'iteration = ',i10) - end -c - block data - double precision objeps,objrep,gLgeps - common /fsqpus/objeps,objrep,gLgeps -c - data objeps,objrep,gLgeps/-1.d0,-1.d0,-1.d0/ - end
deleted file mode 100644 --- a/libcruft/fsqp/fsqpd1.f +++ /dev/null @@ -1,185 +0,0 @@ - subroutine FSQPD1(miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr, - * nctotl,nrowa,feasb,epskt,epseqn,xl,xu,indxob, - * indxcn,iact,iskip,istore,iw,leniw,x,di,d,g,gm, - * gradg,f,gradf,grdpsf,penp,a,bl,bu,clamda, - * cllamd,cvec,bj,hess,hess1,span,backup,signeq, - * w,lenw,obj,constr,gradob,gradcn) -c -c FSQP Version 3.3 : main routine for the optimization -c -c implicit real*8(a-h,o-z) - integer miter,nparam,nob,nobL,nineqn,neq,neqn,ncnstr,nctotl,nrowa, - * leniw,lenw - integer indxob(1),indxcn(1),iact(1),iskip(1), - * istore(1),iw(leniw) -c integer indxob(nob),indxcn(ncnstr),iact(nob+nineqn+neqn),iskip(1), -c * istore(nineqn+nob+neqn),iw(leniw) - double precision epskt,epseqn - double precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1), - * d(nparam+1),g(1),gm(1),gradg(nparam,1), - * f(1),gradf(nparam,1),grdpsf(nparam),penp(1), - * a(nrowa,1),bl(1),bu(1),clamda(1), - * cllamd(1),cvec(nparam+1),bj(1), - * hess(nparam,nparam),hess1(1),span(1), - * backup(1),signeq(1),w(lenw) -c double precision xl(nparam),xu(nparam),x(nparam+1),di(nparam+1), -c * d(nparam+1),g(ncnstr),gm(4*neqn),gradg(nparam,ncnstr), -c * f(nob),gradf(nparam,nob),grdpsf(nparam),penp(neqn), -c * a(nrowa,1),bl(nctotl),bu(nctotl),clamda(nctotl+nparam+1), -c * cllamd(nctotl),cvec(nparam+1),bj(nrowa), -c * hess(nparam,nparam),hess1(nparam+1,nparam+1),span(1), -c * backup(nob+ncnstr),signeq(neqn),w(lenw) - external obj,constr,gradob,gradcn - logical feasb -c - integer nnineq,M,ncallg,ncallf,mode,io,iprint,info,ipd,iter,nstop, - * initvl,ipspan,ipyes,lstype - double precision bigbnd,tolfea,epsmac,rteps,udelta,valnom - logical dlfeas,local,update,first - common /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop, - * /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl, - * /fsqpp3/epsmac,rteps,udelta,valnom, - * /fsqpq1/bigbnd,tolfea, -c * /fsqp1/rentry, - * /fsqplo/dlfeas,local,update,first -c -c bj(1+) is equivalent to bl(nparam+3+) -c - integer i,iskp,nfs,ncf,ncg,nn,non,nstart,nrst,ncnst1,nctot1 - double precision Cbar,Ck,dbar,fM,fMp,steps,d0nm,dummy, - * sktnom,scvneq,grdftd,dmax1,psf -c - initvl=1 - first=.true. - nrst=0 - ipd=0 - if(iter.eq.0) call diagnl(nparam,1.d0,hess) - if(.not.feasb) goto 5 - first=.true. - if(iter.gt.0) iter=iter-1 - if(iter.ne.0) call diagnl(nparam,1.d0,hess) - 5 Cbar=1.d-02 - Ck=Cbar - dbar=5.0d0 - nstart=1 - ncallf=0 - nstop=1 - nfs=0 - non=miter - if(mode.eq.0) goto 10 - nfs=M - non=0 - 10 if(feasb) then - nn=nineqn+neqn - ncnst1=ncnstr - nctot1=nctotl - else - nn=0 - ncnst1=ncnstr-nineqn-neqn - nctot1=nnineq-nineqn+neq-neqn+nparam - if(nob.gt.1) nctot1=nctot1+1 - endif - scvneq=0.d0 - do 100 i=1,ncnst1 - valnom=g(indxcn(i)) - backup(i)=valnom - if(feasb.and.i.gt.nineqn.and.i.le.nn) then - gm(i-nineqn)=valnom*signeq(i-nineqn) - scvneq=scvneq+dabs(valnom) - endif - if(.not.feasb.or.i.gt.nn) goto 20 - iact(i)=indxcn(i) - istore(i)=0 - if(i.gt.nineqn) penp(i-nineqn)=10.d0 - 20 call gradcn(nparam,indxcn(i),x,gradg(1,indxcn(i)),constr) - 100 continue - call nullvc(nparam,grdpsf) - psf=0.d0 - if(.not.feasb.or.neqn.eq.0) goto 110 - call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1), - * gradg(1,nnineq+1),signeq,12,12) - 110 fM=-bigbnd - do 140 i=1,nob - if(.not.feasb) goto 120 - iact(nn+i)=i - istore(nn+i)=0 - call obj(nparam,i,x,f(i)) - valnom=f(i) - backup(i+ncnst1)=valnom - call gradob(nparam,i,x,gradf(1,i),obj) - ncallf=ncallf+1 - if(nobL.ne.nob) fM=dmax1(fM,-f(i)) - goto 130 - 120 valnom=f(i) - iact(i)=i - istore(i)=0 - call gradcn(nparam,indxob(i),x,gradf(1,i),constr) - 130 fM=dmax1(fM,f(i)) - 140 continue - fMp=fM-psf - span(1)=fM -c - if(iprint.lt.3.or..not.first.or.ipyes.gt.0) goto 600 - do 300 i=1,nob - if(.not.feasb) goto 250 - if(nob.gt.1) - * call sbout2(io,nparam,i,'gradf(j,',')',gradf(1,i)) - if(nob.eq.1) - * call sbout1(io,nparam,'gradf(j) ', - * dummy,gradf(1,1),2,2) - goto 300 - 250 call sbout2(io,nparam,indxob(i),'gradg(j,',')',gradf(1,i)) - 300 continue - 310 if(ncnstr.eq.0) goto 410 - do 400 i=1,ncnst1 - 400 call sbout2(io,nparam,i,'gradg(j,',')',gradg(1,i)) - if(neqn.eq.0) goto 410 - call sbout1(io,nparam,'grdpsf(j) ',dummy,grdpsf,2,2) - call sbout1(io,neqn,'P ',dummy,penp,2,2) - 410 do 500 i=1,nparam - 500 call sbout2(io,nparam,i,'hess (j,',')',hess(1,i)) -c -c main loop of the algorithm -c - 600 nstop=1 - 601 continue - call out(miter,nparam,nob,nineqn,nn,neqn,ncnst1,x,g, - * f,fM,psf,steps,sktnom,d0nm,feasb) - if(nstop.ne.0) goto 810 - if(.not.feasb) goto 801 - do 700 i=1,ncnst1 - 700 g(i)=backup(i) - do 800 i=1,nob - 800 f(i)=backup(i+ncnst1) - 801 return - 810 continue - if(ipspan.ge.10.and.iprint.ge.2.and.ipyes.eq.0) - * write(io,9900) iter - call dir(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,nctot1,nrowa, - * feasb,steps,epskt,epseqn,sktnom,scvneq,Ck,d0nm,grdftd, - * xl,xu,indxob,indxcn,iact,iskp,iskip,istore,iw,leniw, - * x,di,d,g,gradg,f,fM,fMp,psf,gradf,grdpsf,penp,a, - * bl,bu,clamda,cllamd,cvec,bj,hess,hess1,w,lenw, - * backup,signeq,obj,constr) - if(nstop.eq.0) goto 601 - first=.false. - if(update) goto 820 - call step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,ncg,ncf, - * indxob,indxcn,iact,iskp,iskip,istore,feasb,grdftd, - * f,fM,fMp,psf,penp,steps,scvneq,bu,x,di,d,g,w, - * backup,signeq,obj,constr) - if(nstop.eq.0) goto 601 - 820 call hesian(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnst1,nctot1, - * nfs,nstart,feasb,bigbnd,bu,x,f,fM,fMp,psf, - * gradf,grdpsf,penp,g,gm,gradg,indxob,indxcn,cllamd, - * bl,clamda,di,hess,d,steps,nrst,signeq,span, - * obj,constr,gradob,gradcn, - * hess1,cvec,bj,w,lenw,iw,leniw) - if(nstop.eq.0) goto 601 - if(mode.eq.0) goto 601 - if(d0nm.gt.dbar) Ck=dmax1(dble(0.5*Ck),Cbar) - if(d0nm.le.dbar.and.dlfeas) Ck=Ck - if(d0nm.le.dbar.and..not.dlfeas) Ck=10.0*Ck - goto 601 - 9900 format(1x,9hiteration,t22,i22) - end
deleted file mode 100644 --- a/libcruft/fsqp/grcnfd.f +++ /dev/null @@ -1,40 +0,0 @@ -c - subroutine grcnfd(nparam,j,x,gradg,constr) -c -c FSQP Version 3.3 : computation of gradients of constraint -c functions by forward finite differences -c -c implicit real*8(a-h,o-z) - integer nparam,j - double precision x(nparam),gradg(nparam) - external constr -c - integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2 - double precision epsmac,rteps,udelta,gj - common /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2, - * /fsqpp3/epsmac,rteps,udelta,gj -c -c estimate the gradient of the ith constraint -c by forward finite differences -c - integer i - double precision xi,delta,dmax1 -c - do 10 i=1,nparam - xi=x(i) - delta=dmax1(udelta,rteps*dmax1(1.d0,dabs(xi))) - if (xi.lt.0.d0) delta=-delta - if (j.ne.1.or.iprint.lt.3) goto 9 - if (ipspan.ge.10.and.ipyes.gt.0) goto 9 - if(i.eq.1) write(io,1001) delta - if(i.ne.1) write(io,1002) delta - ipd=1 - 9 x(i)=xi+delta - call constr(nparam,j,x,gradg(i)) - gradg(i)=(gradg(i)-gj)/delta - x(i)=xi - 10 continue - return - 1001 format(1x,t17,8hdelta(i),t45,e22.14) - 1002 format(1x,t45,e22.14) - end
deleted file mode 100644 --- a/libcruft/fsqp/grobfd.f +++ /dev/null @@ -1,37 +0,0 @@ - subroutine grobfd(nparam,j,x,gradf,obj) -c -c FSQP Version 3.3 : computation of gradients of objective -c functions by forward finite differences -c -c implicit real*8(a-h,o-z) - integer nparam,j - double precision x(nparam),gradf(nparam) - external obj -c - integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2 - double precision epsmac,rteps,udelta,fj - common /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2, - * /fsqpp3/epsmac,rteps,udelta,fj -c -c estimates the gradient of the objective function -c by forward finite differences -c - integer i - double precision xi,delta,dmax1 -c - do 10 i=1,nparam - xi=x(i) - delta=dmax1(udelta,rteps*dmax1(1.d0,dabs(xi))) - if (xi.lt.0.d0) delta=-delta - if (ipd.eq.1.or.j.ne.1.or.iprint.lt.3.or.ipyes.gt.0) goto 9 - if(i.eq.1) write(io,1001) delta - if(i.ne.1) write(io,1002) delta - 9 x(i)=xi+delta - call obj(nparam,j,x,gradf(i)) - gradf(i)=(gradf(i)-fj)/delta - x(i)=xi - 10 continue - return - 1001 format(1x,t17,8hdelta(i),t45,e22.14) - 1002 format(1x,t45,e22.14) - end
deleted file mode 100644 --- a/libcruft/fsqp/hesian.f +++ /dev/null @@ -1,194 +0,0 @@ - subroutine hesian(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr, - * nctotl,nfs,nstart,feasb,bigbnd,xnew,x,f, - * fM,fMp,psf,gradf,grdpsf,penp,g,gm,gradg,indxob, - * indxcn,cllamd,delta,eta,gamma,hess,hd,steps, - * nrst,signeq,span,obj,constr,gradob,gradcn, - * phess,psb,psmu,w,lenw,iw,leniw) -c -c FSQP Version 3.3 : updating the Hessian matrix using BFGS -c formula with Powell's modification -c -c implicit real*8(a-h,o-z) - integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,nctotl,nfs, - * nstart,indxob(1),indxcn(1),nrst,lenw,leniw,iw(leniw) -c * nstart,indxob(nob),indxcn(1),nrst,lenw,leniw,iw(leniw) - double precision bigbnd,steps,psf,fM,fMp, - * xnew(nparam),x(nparam),f(1),gradf(nparam,1), - * grdpsf(nparam),penp(1),g(1),gm(1), - * gradg(nparam,1),cllamd(1),delta(nparam), - * eta(nparam),gamma(nparam),hess(nparam,nparam),hd(nparam), - * signeq(1),span(1),phess(1),psb(1),psmu(1),w(lenw) -c double precision bigbnd,steps,psf,fM,fMp, -c * xnew(nparam),x(nparam),f(nob),gradf(nparam,nob), -c * grdpsf(nparam),penp(neqn),g(ncnstr),gm(4*neqn), -c * gradg(nparam,ncnstr),cllamd(nctotl),delta(nparam), -c * eta(nparam),gamma(nparam),hess(nparam,nparam),hd(nparam), -c * signeq(neqn),span(1),phess(neq,neq),psb(neq), -c * psmu(neq),w(lenw) - external obj,constr,gradob,gradcn - logical feasb -c - integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info, - * ipd,iter,nstop,initvl,lstype - double precision epsmac,rteps,udelta,valnom,objeps,objrep,gLgeps - common /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop, - * /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,iter,initvl, - * /fsqpp3/epsmac,rteps,udelta,valnom, - * /fsqpus/objeps,objrep,gLgeps -c - integer ng,i,j,ifail,indexs,np,mnm,iout - double precision dhd,gammd,etad,scaprd,dummy,theta,signgj,psfnew - logical done -c - if(feasb.and.nstop.ne.0.and.neqn.eq.0) then -c -c check of gLgeps is just after computing d0! -c - if(dabs(w(1)-fM).le.objeps) then - nstop=0 - else if(dabs(1.d0-fM/w(1)).le.objrep) then - nstop=0 - endif - endif - if(nstop.eq.0) goto 810 -c - ipd=0 - done=.false. - psfnew=0.d0 - call nullvc(nparam,delta) - call nullvc(nparam,eta) - if(nobL.gt.1) ng=2 - if(nobL.eq.1) ng=1 -c - 100 continue - call nullvc(nparam,gamma) - if(nobL.gt.1) call matrvc(nparam,nob,nparam,nob,gradf, - * cllamd(nparam+ng+ncnstr),hd) - if(.not.feasb) goto 120 - if(nineqn.eq.0) goto 110 - call matrvc(nparam,nineqn,nparam,nineqn,gradg,cllamd(nparam+ng), - * gamma) - 110 if(neqn.eq.0) goto 120 - call matrvc(nparam,neqn,nparam,neqn,gradg(1,nnineq+1), - * cllamd(nparam+nnineq+ng),eta) - 120 do 200 i=1,nparam - if(nobL.gt.1) then - if(done) psb(i)=hd(i)+cllamd(i)+gamma(i) - gamma(i)=gamma(i)+hd(i)-grdpsf(i)+eta(i) - else if(nobL.eq.1) then - if(done) psb(i)=gradf(i,1)+cllamd(i)+gamma(i) - gamma(i)=gamma(i)+gradf(i,1)-grdpsf(i)+eta(i) - endif - if(.not.done) delta(i)=gamma(i) - 200 continue - if(done) goto 410 - if(nn.eq.0) goto 310 - do 300 i=1,nn - if(feasb.and.i.gt.nineqn) signgj=signeq(i-nineqn) - if(.not.feasb.or.i.le.nineqn) signgj=1.d0 - valnom=g(indxcn(i))*signgj - call gradcn(nparam,indxcn(i),xnew,gradg(1,indxcn(i)),constr) - 300 continue - call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1), - * gradg(1,nnineq+1),signeq,11,11) - 310 do 400 i=1,nob - valnom=f(i) - if(feasb) call gradob(nparam,i,xnew,gradf(1,i),obj) - if(.not.feasb) - * call gradcn(nparam,indxob(i),xnew,gradf(1,i),constr) - 400 continue - done=.true. - goto 100 -c - 410 if(nrst.lt.(5*nparam).or.steps.gt.0.1d0) goto 420 - nrst=0 - call diagnl(nparam,1.d0,hess) - goto 810 - 420 nrst=nrst+1 - do 500 i=1,nparam - gamma(i)=gamma(i)-delta(i) - delta(i)=xnew(i)-x(i) - 500 continue - call matrvc(nparam,nparam,nparam,nparam,hess,delta,hd) - dhd=scaprd(nparam,delta,hd) - gammd=scaprd(nparam,delta,gamma) - if(gammd.ge.0.2d0*dhd) theta=1.d0 - if(gammd.lt.0.2d0*dhd) theta=.8d0*dhd/(dhd-gammd) - do 600 i=1,nparam - 600 eta(i)=hd(i)*(1.d0-theta)+theta*gamma(i) - etad=theta*gammd+(1.d0-theta)*dhd - do 800 i=1,nparam - do 700 j=i,nparam - hess(i,j)=hess(i,j)-hd(i)*hd(j)/dhd+eta(i)*eta(j)/etad - 700 hess(j,i)=hess(i,j) - 800 continue - 810 do 900 i=1,nparam - 900 x(i)=xnew(i) - if(nstop.eq.0) goto 9000 - if(neqn.eq.0.or..not.feasb) goto 1400 - iout=io - i=nnineq-nineqn - if(i.eq.0) goto 990 - call matrvc(nparam,i,nparam,i,gradg(1,nineqn+1), - * cllamd(nparam+ng+nineqn),gamma) - do 950 i=1,nparam - 950 psb(i)=psb(i)+gamma(i) - 990 call estlam(nparam,neq,ifail,iout,bigbnd,phess,delta,eta,gamma, - * gradg(1,nnineq+1),psb,hd,xnew,psmu,w,lenw,iw,leniw) - do 1000 i=1,neqn - if(ifail.ne.0) then - penp(i)=2.d0*penp(i) - else if(ifail.eq.0) then - etad=psmu(i)+penp(i) - if(etad.ge.1.d0) goto 1000 - penp(i)=dmax1(1.0d0-psmu(i),5.0d0*penp(i)) - endif - 1000 continue - call resign(nparam,neqn,psf,grdpsf,penp,g(nnineq+1), - * gradg(1,nnineq+1),signeq,20,12) - fMp=fM-psf - 1400 if(nfs.eq.0) goto 1430 - nstart=nstart+1 - np=indexs(nstart,nfs) - span(np)=fM - do 1410 i=1,neqn - 1410 gm((np-1)*neqn+i)=g(nnineq+i) - if(neqn.ne.0) call resign(nparam,neqn,psfnew,grdpsf,penp, - * gm(1),gradg,signeq,20,10) - fM=span(1) - fMp=span(1)-psfnew - mnm=min0(nstart,nfs) - do 1420 i=2,mnm - if(neqn.ne.0) call resign(nparam,neqn,psfnew,grdpsf,penp, - * gm((i-1)*neqn+1),gradg,signeq,20,10) - fM=dmax1(fM,span(i)) - fMp=dmax1(fMp,span(i)-psfnew) - 1420 continue - 1430 if(iprint.lt.3.or.ipyes.gt.0) goto 9000 - do 1700 i=1,nob - if(.not.feasb) goto 1600 - if(nob.gt.1) call sbout2(io,nparam,i,'gradf(j,',')', - * gradf(1,i)) - if(nob.eq.1) call sbout1(io,nparam,'gradf(j) ', - * dummy,gradf(1,i),2,2) - goto 1700 - 1600 call sbout2(io,nparam,indxob(i),'gradg(j,',')', - * gradf(1,i)) - 1700 continue - if(ncnstr.eq.0) goto 1900 - do 1800 i=1,ncnstr - 1800 call sbout2(io,nparam,i,'gradg(j,',')', - * gradg(1,i)) - if(neqn.eq.0) goto 1900 - call sbout1(io,nparam,'grdpsf(j) ',dummy,grdpsf,2,2) - call sbout1(io,neqn,'P ',dummy,penp,2,2) -c call sbout1(io,neqn,'psmu ',dummy,psmu,2,2) - 1900 call sbout1(io,nparam,'multipliers for x ',dummy,cllamd,2,2) - if(ncnstr.ne.0) call sbout1(io,ncnstr,' for g ', - * dummy,cllamd(nparam+ng),2,2) - if(nobL.gt.1) call sbout1(io,nob,' for f ', - * dummy,cllamd(nparam+ng+ncnstr),2,2) - do 2000 i=1,nparam - 2000 call sbout2(io,nparam,i,'hess (j,',')',hess(1,i)) - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/indexs.f +++ /dev/null @@ -1,14 +0,0 @@ -c - integer function indexs(i,nfs) -c implicit real*8(a-h,o-z) - integer i,nfs,mm -c -c find the residue of i with respect to nfs -c - mm=i - if(mm.le.nfs) goto 120 - 110 mm=mm-nfs - if(mm.gt.nfs) goto 110 - 120 indexs=mm - return - end
deleted file mode 100644 --- a/libcruft/fsqp/initpt.f +++ /dev/null @@ -1,74 +0,0 @@ - subroutine initpt(nparam,nnl,neq,neqn,nclin,nctotl,nrowa,x0, - * bndl,bndu,iw,leniw,x,bl,bu,g,gradg,a,cvec,hess, - * clamda,bj,w,lenw,constr,gradcn) -c -c FSQP Version 3.3 : generation of a feasible point satisfying -c simple bounds and linear constraints -c -c implicit real*8(a-h,o-z) - integer nparam,nnl,neq,neqn,nclin,nctotl,nrowa,leniw,lenw - integer iw(leniw) - double precision x0(nparam),bndl(nparam),bndu(nparam),x(nparam), - * bl(1),bu(1),g(1),gradg(nparam,1), - * a(nrowa,1),cvec(nparam),hess(nparam,nparam), - * clamda(1),bj(1),w(lenw) -c double precision x0(nparam),bndl(nparam),bndu(nparam),x(nparam), -c * bl(nctotl),bu(nctotl),g(nclin),gradg(nparam,nclin), -c * a(nrowa,nparam),cvec(nparam),hess(nparam,nparam), -c * clamda(nctotl+nparam),bj(nclin),w(lenw) - external constr,gradcn -c -c bj(1) is equivalent to bl(nparam+3) -c - integer io,iprint,ipspan,ipyes,info,ipd,idum,idum2,maxit, - * nnineq,id1,id2,id3,id4,id5,id6 - double precision epsmac,rteps,udelta,valnom,big,tolfea - common /fsqpp1/nnineq,id1,id2,id3,id4,id5,id6 - * /fsqpp2/io,iprint,ipspan,ipyes,info,ipd,idum,idum2, - * /fsqpp3/epsmac,rteps,udelta,valnom, - * /fsqpq1/big,tolfea,/fsqpq2/maxit -c - integer i,j,infoql,mnn - double precision x0i -c - info=1 - do 10 i=1,nclin - valnom=g(i) - j=i+nnl - if(j.le.nnineq) call gradcn(nparam,j,x0,gradg(1,i),constr) - if(j.gt.nnineq) - * call gradcn(nparam,j+neqn,x0,gradg(1,i),constr) - 10 continue - do 20 i=1,nparam - x0i=x0(i) - bl(i)=bndl(i)-x0i - bu(i)=bndu(i)-x0i - cvec(i)=0.d0 - 20 continue - do 30 i=nclin,1,-1 - 30 bj(nclin-i+1)=-g(i) - do 60 i=nclin,1,-1 - do 50 j=1,nparam - 50 a(nclin-i+1,j)=-gradg(j,i) - 60 continue - call diagnl(nparam,1.d0,hess) - call nullvc(nparam,x) -C - mnn=nrowa+2*nparam - iw(1)=1 - call QL0001(nclin,neq-neqn,nrowa,nparam,nparam,mnn,hess,cvec,A, - * bj,bL,bU,X,clamda,io,infoql,0,w,lenw,iw,leniw) - if(infoql.ne.0) goto 90 - do 70 i=1,nparam - 70 x0(i)=x0(i)+x(i) - do 80 i=1,nclin - j=i+nnl - if(j.le.nnineq) call constr(nparam,j,x0,g(i)) - if(j.gt.nnineq) call constr(nparam,j+neqn,x0,g(i)) - 80 continue - info=0 - 90 if(info.eq.1.and.iprint.ne.0) write(io,1000) - 1000 format(1x,'Error: No feasible point is found for the', - * ' linear constraints',/) - return - end
deleted file mode 100644 --- a/libcruft/fsqp/lfuscp.f +++ /dev/null @@ -1,9 +0,0 @@ -c - double precision function lfuscp(val,thrshd) -c implicit real*8(a-h,o-z) - double precision val,thrshd -c - if(dabs(val).le.thrshd) lfuscp=0 - if(dabs(val).gt.thrshd) lfuscp=1 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/macros.tex +++ /dev/null @@ -1,424 +0,0 @@ -\def\Resetstrings{ - \def\present{ }\let\bgroup={\let\egroup=}%primitive TeX - \def\Astr{}\def\astr{}\def\Atest{}\def\atest{}% - \def\Bstr{}\def\bstr{}\def\Btest{}\def\btest{}% - \def\Cstr{}\def\cstr{}\def\Ctest{}\def\ctest{}% - \def\Dstr{}\def\dstr{}\def\Dtest{}\def\dtest{}% - \def\Estr{}\def\estr{}\def\Etest{}\def\etest{}% - \def\Fstr{}\def\fstr{}\def\Ftest{}\def\ftest{}% - \def\Gstr{}\def\gstr{}\def\Gtest{}\def\gtest{}% - \def\Hstr{}\def\hstr{}\def\Htest{}\def\htest{}% - \def\Istr{}\def\istr{}\def\Itest{}\def\itest{}% - \def\Jstr{}\def\jstr{}\def\Jtest{}\def\jtest{}% - \def\Kstr{}\def\kstr{}\def\Ktest{}\def\ktest{}% - \def\Lstr{}\def\lstr{}\def\Ltest{}\def\ltest{}% - \def\Mstr{}\def\mstr{}\def\Mtest{}\def\mtest{}% - \def\Nstr{}\def\nstr{}\def\Ntest{}\def\ntest{}% - \def\Ostr{}\def\ostr{}\def\Otest{}\def\otest{}% - \def\Pstr{}\def\pstr{}\def\Ptest{}\def\ptest{}% - \def\Qstr{}\def\qstr{}\def\Qtest{}\def\qtest{}% - \def\Rstr{}\def\rstr{}\def\Rtest{}\def\rtest{}% - \def\Sstr{}\def\sstr{}\def\Stest{}\def\stest{}% - \def\Tstr{}\def\tstr{}\def\Ttest{}\def\ttest{}% - \def\Ustr{}\def\ustr{}\def\Utest{}\def\utest{}% - \def\Vstr{}\def\vstr{}\def\Vtest{}\def\vtest{}% - \def\Wstr{}\def\wstr{}\def\Wtest{}\def\wtest{}% - \def\Xstr{}\def\xstr{}\def\Xtest{}\def\xtest{}% - \def\Ystr{}\def\ystr{}\def\Ytest{}\def\ytest{}% -} -\Resetstrings\def\Ztest{}\def\ztest{} - -\def\Refformat{%Determines the kind of reference by the presence or - \if\Jtest\present - {\if\Vtest\present\journalarticleformat - \else\conferencereportformat\fi} - \else\if\Btest\present\bookarticleformat - \else\if\Rtest\present\technicalreportformat - \else\if\Itest\present\bookformat - \else\otherformat\fi\fi\fi\fi} - -\def\Rpunct{%Default punctuation control strings if the punctuation - \def\Lspace{ }% - \def\Lperiod{ }% . - \def\Lcomma{ }% , - \def\Lquest{ }% ? - \def\Lcolon{ }% : - \def\Lscolon{ }% ; - \def\Lbang{ }% ! - \def\Lquote{ }% ' - \def\Lqquote{ }% " - \def\Lrquote{ }% ` - \def\Rspace{}% - \def\Rperiod{.}% . - \def\Rcomma{,}% , - \def\Rquest{?}% ? - \def\Rcolon{:}% : - \def\Rscolon{;}% ; - \def\Rbang{!}% ! - \def\Rquote{'}% ' - \def\Rqquote{"}% " - \def\Rrquote{`}% ` - } - -\def\Lpunct{%Default punctuation control strings if the punctuation - \def\Lspace{}% - \def\Lperiod{\unskip.}% . - \def\Lcomma{\unskip,}% , - \def\Lquest{\unskip?}% ? - \def\Lcolon{\unskip:}% : - \def\Lscolon{\unskip;}% ; - \def\Lbang{\unskip!}% ! - \def\Lquote{\unskip'}% ' - \def\Lqquote{\unskip"}% " - \def\Lrquote{\unskip`}% ` - \def\Rspace{\spacefactor=1000}% - \def\Rperiod{\spacefactor=3000}% . - \def\Rcomma{\spacefactor=1250}% , - \def\Rquest{\spacefactor=3000}% ? - \def\Rcolon{\spacefactor=2000}% : - \def\Rscolon{\spacefactor=1250}% ; - \def\Rbang{\spacefactor=3000}% ! - \def\Rquote{\spacefactor=1000}% ' - \def\Rqquote{\spacefactor=1000}% " - \def\Rrquote{\spacefactor=1000}% ` - } - -\def\Refstd{ - \def\Acomma{\unskip, }%between multiple author names - \def\Aand{\unskip\ and }%between two author names - \def\Aandd{\unskip\ and }%between last two of multiple author names - \def\Ecomma{\unskip, }%between multiple editor names - \def\Eand{\unskip\ and }%between two editor names - \def\Eandd{\unskip\ and }%between last two of multiple author names - \def\acomma{\unskip, }%same for authors of reviewed material - \def\aand{\unskip\ and }%same for authors of reviewed material - \def\aandd{\unskip\ and }%same for authors of reviewed material - \def\ecomma{\unskip, }%same for translators - \def\eand{\unskip\ and }%same for translators - \def\eandd{\unskip\ and }%same for translators - \def\Namecomma{\unskip, }%same for citations using authors' names - \def\Nameand{\unskip\ and }%same for citations using authors' names - \def\Nameandd{\unskip\ and }%same for citations using authors' names - \def\Revcomma{\unskip, }%between last and first name of reversed name - \def\Initper{.\ }%punctuation after initial - \def\Initgap{\dimen0=\spaceskip\divide\dimen0 by 2\hskip-\dimen0}% - %gap between initials of abbreviated first name - } - -\def\Smallcapsaand{%Smallcaps redefinition of \Aand and \Aandd - for \Refstd - \def\Aand{\unskip\bgroup{\Smallcapsfont\ AND }\egroup}% - \def\Aandd{\unskip\bgroup{\Smallcapsfont\ AND }\egroup}% - \def\eand{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - \def\eandd{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - } - -\def\Smallcapseand{%Smallcaps redefinition of \Eand, - \Eeand, etc for Refstd - \def\Eand{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - \def\Eandd{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - \def\aand{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - \def\aandd{\unskip\bgroup\Smallcapsfont\ AND \egroup}% - } - -\def\Refstda{ - \chardef\Ampersand=`\&%primitive TeX - \def\Acomma{\unskip, }%between multiple author names - \def\Aand{\unskip\ \Ampersand\ }%between two author names - \def\Aandd{\unskip\ \Ampersand\ } - \def\Ecomma{\unskip, }%between multiple editor names - \def\Eand{\unskip\ \Ampersand\ }%between two editor names - \def\Eandd{\unskip\ \Ampersand\ } - \def\acomma{\unskip, }%same for authors of reviewed material - \def\aand{\unskip\ \Ampersand\ } - \def\aandd{\unskip\ \Ampersand\ } - \def\ecomma{\unskip, }%same for translators - \def\eand{\unskip\ \Ampersand\ }%same for translators - \def\eandd{\unskip\ \Ampersand\ }%same for translators - \def\Namecomma{\unskip, }%same for citations using authors' names - \def\Nameand{\unskip\ \Ampersand\ } - \def\Nameandd{\unskip\ \Ampersand\ } - \def\Revcomma{\unskip, } - \def\Initper{.\ }%punctuation after initial - \def\Initgap{\dimen0=\spaceskip\divide\dimen0 by 2\hskip-\dimen0}% - %gap between initials of abbreviated first name - } - - \def\Citefont{}%citations - \def\ACitefont{}%alternate citations - \def\Authfont{}%authors - \def\Titlefont{}%titles - \def\Tomefont{\sl}%journals or books - \def\Volfont{}%volume number of journal - \def\Flagfont{}%citation flag - \def\Reffont{\rm}%set at beginning of reference listing - \def\Smallcapsfont{\sevenrm}%small caps - \def\Flagstyle#1{\hangindent\parindent\indent\hbox to0pt%flag style - {\hss[{\Flagfont#1}]\kern.5em}\ignorespaces} - -\def\Underlinemark{\vrule height .7pt depth 0pt width 3pc}%for replacing - -\def\Citebrackets{\Rpunct%defaults for putting citations in brackets []. - \def\Lcitemark{\def\Cfont{\Citefont}[\bgroup\Cfont} - \def\Rcitemark{\egroup]}%mark at right of citation - \def\LAcitemark{\def\Cfont{\ACitefont}\bgroup\ACitefont}% - %mark at left of alternate citation - \def\RAcitemark{\egroup}%mark at right of alternate citation - \def\LIcitemark{\egroup}%mark at left of insertion in citation - \def\RIcitemark{\bgroup\Cfont}%mark at right of insertion in citation - \def\Citehyphen{\egroup--\bgroup\Cfont} - \def\Citecomma{\egroup,\hskip0pt\bgroup\Cfont}% - %separater for multiple citations - \def\Citebreak{} - } - -\def\Citeparen{\Rpunct%defaults for putting citations in parenthesis (). - \def\Lcitemark{\def\Cfont{\Citefont}(\bgroup\Cfont} - \def\Rcitemark{\egroup)}%mark at right of citation - \def\LAcitemark{\def\Cfont{\ACitefont}\bgroup\ACitefont}% - %mark at left of alternate citation - \def\RAcitemark{\egroup}%mark at right of alternate citation - \def\LIcitemark{\egroup}%mark at left of insertion in citation - \def\RIcitemark{\bgroup\Cfont}%mark at right of insertion in citation - \def\Citehyphen{\egroup--\bgroup\Cfont} - \def\Citecomma{\egroup,\hskip0pt\bgroup\Cfont}% - %separater for multiple citations - \def\Citebreak{} - } - -\def\Citesuper{\Lpunct%defaults for making superscript citations -\def\Lcitemark{\def\Cfont{\Citefont}\raise1ex\hbox\bgroup\bgroup\Cfont}% - %mark at left of citation - \def\Rcitemark{\egroup\egroup}%mark at right of citation - \def\LAcitemark{\def\Cfont{\ACitefont}\bgroup\ACitefont}% - %mark at left of alternate citation - \def\RAcitemark{\egroup}%mark at right of alternate citation - \def\LIcitemark{\egroup\egroup}%mark at left of insertion in citation - \def\RIcitemark{\raise1ex\hbox\bgroup\bgroup\Cfont}% - %mark at right of insertion in citation - \def\Citehyphen{\egroup--\bgroup\Cfont} - \def\Citecomma{\egroup,\hskip0pt\bgroup% - \Cfont}%separater for multiple citations - \def\Citebreak{} - } - -\def\Citenamedate{\Rpunct%defaults for making name-date citations - \def\Lcitemark{ - \def\Citebreak{\egroup\ [\bgroup\Citefont}%separater in citation - \def\Citecomma{\egroup]; %between multiple citations - \bgroup\let\uchyph=1\Citefont}(\bgroup\let\uchyph=1\Citefont}% - \def\Rcitemark{\egroup])}%mark at right of citation - \def\LAcitemark{%mark at left of alternate citation - \def\Citebreak{\egroup\ [\bgroup\Citefont}\def\Citecomma{\egroup], % - \bgroup\ACitefont }\bgroup\let\uchyph=1\ACitefont}% - \def\RAcitemark{\egroup]}%mark at right of alternate citation - \def\Citehyphen{\egroup--\bgroup\Citefont} - \def\LIcitemark{\egroup}%mark at left of insertion in citation - \def\RIcitemark{\bgroup\Citefont} - } - - -\def\Flagstyle#1{\hangindent\parindent -\indent\hbox to0pt{\hss[{\Flagfont#1}]\kern.5em}}%flag style - -\def\journalarticleformat{\Reffont\let\uchyph=1 -\parindent=1.25pc\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000\sfcode`\:=1000 - \sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% -\if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }\fi% - \if\Ttest\present\Comma - \bgroup``\Titlefont\Tstr\egroup\def\Comma{," }\fi% - \if\etest\present\if\Ttest\present{"}\fi\hskip.16667em( - \bgroup\estr\egroup)\def\Comma{\unskip, }\fi% - \if\Jtest\present\Comma\bgroup\Tomefont\Jstr\/\egroup - \def\Comma{, }\fi% - \if\Vtest\present\if\Jtest\present\hskip.16667em - \else\Comma\fi\bgroup\Volfont\Vstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\hskip.16667em(\bgroup\Dstr\egroup) - \def\Comma{, }\fi% - \if\Ptest\present\bgroup, \Pstr\egroup\def\Comma{, }\fi% - \if\ttest\present\Comma - \bgroup``\Titlefont\tstr\egroup\def\Comma{," }\fi% - \if\jtest\present\Comma\bgroup\Tomefont\jstr\/\egroup - \def\Comma{, }\fi% - \if\vtest\present\if\jtest\present\hskip.16667em\else - \Comma\fi\bgroup\Volfont\vstr\egroup\def\Comma{, }\fi% - \if\dtest\present\hskip.16667em(\bgroup\dstr\egroup) - \def\Comma{, }\fi% - \if\ptest\present\bgroup, \pstr\egroup\def\Comma{, }\fi% - \if\Gtest\present{\Comma Gov't ordering no. } - \bgroup\Gstr\egroup\def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.}\else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\def\conferencereportformat{\Reffont\let\uchyph=1 -\parindent=1.25pc\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000 - \sfcode`\:=1000\sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% - \if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }\fi% - \if\Ttest\present\Comma - \bgroup``\Titlefont\Tstr\egroup\def\Comma{," }\fi% -\if\Jtest\present\Comma\bgroup\Tomefont\Jstr\/\egroup\def\Comma{, }\fi% - \if\Ctest\present\Comma\bgroup\Cstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\hskip.16667em(\bgroup\Dstr\egroup) - \def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.}\else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\def\bookarticleformat{\Reffont\let\uchyph=1\parindent=1.25pc -\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000 - \sfcode`\:=1000\sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% - \if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }\fi% - \if\Ttest\present\Comma\bgroup``\Titlefont\Tstr - \egroup\def\Comma{," }\fi% - \if\etest\present\if\Ttest\present"\fi\hskip.16667em( - \bgroup\estr\egroup)\def\Comma{\unskip, }\fi% - \if\Btest\present\Comma in \bgroup\Tomefont\Bstr\/\egroup - \def\Comma{\unskip, }\fi% - \if\otest\present\ \bgroup\ostr\egroup\def\Comma{, }\fi% - \if\Etest\present\Comma\bgroup\Estr\egroup - \unskip, \ifnum\Ecnt>1eds.\else ed.\fi\def\Comma{, }\fi% - \if\Stest\present\Comma\bgroup\Sstr\egroup\def\Comma{, }\fi% - \if\Vtest\present\bgroup\hskip.16667em\#\Volfont\Vstr - \egroup\def\Comma{, }\fi% - \if\Ntest\present\bgroup\hskip.16667em\#\Volfont\Nstr - \egroup\def\Comma{, }\fi% - \if\Itest\present\Comma\bgroup\Istr\egroup\def\Comma{, }\fi% - \if\Ctest\present\Comma\bgroup\Cstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\Comma\bgroup\Dstr\egroup\def\Comma{, }\fi% - \if\Ptest\present\Comma\Pstr\def\Comma{, }\fi% - \if\ttest\present\Comma\bgroup``\Titlefont\Tstr - \egroup\def\Comma{," }\fi% - \if\btest\present\Comma in \bgroup\Tomefont\bstr - \egroup\def\Comma{, }\fi% - \if\atest\present\Comma\bgroup\astr\egroup\unskip, - \if\acnt\present eds.\else ed.\fi\def\Comma{, }\fi% - \if\stest\present\Comma\bgroup\sstr - \egroup\def\Comma{, }\fi% - \if\vtest\present\bgroup\hskip.16667em\#\Volfont - \vstr\egroup\def\Comma{, }\fi% - \if\ntest\present\bgroup\hskip.16667em\#\Volfont - \nstr\egroup\def\Comma{, }\fi% - \if\itest\present\Comma\bgroup\istr\egroup - \def\Comma{, }\fi% - \if\ctest\present\Comma\bgroup\cstr - \egroup\def\Comma{, }\fi% - \if\dtest\present\Comma\bgroup\dstr - \egroup\def\Comma{, }\fi% - \if\ptest\present\Comma\pstr\def\Comma{, }\fi% - \if\Gtest\present{\Comma Gov't ordering no. } - \bgroup\Gstr\egroup\def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.} - \else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\def\bookformat{\Reffont\let\uchyph=1\parindent=1.25pc\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000 - \sfcode`\:=1000\sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% - \if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }% - \else\if\Etest\present\bgroup\def\Eand{\Aand}\def\Eandd{\Aandd} -\Authfont\Estr\egroup\unskip, \ifnum\Ecnt>1eds.\else ed.\fi -\def\Comma{, }% - \else\if\Itest\present\bgroup\Authfont\Istr - \egroup\def\Comma{, }\fi\fi\fi% - \if\Ttest\present\Comma\bgroup\Tomefont\Tstr\/\egroup - \def\Comma{\unskip, }% - \else\if\Btest\present\Comma\bgroup\Tomefont\Bstr\/\egroup - \def\Comma{\unskip, }\fi\fi% - \if\otest\present\ \bgroup\ostr\egroup\def\Comma{, }\fi% - \if\etest\present\hskip.16667em(\bgroup\estr\egroup) - \def\Comma{\unskip, }\fi% - \if\Stest\present\Comma\bgroup\Sstr\egroup\def\Comma{, }\fi% - \if\Vtest\present\bgroup\hskip.16667em\#\Volfont\Vstr - \egroup\def\Comma{, }\fi% - \if\Ntest\present\bgroup\hskip.16667em\#\Volfont\Nstr - \egroup\def\Comma{, }\fi% - \if\Atest\present\if\Itest\present - \Comma\bgroup\Istr\egroup\def\Comma{\unskip, }\fi% - \else\if\Etest\present\if\Itest\present - \Comma\bgroup\Istr\egroup - \def\Comma{\unskip, }\fi\fi\fi% - \if\Ctest\present\Comma\bgroup\Cstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\Comma\bgroup\Dstr\egroup\def\Comma{, }\fi% - \if\ttest\present\Comma\bgroup\Tomefont\tstr\egroup\def\Comma{, }% - \else\if\btest\present\Comma\bgroup\Tomefont\bstr - \egroup\def\Comma{, }\fi\fi% - \if\stest\present\Comma\bgroup\sstr\egroup\def\Comma{, }\fi% -\if\vtest\present\bgroup\hskip.16667em\#\Volfont\vstr - \egroup\def\Comma{, }\fi% -\if\ntest\present\bgroup\hskip.16667em\#\Volfont -\nstr\egroup\def\Comma{, }\fi% - \if\itest\present\Comma\bgroup\istr\egroup\def\Comma{, }\fi% - \if\ctest\present\Comma\bgroup\cstr\egroup\def\Comma{, }\fi% - \if\dtest\present\Comma\bgroup\dstr\egroup\def\Comma{, }\fi% - \if\Gtest\present{\Comma Gov't ordering no. }\bgroup\Gstr - \egroup\def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.}\else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\def\technicalreportformat{\Reffont\let\uchyph=1 -\parindent=1.25pc\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000 - \sfcode`\:=1000\sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% - \if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }% - \else\if\Etest\present\bgroup\def\Eand{\Aand} - \def\Eandd{\Aandd}\Authfont\Estr\egroup\unskip, - \ifnum\Ecnt>1eds.\else ed.\fi\def\Comma{, }% - \else\if\Itest\present\bgroup\Authfont\Istr - \egroup\def\Comma{, }\fi\fi\fi% - \if\Ttest\present\Comma - \bgroup``\Titlefont\Tstr\egroup\def\Comma{," }\fi% - \if\Atest\present\if\Itest\present - \Comma\bgroup\Istr\egroup\def\Comma{, }\fi% - \else\if\Etest\present\if\Itest\present - \Comma\bgroup\Istr\egroup\def\Comma{, }\fi\fi\fi% - \if\Rtest\present\Comma\bgroup\Rstr\egroup\def\Comma{, }\fi% - \if\Ctest\present\Comma\bgroup\Cstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\Comma\bgroup\Dstr\egroup\def\Comma{, }\fi% - \if\ttest\present\Comma - \bgroup``\Titlefont\tstr\egroup\def\Comma{," }\fi% - \if\itest\present\Comma\bgroup\istr\egroup\def\Comma{, }\fi% - \if\rtest\present\Comma\bgroup\rstr\egroup\def\Comma{, }\fi% - \if\ctest\present\Comma\bgroup\cstr\egroup\def\Comma{, }\fi% - \if\dtest\present\Comma\bgroup\dstr\egroup\def\Comma{, }\fi% - \if\Gtest\present{\Comma Gov't ordering no. } - \bgroup\Gstr\egroup\def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.}\else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\def\otherformat{\Reffont\let\uchyph=1\parindent=1.25pc\def\Comma{}% - \sfcode`\.=1000\sfcode`\?=1000\sfcode`\!=1000 - \sfcode`\:=1000\sfcode`\;=1000\sfcode`\,=1000%\frenchspacing - \par\vfil\penalty-200\vfilneg%\filbreak - \if\Ftest\present\Flagstyle\Fstr\fi% - \if\Atest\present\bgroup\Authfont\Astr\egroup\def\Comma{\unskip, }% - \else\if\Etest\present\bgroup\def\Eand{\Aand} - \def\Eandd{\Aandd}\Authfont\Estr\egroup\unskip, - \ifnum\Ecnt>1eds.\else ed.\fi\def\Comma{, }% - \else\if\Itest\present\bgroup\Authfont\Istr - \egroup\def\Comma{, }\fi\fi\fi% - \if\Ttest\present\Comma - \bgroup``\Titlefont\Tstr\egroup\def\Comma{," }\fi% - \if\Atest\present\if\Itest\present - \Comma\bgroup\Istr\egroup\def\Comma{, }\fi% - \else\if\Etest\present\if\Itest\present - \Comma\bgroup\Istr\egroup\def\Comma{, }\fi\fi\fi% - \if\Ctest\present\Comma\bgroup\Cstr\egroup\def\Comma{, }\fi% - \if\Dtest\present\Comma\bgroup\Dstr\egroup\def\Comma{, }\fi% - \if\Gtest\present{\Comma Gov't ordering no. } - \bgroup\Gstr\egroup\def\Comma{, }\fi% - \if\Otest\present{\Comma\bgroup\Ostr\egroup.}\else{.}\fi% - \vskip3ptplus1ptminus1pt}%\smallskip - -\Refstda\Citebrackets
deleted file mode 100644 --- a/libcruft/fsqp/manua2.tex +++ /dev/null @@ -1,1316 +0,0 @@ -\section{Examples} -\label{example} -The first problem is borrowed -from\Lspace \Lcitemark 9\Rcitemark \Rspace{} (Problem 32). -It involves a single objective function, simple bounds on the variables, -nonlinear inequality constraints, -and linear equality constraints. -The objective function $f$ is defined for $x\in R^3$ by -\begin{quote} -\begin{quote} -$f(x)=(x_1+3x_2+x_3)^2+4(x_1-x_2)^2$ -\end{quote} -\end{quote} -The constraints are -\begin{quote} -\begin{quote} - $0 \leq x_i ,~~~~~~~~~~i = 1,\ldots,3$ \\ - $x_1^3-6x_2-4x_3+3 \leq 0\;\;\;\;\;\ - 1-x_1-x_2-x_3 = 0$ -\end{quote} -\end{quote} -The feasible initial guess is:~~~$x_0=(0.1,~0.7,~0.2)^T$ ~~with -corresponding value -of the objective function~~~ $f(x_0)=7.2$. -The final solution is:~~~$x^*=(0,~0,~1)^T$ ~~with ~~~$f(x^*)=1$. -A suitable main program is as follows. -\begin{quote} -\begin{verbatim} -c -c problem description -c - program sampl1 -c - integer iwsize,nwsize,nparam,nf,nineq,neq - parameter (iwsize=29, nwsize=219) - parameter (nparam=3, nf=1) - parameter (nineq=1, neq=1) - integer iw(iwsize) - double precision x(nparam),bl(nparam),bu(nparam), - * f(nf+1),g(nineq+neq+1),w(nwsize) - external obj32,cntr32,grob32,grcn32 -c - integer mode,iprint,miter,nineqn,neqn,inform - double precision bigbnd,eps,epseqn,udelta -c - mode=100 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.d-08 - epseqn=0.d0 - udelta=0.d0 -c -c nparam=3 -c nf=1 - nineqn=1 - neqn=0 -c nineq=1 -c neq=1 -c - bl(1)=0.d0 - bl(2)=0.d0 - bl(3)=0.d0 - bu(1)=bigbnd - bu(2)=bigbnd - bu(3)=bigbnd -c -c give the initial value of x -c - x(1)=0.1d0 - x(2)=0.7d0 - x(3)=0.2d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epseqn,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj32,cntr32,grob32,grcn32) - end -\end{verbatim} -\end{quote} -Following are the subroutines defining the objective and -constraints and their gradients. -\begin{quote} -\begin{verbatim} - subroutine obj32(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj -c - fj=(x(1)+3.d0*x(2)+x(3))**2+4.d0*(x(1)-x(2))**2 - return - end -c - subroutine grob32(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision x(nparam),gradfj(nparam),fa,fb - external dummy -c - fa=2.d0*(x(1)+3.d0*x(2)+x(3)) - fb=8.d0*(x(1)-x(2)) - gradfj(1)=fa+fb - gradfj(2)=fa*3.d0-fb - gradfj(3)=fa - return - end -c - subroutine cntr32(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj - external dummy -c - go to (10,20),j - 10 gj=x(1)**3-6.0d0*x(2)-4.0d0*x(3)+3.d0 - return - 20 gj=1.0d0-x(1)-x(2)-x(3) - return - end -c - subroutine grcn32(nparam,j,x,gradgj,dummy) - integer nparam,j - double precision x(nparam),gradgj(nparam) - external dummy -c - go to (10,20),j - 10 gradgj(1)=3.d0*x(1)**2 - gradgj(2)=-6.d0 - gradgj(3)=-4.d0 - return - 20 gradgj(1)=-1.d0 - gradgj(2)=-1.d0 - gradgj(3)=-1.d0 - return - end -\end{verbatim} -\end{quote} -The file containing the user-provided subroutines is -then compiled together with {\tt fsqpd.f} and {\tt qld.f}. -After running the algorithm on a SUN 4/SPARC station 1, the -following output is obtained: -\begin{verbatim} - - FSQP Version 3.2 (Released March 1993) - Copyright (c) 1989 --- 1993 - J.L. Zhou and A.L. Tits - All Rights Reserved - - - The given initial point is feasible for inequality - constraints and linear equality constraints: - x 0.10000000000000E+00 - 0.70000000000000E+00 - 0.20000000000000E+00 - objectives 0.72000000000000E+01 - constraints -0.19990000000000E+01 - 0.55511151231258E-16 - - - iteration 3 - x -0.98607613152626E-31 - 0.00000000000000E+00 - 0.10000000000000E+01 - objectives 0.10000000000000E+01 - constraints -0.10000000000000E+01 - 0.00000000000000E+00 - SCV 0.00000000000000E+00 - d0norm 0.13945222387368E-30 - ktnorm 0.10609826585190E-29 - ncallf 3 - ncallg 5 - - - inform 0 - Normal termination: You have obtained a solution !! -\end{verbatim} - -Our second example is taken from example 6 -in\Lspace \Lcitemark 10\Rcitemark \Rspace{}. The problem is as follows. -$$\begin{array}{cl} -\min\limits_{x\in R^6} & \max\limits_{i=1,\ldots,163} |f_i(x)| \\ -\mbox{s.t.} & -x(1)~~~~~~\,\!~~~~~~~~~~~~~~\; -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+s \leq 0 \\ - & ~\,\,\,\!x(1)-x(2)~~~~~~~~~~~~\; -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+s \leq 0 \\ - & ~~~~~~\,\!~~~~~\,x(2)-x(3)~~~~\;\, -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+s \leq 0 \\ - & ~~~~~~~\,\!~~~~~~~~~~~~~~x(3)-x(4) -~~~~~~~~~~~~~~~~~~~~~~~~\;~+s \leq 0 \\ - & ~~~~~~~~\,\!~~~~~~~~~~~~~~~~~~~~~~\,x(4)-x(5) -~~~~~~~~~~~~~~~\;\,+s \leq 0 \\ - & ~~~~~~~~~~~\,\!~~~~~~~~~~~~~~~~~~~~~~~~~~~~\,\,x(5)-x(6) -~~~\;~~~+s \leq 0 \\ - & ~~~~~~~~~~~~~~~\,\!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -~~~\,x(6)-3.5+s \leq 0; -\end{array}$$ -where -$$\begin{array}{l} -f_i(x)=\frac{1}{15}+\frac{2}{15}(\sum^6_{j=1} - \mbox{cos}(2\pi x_j\mbox{sin}\theta _i) - +\mbox{cos}(7\pi \mbox{sin}\theta _i)), \\ -\theta _i=\frac{\pi}{180}(8.5+0.5i),~i=1,\ldots,163,\\ -s=0.425. -\end{array}$$ -The feasible initial guess is:~$x_0=(0.5,1,1.5,2,2.5,3)^T$ with -the corresponding value of the objective -function $\max\limits_{i=1,\ldots,163} |f_i(x_0)|=0.22051991555531$. -A suitable main program is as follows. -\begin{quote} -\begin{verbatim} -c -c problem description -c - program sampl2 -c - integer iwsize,nwsize,nparam,nf,nineq,neq - parameter (iwsize=1029, nwsize=7693) - parameter (nparam=6, nf=163) - parameter (nineq=7, neq=0) - integer iw(iwsize) - double precision x(nparam),bl(nparam),bu(nparam), - * f(nf+1),g(nineq+neq+1),w(nwsize) - external objmad,cnmad,grobfd,grcnfd -c - integer mode,iprint,miter,nineqn,neqn,inform - double precision bigbnd,eps,udelta -c - mode=111 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.0d-08 - epseqn=0.d0 - udelta=0.d0 -c -c nparam=6 -c nf=163 - nineqn=0 - neqn=0 -c nineq=7 -c neq=0 -c - bl(1)=-bigbnd - bl(2)=-bigbnd - bl(3)=-bigbnd - bl(4)=-bigbnd - bl(5)=-bigbnd - bl(6)=-bigbnd - bu(1)=bigbnd - bu(2)=bigbnd - bu(3)=bigbnd - bu(4)=bigbnd - bu(5)=bigbnd - bu(6)=bigbnd -c -c give the initial value of x -c - x(1)=0.5d0 - x(2)=1.d0 - x(3)=1.5d0 - x(4)=2.d0 - x(5)=2.5d0 - x(6)=3.d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epseqn,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,objmad,cnmad,grobfd,grcnfd) - end - stop -\end{verbatim} -\end{quote} -We choose to compute the gradients of functions by means of -finite difference approximation. Thus only subroutines that -define the objectives and constraints are needed as follows. -\begin{quote} -\begin{verbatim} - subroutine objmad(nparam,j,x,fj) - integer nparam,j,i - double precision x(nparam),theta,pi,fj -c - pi=3.14159265358979d0 - theta=pi*(8.5d0+dble(j)*0.5d0)/180.d0 - fj=0.d0 - do 10 i=1,6 - 10 fj=fj+dcos(2.d0*pi*x(i)*dsin(theta)) - fj=2.d0*(fj+dcos(2.d0*pi*3.5d0*dsin(theta)))/15.d0 - * +1.d0/15.d0 - return - end -c - subroutine cnmad(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),ss,gj -c - ss=0.425d0 - goto(10,20,30,40,50,60,70),j - 10 gj=ss-x(1) - return - 20 gj=ss+x(1)-x(2) - return - 30 gj=ss+x(2)-x(3) - return - 40 gj=ss+x(3)-x(4) - return - 50 gj=ss+x(4)-x(5) - return - 60 gj=ss+x(5)-x(6) - return - 70 gj=ss+x(6)-3.5d0 - return - end -\end{verbatim} -\end{quote} -After running the algorithm on a SUN 4/SPARC station 1, -the following output -is obtained (the results for the set of objectives have been deleted to -save space) -\begin{verbatim} - - FSQP Version 3.2 (Released March 1993) - Copyright (c) 1989 --- 1993 - J.L. Zhou and A.L. Tits - All Rights Reserved - - - The given initial point is feasible for inequality - constraints and linear equality constraints: - 0.50000000000000E+00 - 0.10000000000000E+01 - 0.15000000000000E+01 - 0.20000000000000E+01 - 0.25000000000000E+01 - 0.30000000000000E+01 - objmax 0.22051986506559E+00 - constraints -0.75000000000000E-01 - -0.75000000000000E-01 - -0.75000000000000E-01 - -0.75000000000000E-01 - -0.75000000000000E-01 - -0.75000000000000E-01 - -0.75000000000000E-01 - - - iteration 7 - x 0.42500000000000E+00 - 0.85000000000000E+00 - 0.12750000000000E+01 - 0.17000000000000E+01 - 0.21840763196688E+01 - 0.28732755096448E+01 - objective max4 0.11421841325221E+00 - objmax 0.11310472749826E+00 - constraints 0.00000000000000E+00 - 0.00000000000000E+00 - 0.00000000000000E+00 - 0.00000000000000E+00 - -0.59076319668817E-01 - -0.26419918997596E+00 - -0.20172449035522E+00 - SCV 0.00000000000000E+00 - d0norm 0.15662162275640E-09 - ktnorm 0.20564110435030E-10 - ncallf 1141 - - - inform 0 - Normal termination: You have obtained a solution !! -\end{verbatim} - -Our third example is borrowed -from\Lspace \Lcitemark 9\Rcitemark \Rspace{} (Problem 71). It involves both -equality and inequality nonlinear constraints and is defined by -$$\begin{array}{cl} -\min\limits_{x\in R^4} & x_1x_4(x_1+x_2+x_3)+x_3\\ -\mbox{s.t.} & 1\leq x_i\leq 5,\quad i=1,\ldots,4\\ - & x_1x_2x_3x_4-25\geq 0\\ - & x_1^2+x_2^2+x_3^2+x_4^2-40=0. -\end{array}$$ -The feasible initial guess is: $x_0=(1,5,5,1)^T$ with the corresponding -value of the objective function $f(x_0)=16$. A suitable program -that invokes FSQP to solve this problem is given below. -\begin{quote} -\begin{verbatim} -c -c problem description -c - program sampl3 -c - integer iwsize,nwsize,nparam,nf,nineq,neq - parameter (iwsize=33, nwsize=284) - parameter (nparam=4, nf=1) - parameter (nineq=1, neq=1) - integer iw(iwsize) - double precision x(nparam),bl(nparam),bu(nparam),f(nf+1), - * g(nineq+neq+1),w(nwsize) - external obj,cntr,gradob,gradcn -c - integer mode,iprint,miter,neqn,nineqn,inform - double precision bigbnd,eps,epseqn,udelta -c - mode=100 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.0d-07 - epseqn=7.d-06 - udelta=0.d0 -c - neqn=1 - nineqn=1 -c - bl(1)=1.d0 - bl(2)=1.d0 - bl(3)=1.d0 - bl(4)=1.d0 - bu(1)=5.d0 - bu(2)=5.d0 - bu(3)=5.d0 - bu(4)=5.d0 -c -c give the initial value of x -c - x(1)=1.d0 - x(2)=5.d0 - x(3)=5.d0 - x(4)=1.d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epseqn,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj,cntr,gradob,gradcn) - end -\end{verbatim} -\end{quote} -Following are the subroutines that define the objective, constraints -and their gradients. -\begin{quote} -\begin{verbatim} - subroutine obj(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj -c - fj=x(1)*x(4)*(x(1)+x(2)+x(3))+x(3) - return - end -c - subroutine gradob(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision x(nparam),gradfj(nparam) - external dummy -c - gradfj(1)=x(4)*(x(1)+x(2)+x(3))+x(1)*x(4) - gradfj(2)=x(1)*x(4) - gradfj(3)=x(1)*x(4)+1.d0 - gradfj(4)=x(1)*(x(1)+x(2)+x(3)) - return - end -c - subroutine cntr(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj -c - goto (10,20),j - 10 gj=25.d0-x(1)*x(2)*x(3)*x(4) - return - 20 gj=x(1)**2+x(2)**2+x(3)**2+x(4)**2-40.d0 - return - end -c - subroutine gradcn(nparam,j,x,gradgj,dummy) - integer nparam,j - double precision x(nparam),gradgj(nparam) - external dummy -c - goto (10,20),j - 10 gradgj(1)=-x(2)*x(3)*x(4) - gradgj(2)=-x(1)*x(3)*x(4) - gradgj(3)=-x(1)*x(2)*x(4) - gradgj(4)=-x(1)*x(2)*x(3) - return - 20 gradgj(1)=2.d0*x(1) - gradgj(2)=2.d0*x(2) - gradgj(3)=2.d0*x(3) - gradgj(4)=2.d0*x(4) - return - end -\end{verbatim} -\end{quote} -After running the algorithm on a SUN 4/SPARC station 1, the following -output is obtained -\begin{verbatim} - - FSQP Version 3.2 (Released March 1993) - Copyright (c) 1989 --- 1993 - J.L. Zhou and A.L. Tits - All Rights Reserved - - - The given initial point is feasible for inequality - constraints and linear equality constraints: - x 0.10000000000000E+01 - 0.50000000000000E+01 - 0.50000000000000E+01 - 0.10000000000000E+01 - objectives 0.16000000000000E+02 - constraints 0.00000000000000E+00 - -0.12000000000000E+02 - - - iteration 8 - x 0.10000000000000E+01 - 0.47429996518112E+01 - 0.38211499651796E+01 - 0.13794082958030E+01 - objectives 0.17014017289158E+02 - constraints -0.35171865420125E-11 - -0.35100811146549E-11 - SCV 0.35100811146549E-11 - d0norm 0.23956399867788E-07 - ktnorm 0.34009891628142E-07 - ncallf 9 - ncallg 24 - - - inform 0 - Normal termination: You have obtained a solution !! -\end{verbatim} - -\section{Results for Test Problems} -\label{results} -\noindent These results are provided to allow the user to -compare FSQP with his/her favorite code (see -also\Lspace \Lcitemark 2\Citehyphen 4\Rcitemark \Rspace{}). -Table 1 contains results -obtained for some (non-minimax) test problems -from\Lspace \Lcitemark 9\Rcitemark \Rspace{} (the same initial points -as in\Lspace \Lcitemark 9\Rcitemark \Rspace{} were selected). -{\tt prob} indicates the problem number as in -\Lcitemark 9\Rcitemark \Rspace{}, {\tt nineqn} the number of nonlinear constrai -nts, -{\tt ncallf} the total number of evaluations of the objective function, -{\tt ncallg} the total number of evaluations of the (scalar) nonlinear -constraint functions, {\tt iter} the total number of iterations, -{\tt objective} the final value -of the objective, {\tt ktnorm} the norm of Kuhn-Tucker vector at the -final iterate, {\tt eps} the norm requirement of the Kuhn-Tucker vector, -{\tt SCV} the sum of feasibility violation of linear constraints (see -\S~\ref{stopcri}). On each test problem, {\tt eps} was selected -so as to achieve the same -field precision as in\Lspace \Lcitemark 9\Rcitemark \Rspace{}. -Whether FSQP-AL (0) or FSQP-NL (1) is used is indicated in column ``B''. - -Results obtained on selected minimax problems -are summarized in Table 2. -Problems {\tt bard}, {\tt davd2}, {\tt f\&r}, {\tt hettich}, -and {\tt wats} are -from\Lspace \Lcitemark 11\Rcitemark \Rspace{}; -{\tt cb2}, {\tt cb3}, {\tt r-s}, {\tt wong} and {\tt colv} are -from\Lspace \Lcitemark 12\LIcitemark{}; Examples 5.1-5\RIcitemark \Rcitemark \R -space{} -(the latest test results on problems {\tt bard} down to -{\tt wong} can be found in\Lspace \Lcitemark 13\Rcitemark \Rspace{}); -{\tt kiw1} and {\tt kiw4} are from\Lspace \Lcitemark 14\Rcitemark \Rspace{} -(results for {\tt kiw2} and {\tt kiw3} are not reported due to -data disparity); -{\tt mad1} to {\tt mad8} are from\Lspace \Lcitemark 10\LIcitemark{}, Examples 1 --8\RIcitemark \Rcitemark \Rspace{}; -{\tt polk1} to {\tt polk4} are from\Lspace \Lcitemark 15\Rcitemark \Rspace{}. -%for {\tt polk1} to {\tt polk4}. -Some of these test problems allow one to freely select -the number of variables; -problems {\tt wats-6} and {\tt wats-20} correspond to 6 and 20 -variables respectively, -and {\tt mad8-10}, {\tt mad8-30} and {\tt mad8-50} to 10, 30 and 50 -variables respectively. -All of the above are either -unconstrained or linearly constrained minimax problems. Unable to find -nonlinearly constrained minimax test problems in the literature, we -constructed problems {\tt p43m} through {\tt p117m} from problems -43, 84, 113 and 117 in\Lspace \Lcitemark 9\Rcitemark \Rspace{} -by removing certain constraints and including instead -additional objectives of the form -$$f_i(x)=f(x)+\alpha _ig_i(x)$$ -where the $\alpha _i$'s are positive scalars and $g_i(x)\leq 0.$ -Specifically, {\tt p43m} -is constructed from problem 43 by taking out the first -two constraints and -including two corresponding objectives with $\alpha _i=15$ for both; -{\tt p84m} similarly corresponds to problem 84 without -constraints 5 and 6 but -with two corresponding additional objectives, -with $\alpha _i=20$ for both; -for {\tt p113m}, the first three linear constraints from problem 113 -were turned into objectives, with $\alpha _i=10$ for all; -for {\tt p117m}, -the first two nonlinear constraints were turned into objectives, -again with $\alpha _i=10$ for both. -The gradients of all the functions were computed by finite difference -approximation except for {\tt polk1} through {\tt polk4} for which -gradients were computed analytically. - -In Table 2, the meaning of columns {\tt B}, {\tt nineqn}, {\tt ncallf}, -{\tt ncallg}, -{\tt iter}, {\tt ktnorm} and {\tt SCV} is as in -Table 1 (but {\tt ncallf} -is the total number of evaluations of {\it scalar} objective function). -{\tt nf} is the number of objective functions in the max, -{\tt objmax} is the -final value of the max of the objective functions. -Finally, as in Table 1, -{\tt eps} is the stopping rule parameter. -Here however its specific meaning -varies from problem to problem as we attempted to best approximate the -stopping rule used in the reference. Specifically, -for problems {\tt bard} through {\tt kiw4}, -execution was terminated when $\|d^0_k\|$ becomes smaller -than the corresponding value of $\epsilon$ in the column -of {\tt eps} (this was also done for problems {\tt p43m} -through {\tt p117m}); -for problems {\tt mad1} down to {\tt mad8}, execution was -terminated when $\|d^0_k\|$ is smaller than $\|x_k\|$ times the -corresponding value of $\epsilon$ in the column {\tt eps} -(except {\tt mad2} for which FSQPD was terminated when the 14 digits -of the maximum objective value carried out by our code did not change); -for problems {\tt polk1} through {\tt polk4}, execution -was terminated when -$\log _e\|x_k-x^*\|$ becomes smaller than the corresponding -value of $\epsilon$ in the column of {\tt eps}. -FSQPD with monotone line search failed to reach a solution for {\tt mad8-30} -when QLD was used, but it succeeded when QPSOL\Lspace \Lcitemark 16\Rcitemark \ -Rspace{} -was used.\footnote{But on most problems, according to our experience, -QLD is significantly faster than QPSOL. A subroutine to interface FSQP -with QPSOL can be obtained from the authors.} - -Table 3 contains results of problems with nonlinear equality -constraints from\Lspace \Lcitemark 9\Rcitemark \Rspace{}. All symbols are the s -ame as -described before. {\tt eps} is the norm requirement on $d_k^0$ -and {\tt epseqn} is chosen close to the corresponding values -in\Lspace \Lcitemark 9\Rcitemark \Rspace{}, with $10^{-8}$ replacing 0. -An asterisk (*) indicates that FSQP failed -to meet the stopping criterion before certain execution error is encountered. -It can be checked that -the second order sufficient conditions of optimality are not satisfied -at the known optimal solution for problems 26, 27, 46 and 47. - -\section{Programming Tips} -\label{tips} -\noindent -The order in which FSQP evaluates the various objectives and -constraints during the line search varies from iteration to -iteration, as the functions deemed more likely to cause rejection of -the trial steps are evaluated first. On the other hand, in -many applications, it is far more efficient to evaluate all -(or at least more than one) of the objectives and constraints concurrently, -as they are all obtained as byproducts of expensive simulations -(e.g., involving finite element computation). This situation -can be accomodated as follows. Whenever a function evaluation -has been performed, store in a common block the value of {\tt x} -and the corresponding values of all objectives and constraints (alternatively, -the values of all ``simulation outputs''). Then, whenever a function -evaluation is requested by FSQP, first check whether the same value of -{\tt x} has just been used and, if so, entirely bypass the expensive -simulation. Note that, if gradients are computed by finite differences, -it will be necessary to save the past {\tt nparam}+1 values of {\tt x} -and of the corresponding objective/constraint values. - -\section{Trouble-Shooting} -\label{trouble} -\noindent It is important to keep in mind some limitations of FSQP. -First, similar to most codes targeted at smooth problems, it is -likely to encounter difficulties when confronted to nonsmooth -functions such as, for example, functions involving matrix -eigenvalues. Second, because FSQP generates feasible iterates, it may -be slow if the feasible set is very ``thin'' or oddly shaped. -Third, concerning equality constraints, if $h_j(x)\geq 0$ for all -$x\in R^n$ and if $h_j(x_0)=0$ -for some $j$ at the initial point $x_0$, the interior of the feasible set -defined by $h_j(x)\leq 0$ for such $j$ is empty. This may cause -difficulties for FSQPD because, in FSQPD, $h_j(x)=0$ is directly -turned into $h_j(x)\leq 0$ for such $j$. -The user is advised to either give an initial point -that is infeasible for all nonlinear equality constraints or change -the sign of $h_j$ so that $h_j(x)<0$ can be achieved at some point -for all such nonlinear equality constraint. - -A common failure mode for FSQP, corresponding to ${\tt inform}=5$ or 6, -is that of the QP solver in constructing {\tt d0} or {\tt d1}. -This is often due to linear dependence (or almost dependence) -of gradients of equality constraints or active inequality constraints. -Sometimes this problem can be circumvented by making use of a more -robust (but likely slower) QP solver. We have designed an interface, -available upon request, that allows the user to use QPSOL\Lspace \Lcitemark 16\ -Rcitemark \Rspace{} -instead of QLD. The user may also want to -check the jacobian matrix and identify which constraints are the -culprit. Eliminating redundant constraints or formulating the constraints -differently (without changing the feasible set) may then be the way to go. - -Finally, when FSQP fails in the line search ({\tt inform}=4), it is -typically due to inaccurate computation of the search direction. Two -possible reasons are: (i) Insufficient accuracy of the QP solver; again, -it may be appropriate to substitute a different QP solver. (ii) -Insufficient accuracy of gradient computation, e.g., when gradients -are computed by finite differences. A remedy may be to provide -analytical gradients or, more astutely, to resort to ``automatic -differentiation''. - -\vspace{1em} -\noindent{\bf Acknowledgment} - -\vspace{1em} -The authors are indebted to Dr. E.R. Panier for many invaluable -comments and suggestions. - -\vspace{1em} -\noindent{\bf References} -\vspace{1em} - -\message{REFERENCE LIST} - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{1}% -\def\Atest{ }\def\Astr{D.Q. Mayne% - \Aand E. Polak}% -\def\Ttest{ }\def\Tstr{Feasible Directions Algorithms for Optimization Problems - with Equality and Inequality Constraints}% -\def\Jtest{ }\def\Jstr{Math. Programming}% -\def\Vtest{ }\def\Vstr{11}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{67--80}% -\def\Dtest{ }\def\Dstr{1976}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{2}% -\def\Atest{ }\def\Astr{E.R. Panier% - \Aand A.L. Tits}% -\def\Ttest{ }\def\Tstr{On Combining Feasibility, Descent and Superlinear Conver -gence in Inequality Constrained Optimization}% -\def\Jtest{ }\def\Jstr{Math. Programming}% -\def\Dtest{ }\def\Dstr{1993, to appear}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{4}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{3}% -\def\Atest{ }\def\Astr{J.F. Bonnans% - \Acomma E.R. Panier% - \Acomma A.L. Tits% - \Aandd J.L. Zhou}% -\def\Ttest{ }\def\Tstr{Avoiding the Maratos Effect by Means of a Nonmonotone Li -ne Search. II. Inequality Constrained Problems -- Feasible Iterates}% -\def\Jtest{ }\def\Jstr{SIAM J. Numer. Anal.}% -\def\Vtest{ }\def\Vstr{29}% -\def\Ntest{ }\def\Nstr{4}% -\def\Dtest{ }\def\Dstr{1992}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{1187--1202}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{4}% -\def\Atest{ }\def\Astr{J.L. Zhou% - \Aand A.L. Tits}% -\def\Ttest{ }\def\Tstr{Nonmonotone Line Search for Minimax Problems}% -\def\Jtest{ }\def\Jstr{J. Optim. Theory Appl.}% -\def\Vtest{ }\def\Vstr{76}% -\def\Ntest{ }\def\Nstr{3}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{455--476}% -\def\Dtest{ }\def\Dstr{1993}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{3}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{5}% -\def\Atest{ }\def\Astr{L. Grippo% - \Acomma F. Lampariello% - \Aandd S. Lucidi}% -\def\Ttest{ }\def\Tstr{A Nonmonotone Line Search Technique for Newton's Method} -% -\def\Jtest{ }\def\Jstr{SIAM J. Numer. Anal.}% -\def\Vtest{ }\def\Vstr{23}% -\def\Ntest{ }\def\Nstr{4}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{707--716}% -\def\Dtest{ }\def\Dstr{1986}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{6}% -\def\Atest{ }\def\Astr{D. Q. Mayne% - \Aand E. Polak}% -\def\Ttest{ }\def\Tstr{A Superlinearly Convergent Algorithm for Constrained Opt -imization Problems}% -\def\Jtest{ }\def\Jstr{Math. Programming Stud.}% -\def\Vtest{ }\def\Vstr{16}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{45--61}% -\def\Dtest{ }\def\Dstr{1982}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{1}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{7}% -\def\Atest{ }\def\Astr{K. Schittkowski}% -\def\Ttest{ }\def\Tstr{QLD : A FORTRAN Code for Quadratic Programming, User's G -uide}% -\def\Itest{ }\def\Istr{Mathematisches Institut, Universit{\"a}t Bayreuth}% -\def\Ctest{ }\def\Cstr{Germany}% -\def\Dtest{ }\def\Dstr{1986}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{1}\def\Ecnt{1}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{8}% -\def\Atest{ }\def\Astr{M.J.D. Powell}% -\def\Ttest{ }\def\Tstr{A Fast Algorithm for Nonlinearly Constrained Optimizatio -n Calculations}% -\def\Btest{ }\def\Bstr{Numerical Analysis, Dundee, 1977, Lecture Notes in Mathe -matics 630}% -\def\Etest{ }\def\Estr{G.A. Watson}% -\def\Itest{ }\def\Istr{Springer-Verlag}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{144--157}% -\def\Dtest{ }\def\Dstr{1978}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{9}% -\def\Atest{ }\def\Astr{W. Hock% - \Aand K. Schittkowski}% -\def\Ttest{ }\def\Tstr{Test Examples for Nonlinear Programming Codes}% -\def\Itest{ }\def\Istr{Lecture Notes in Economics and Mathematical Systems (187 -), Springer Verlag}% -\def\Dtest{ }\def\Dstr{1981}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{10}% -\def\Atest{ }\def\Astr{K. Madsen% - \Aand H. Schj{\ae}r-Jacobsen}% -\def\Ttest{ }\def\Tstr{Linearly Constrained Minimax Optimization}% -\def\Jtest{ }\def\Jstr{Math. Programming}% -\def\Vtest{ }\def\Vstr{14}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{208--223}% -\def\Dtest{ }\def\Dstr{1978}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{1}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{11}% -\def\Atest{ }\def\Astr{G.A. Watson}% -\def\Ttest{ }\def\Tstr{The Minimax Solution of an Overdetermined System of Non- -linear Equations}% -\def\Jtest{ }\def\Jstr{J. Inst. Math. Appl.}% -\def\Vtest{ }\def\Vstr{23}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{167--180}% -\def\Dtest{ }\def\Dstr{1979}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{12}% -\def\Atest{ }\def\Astr{C. Charalambous% - \Aand A.R. Conn}% -\def\Ttest{ }\def\Tstr{An Efficient Method to Solve the Minimax Problem Directl -y}% -\def\Jtest{ }\def\Jstr{SIAM J. Numer. Anal.}% -\def\Vtest{ }\def\Vstr{15}% -\def\Ntest{ }\def\Nstr{1}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{162--187}% -\def\Dtest{ }\def\Dstr{1978}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{2}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{13}% -\def\Atest{ }\def\Astr{A.R. Conn% - \Aand Y. Li}% -\def\Ttest{ }\def\Tstr{An Efficient Algorithm for Nonlinear Minimax Problems}% -\def\Rtest{ }\def\Rstr{Research Report CS-88-41}% -\def\Itest{ }\def\Istr{University of Waterloo}% -\def\Ctest{ }\def\Cstr{Waterloo, Ontario, N2L 3G1 Canada}% -\def\Dtest{ }\def\Dstr{November, 1989 }% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{1}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{14}% -\def\Atest{ }\def\Astr{K.C. Kiwiel}% -\def\Ttest{ }\def\Tstr{Methods of Descent in Nondifferentiable Optimization}% -\def\Stest{ }\def\Sstr{Lecture Notes in Mathematics}% -\def\Ntest{ }\def\Nstr{1133}% -\def\Itest{ }\def\Istr{Springer-Verlag}% -\def\Ctest{ }\def\Cstr{New York--Heidelberg--Berlin}% -\def\Ctest{ }\def\Cstr{Berlin, Heidelberg, New-York, Tokyo}% -\def\Dtest{ }\def\Dstr{1985}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{3}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{15}% -\def\Atest{ }\def\Astr{E. Polak% - \Acomma D.Q. Mayne% - \Aandd J.E. Higgins}% -\def\Ttest{ }\def\Tstr{A Superlinearly Convergent Algorithm for Min-max Problem -s}% -\def\Jtest{ }\def\Jstr{Proceedings of the 28th IEEE Conference on Decision and -Control}% -\def\Dtest{ }\def\Dstr{December 1989}% -\def\Ptest{ }\def\Pcnt{ }\def\Pstr{894--898}% -\Refformat\egroup% - -\bgroup\Resetstrings% -\def\Loccittest{}\def\Abbtest{}\def\Capssmallcapstest{}\def\Edabbtest{}\def\Edc -apsmallcapstest{}\def\Underlinetest{}% -\def\NoArev{0}\def\NoErev{0}\def\Acnt{4}\def\Ecnt{0}\def\acnt{0}\def\ecnt{0}% -\def\Ftest{ }\def\Fstr{16}% -\def\Atest{ }\def\Astr{P.E. Gill% - \Acomma W. Murray% - \Acomma M.A. Saunders% - \Aandd M.H. Wright}% -\def\Ttest{ }\def\Tstr{User's Guide for QPSOL (Version 3.2): A Fortran Package -for Quadratic Programming}% -\def\Rtest{ }\def\Rstr{Technical Report SOL 84-6}% -\def\Itest{ }\def\Istr{Systems Optimization Laboratory, Stanford University}% -\def\Ctest{ }\def\Cstr{Stanford, CA 94305}% -\def\Dtest{ }\def\Dstr{1984}% -\Refformat\egroup% - - -\newpage -\renewcommand{\baselinestretch}{0.95} % more interline spacing - \footnotesize{ -\begin{tabular}{ccccccrlll} \hline -\multicolumn{1}{c}{{\tt prob}} & -\multicolumn{1}{c}{{\tt B}} & -\multicolumn{1}{c}{{\tt nineqn}} & -\multicolumn{1}{c}{{\tt ncallf}} & -\multicolumn{1}{c}{{\tt ncallg}} & -\multicolumn{1}{c}{{\tt iter}} & -\multicolumn{1}{c}{{\tt objective}} & -\multicolumn{1}{c}{{\tt ktnorm}} & -\multicolumn{1}{c}{{\tt eps}} & -\multicolumn{1}{l}{{\tt SCV}} \\ \hline \\ - - {\tt p12} & 0 & 1 & ~7 & ~14 &~7 &$-$.300000000E+02 &.72E-06 & .10E-05 & -.0\\ - & 1 & & ~7 & ~12 &~7 &$-$.300000000E+02 &.79E-06 & .10E-05 & -.0\\\hline - {\tt p29} & 0 & 1 & 11 & ~20 & 10 &$-$.226274170E+02 &.41E-05 & .10E-04 & -.0\\ - & 1 & & 12 & ~16 & 12 &$-$.226274170E+02 &.63E-05 & .10E-04 & -.0\\\hline - {\tt p30} & 0 & 1 & 13 & ~25 & 13 & .100000000E+01 &.26E-07 & .10E-06 & -.0\\ - & 1 & & 14 & ~14 & 14 & .100000000E+01 &.43E-07 & .10E-06 & -.0\\\hline - {\tt p31} & 0 & 1 & 10 & ~21 &~8 & .600000000E+01 &.34E-06 & .10E-04 & -.0\\ - & 1 & & 10 & ~18 & 10 & .600000000E+01 &.50E-06 & .10E-04 & -.0\\\hline - {\tt p32} & 0 & 1 & ~3 & ~~5 &~3 & .100000000E+01 &.15E-14 & .10E-07 & -.0\\ - & 1 & & ~3 & ~~4 &~3 & .100000000E+01 &.64E-16 & .10E-07 & -.0\\\hline - {\tt p33} & 0 & 2 & ~4 & ~11 &~4 &$-$.400000000E+01 &.13E-11 & .10E-07 & -.0\\ - & 1 & & ~5 & ~10 &~5 &$-$.400000000E+01 &.47E-11 & .10E-07 & -.0\\\hline - {\tt p34} & 0 & 2 & ~7 & ~28 &~7 &$-$.834032443E+00 &.19E-08 & .10E-07 & -.0\\ - & 1 & & ~9 & ~24 &~9 &$-$.834032445E+00 &.38E-11 & .10E-07 & -.0\\\hline - {\tt p43} & 0 & 3 & 11 & ~51 & ~9 &$-$.440000000E+02 &.12E-05 & .10E-04 & -.0\\ - & 1 & & 12 & ~49 &12 &$-$.440000000E+02 &.16E-06 & .10E-04 & -.0\\\hline - {\tt p44} & 0 & 0 & ~6 & ~~0 & ~6 &$-$.150000000E+02 &.0 & .10E-07 & -.0\\ - & 1 & & ~6 & &~6 &$-$.150000000E+02 &.0 & .10E-07 & -.0\\\hline - {\tt p51} & 0 & 0 & ~8 & ~~0 &~6 & .505655658E$-$15 &.46E-06 &.10E-05 -&.22E-15\\ - & 1 & & ~9 & &~8 & .505655658E$-$15 &.34E-08 &.10E-05 -&.22E-15\\\hline - {\tt p57} & 0 & 1 & ~5 & ~~7 &~3 & .306463061E$-$01 &.29E-05 &.10E-04 -&.0\\ - & 1 & & ~5 & ~~7 &~3 & .306463061E$-$01 &.28E-05 &.10E-04 -&.0\\\hline - {\tt p66} & 0 & 2 & ~8 & ~30 &~8 & .518163274E+00 &.50E-09 &.10E-07 -&.0\\ - & 1 & & ~9 & ~24 &~9 & .518163274E+00 &.14E-08 &.10E-07 -&.0\\\hline - {\tt p67} & 0 & 14 & 21 & 305 &21 &$-$.116211927E+02 &.88E-06 &.10E-04 -&.0\\ - & 1 & & 61 & 854 &61 &$-$.116211927E+02 &.58E-05 &.10E-04 -&.0\\\hline - {\tt p70} & 0 & 1 & 32 & ~39 &30 & .940197325E$-$02 &.58E-08 &.10E-06 -&.0\\ - & 1 & & 31 & ~31 &31 & .940197325E$-$02 &.19E-07 &.10E-06 -&.0\\\hline - {\tt p76} & 0 & 0 & ~6 & ~~0 &~6 &$-$.468181818E+01 &.34E-04 &.10E-03 &. -0\\ - & 1 & & ~6 & &~6 &$-$.468181818E+01 &.34E-04 &.10E-03 &. -0\\\hline - {\tt p84} & 0 & 6 & ~4 & ~30 &~4 &$-$.528033513E+07 &.0 & .10E-07 & -.0\\ -* & 1 & & ~4 & ~29 &~4 &$-$.528033513E+07 &.38E-09 & .10E-07 & -.0\\\hline - {\tt p85} & 0 &38 & 34 & 1347 &34 &$-$.240000854E+01 &.35E-03 &.10E-02 &. -0\\ - & 1 & & 80 & 3040 &80 &$-$.240000854E+01 &.81E-03 &.10E-02 &. -0\\\hline - {\tt p86} & 0 & 0 & ~8 & ~~0 &~6 &$-$.323486790E+02 &.22E-08 & .10E-05 & -.0\\ - & 1 & & ~7 & &~6 &$-$.323486790E+02 &.53E-06 & .10E-05 & -.0\\\hline - {\tt p93} & 0 & 2 & 15 & ~58 & 12 & .135075968E+03 &.37E-03 & .10E-02 & -.0\\ - & 1 & & 15 & ~36 & 15 & .135075964E+03 &.24E-04 & .10E-02 & -.0\\\hline - {\tt p100}& 0 & 4 & 23 & 114 & 16 & .680630057E+03 &.62E-06 & .10E-03 & -.0\\ - & 1 & & 20 & 102 & 17 & .680630057E+03 &.49E-04 & .10E-03 & -.0\\\hline - {\tt p110}& 0 & 0 & ~9 & ~~0 &~8 &$-$.457784697E+02 &.50E-06 & .10E-05 & -.0\\ - & 1 & & ~9 & &~8 &$-$.457784697E+02 &.50E-06 & .10E-05 & -.0\\\hline - {\tt p113}& 0 & 5 & 12 & 108 & 12 & .243063768E+02 &.81E-03 & .10E-02 & -.0\\ - & 1 & & 12 & ~99 & 12 & .243064357E+02 &.83E-03 & .10E-02 & -.35E-14\\\hline - {\tt p117}& 0 & 5 & 20 & 219 & 19 & .323486790E+02 &.58E-04 & .10E-03 & -.0\\ - & 1 & & 18 & ~93 & 17 & .323486790E+02 &.34E-04 & .10E-03 & -.0\\\hline - {\tt p118}& 0 & 0 & 19 &~~0 & 19 & .664820450E+03 &.13E-14 & .10E-07 & -.0\\ - & 1 & & 19 & & 19 & .664820450E+03 &.17E-14 & .10E-07 & -.0\\ -\hline -\end{tabular} -} - -\nopagebreak -\vspace{1em} -\hspace{4em} -Table 1: Results for Inequality Constrained Problems with FSQP Version 3.2 - -\newpage -\renewcommand{\baselinestretch}{1.0} % more interline spacing - \begin{quote} -{\scriptsize -\begin{tabular}{cccccccrllc} \hline -\multicolumn{1}{c}{\tt prob} & -\multicolumn{1}{c}{{\tt B}} & -\multicolumn{1}{c}{{\tt nineqn}} & -\multicolumn{1}{r}{{\tt nf}} & -\multicolumn{1}{c}{{\tt ncallf}} & -\multicolumn{1}{c}{{\tt ncallg}} & -\multicolumn{1}{c}{{\tt iter}} & -\multicolumn{1}{c}{{\tt objmax}} & -\multicolumn{1}{c}{{\tt ktnorm}} & -\multicolumn{1}{c}{{\tt eps}} & -\multicolumn{1}{c}{{\tt SCV}}\\ \hline \\ - {\tt bard} & 0 &0&~15&~168&~~0&~8& .508163265E$-$01&.61E-09 & .50E-05&.0 \\ - & 1 & & &~105& &~7& .508168686E$-$01&.22E-06 & .50E-05&.0 \\\ -hline - {\tt cb2} & 0 &0&~~3&~~30&~~0&~6& .195222449E+01 &.37E-06 & .50E-05&.0 \\ - & 1 & & &~~18& &~6& .195222449E+01 &.29E-05 & .50E-05 &.0\\\ -hline - {\tt cb3} & 0 &0&~~3&~~15&~~0&~3& .200000157E+01 &.40E-05 & .50E-05 &.0\\ - & 1 & & &~~15& &~5& .200000000E+01 &.47E-08 & .50E-05 &.0\\\ -hline -{\tt colv} & 0 &0&~~6&~240&~~0&21& .323486790E+02 &.46E-05 & .50E-05 &.0\\ - & 1 & & &~102& &17& .323486790E+02 &.12E-04 & .50E-05 &.0\\\ -hline -{\tt davd2} & 0 &0&~20&~342&~~0&12& .115706440E+03 &.62E-06 & .50E-05 &.0\\ - & 1 & & &~220& &11& .115706440E+03 &.11E-05 & .50E-05 &.0\\\ -hline -{\tt f\&r} & 0 &0&~~2&~~32&~~0&~9& .494895210E+01 &.90E-09 & .50E-05 &.0\\ - & 1 & & &~~20& &10& .494895210E+01 &.70E-07 & .50E-05 &.0\\\ -hline -{\tt hettich}& 0 &0&~~5&~125&~~0&13& .245935695E$-$02&.10E-07 & .50E-05&.0 \\ - & 1 & & &~~75& &11& .245936698E$-$02&.18E-07 & .50E-05&.0 \\\ -hline -{\tt r-s} & 0 &0&~~4&~~71&~~0&~9&$-$.440000000E+02 &.98E-06 & .50E-05 &.0\\ - & 1 & & &~~68& &12&$-$.440000000E+02 &.28E-06 & .50E-05 &.0\\\ -hline -{\tt wats-6}& 0 &0&~31&~623&~~0&12& .127172748E$-$01&.42E-07 & .50E-05&.0 \\ - & 1 & & &~433& &13& .127170913E$-$01&.84E-10 & .50E-05 &.0\\\ -hline -{\tt wats-20}& 0 &0&~31&1953&~~0&32& .895554035E$-$07&.13E-05 & .50E-05 &.0\\ - & 1 & & &1023& &32& .898278737E$-$07&.13E-05 & .50E-05 &.0\\\ -hline -{\tt wong} & 0 &0&~~5&~182&~~0&19& .680630057E+03 &.40E-04 & .50E-05 &.0\\ - & 1 & & &~171& &26& .680630057E+03 &.13E-03 & .50E-05 &.0\\\ -hline -{\tt kiw1} & 0 &0&~10&~159&~~0&11& .226001621E+02 &.32E-05 & .11E-05 &.0\\ - & 1 & & &~130& &13& .226001621E+02 &.54E-05 & .60E-06 &.0\\\ -hline -{\tt kiw4} & 0 &0&~~2&~~42&~~0&~9& .222044605E$-$15&.18E-07 &.42E-07&.0 \\ - & 1 & & &~~23& &~9& .0\hspace{5.75em}~~~&.47E-07 &.15E-07 &.0 -\\\hline -{\tt mad1} & 0 &0&~~3&~~24&~~0&~5&$-$.389659516E+00 &.22E-10 & .10E-09 &.0\\ - & 1 & & &~~18& &~6&$-$.389659516E+00 &.48E-10 & .10E-09 &.0\\\ -hline -{\tt mad2} & 0 &0&~~3&~~25&~~0&~5&$-$.330357143E+00 &.22E-10 & .10E-09 &.0\\ - & 1 & & &~~21& &~6&$-$.330357143E+00 &.86E-09 & .10E-09 &.0\\\ -hline -{\tt mad4} & 0 &0&~~3&~~29&~~0&~6&$-$.448910786E+00 &.31E-17 & .10E-09 &.0\\ - & 1 & & &~~24& &~8&$-$.448910786E+00 &.38E-16 & .10E-09 &.0\\\ -hline -{\tt mad5} & 0 &0&~~3&~~31&~~0&~7&$-$.100000000E+01 &.21E-11 & .10E-09 &.0\\ - & 1 & & &~~24& &~8&$-$.100000000E+01 &.78E-14 & .10E-09 &.0\\\ -hline -{\tt mad6} & 0 &0&163&1084&~~0&~6& .113104727E+00 &.81E-11 & .10E-09 &.0\\ - & 1 & & &1141& &~7& .113104727E+00 &.21E-10 & .10E-09 &.0\\\ -hline -{\tt mad8-10}& 0&0&~18&~291&~~0&10& .381173963E+00 &.89E-11 & .10E-09 &.0\\ - & 1 & & &~252& &14& .381173963E+00 &.16E-14 & .10E-09 &.0\\\ -hline -{\tt mad8-30}& 0&0& & & & *& & & .10E-09 & \\ - & 1 & & &1102& &18& .547620496E+00 &.12E-14 & .10E-09 &.0\\\ -hline -{\tt mad8-50}& 0&0&~98&3056&~~0&21& .579276202E+00 &.86E-15 & .10E-09 &.0\\ - & 1 & & &2084& &21& .579276202E+00 &.91E-16 & .10E-09 &.0\\\ -hline -{\tt polk1} & 0 &0&~~2&~~42&~~0&10& .271828183E+01 &.50E-04 & ~$-$10.00&.0 \ -\ - & 1 & & &~~22& &10& .271828183E+01 &.68E-04 & ~$-$10.00&.0 \ -\\hline -{\tt polk2} & 0 &0&~~2&~203&~~0&42& .545981839E+02 &.28E-03 & ~$-$\,~9.00&.0 - \\ - & 1 & & &~116& &38& .545981500E+02 &.14E-02 & ~$-$\,~9.00&.0 - \\\hline -{\tt polk3} & 0 &0&~10&~188&~~0&12& .370348302E+01 &.23E-02 & ~$-$\,~5.50&.0 - \\ - & 1 & & &~141& &12& .370348272E+01 &.26E-02 & ~$-$\,~5.50&.0 - \\\hline -{\tt polk4} & 0 &0&~~3&~~45&~~0&~7&.0\hspace{5.45em}~~~ &.39E-04 & ~$-$10.00&. -0 \\ - & 1 & & &~~24& &~7& .364604254E+00 &.37E-06 & ~$-$10.00&.0 \ -\\hline -{\tt p43m} & 0 &1&~~3&~~80&~43&15&$-$.440000000E+02 &.14E-05 & .50E-05&.0\\ - &1 & & &~~63&~25&16&$-$.440000000E+02 &.46E-05 & .50E-05&.0\\\h -line -{\tt p84m} &0 &4&~~3&~~17&~20&~4&$-$.528033513E+07 &.28E-09 & .50E-05&.0\\ - &1 & & &~~~9&~12&~3&$-$.528033511E+07 &.76E-05 & .50E-05&.0\\\h -line -{\tt p113m} &0 &5&~~4&~108&127&14& .243062091E+02 &.14E-04 & .50E-05&.0\\ - &1 & & &~~84&105&14& .243062091E+02 &.29E-04 & .50E-05&.0\\\h -line -{\tt p117m} &0 &3&~~3&~124&144&21& .323486790E+02 &.43E-05 & .50E-05&.0\\ - &1 & & &~~57&~54&17& .323486790E+02 &.26E-04 & .50E-05&.0\\\h -line -\end{tabular} -} -\end{quote} - -\nopagebreak -\hspace{6em}Table 2: Results for Minimax Problems with FSQP Version 3.2 - -\newpage -\renewcommand{\baselinestretch}{0.924} % more interline spacing - \footnotesize{ -\begin{tabular}{cccccrllll} \hline -\multicolumn{1}{c}{{\tt prob}} & -\multicolumn{1}{c}{{\tt B}} & -\multicolumn{1}{c}{{\tt ncallf}} & -\multicolumn{1}{c}{{\tt ncallg}} & -\multicolumn{1}{c}{{\tt iter}} & -\multicolumn{1}{c}{{\tt objective}} & -\multicolumn{1}{c}{{\tt ktnorm}} & -\multicolumn{1}{c}{{\tt eps}} & -\multicolumn{1}{c}{{\tt epseqn}} & -\multicolumn{1}{c}{{\tt SCV}} \\ \hline \\ - - {\tt p6} &0 &~17 & ~22 &10 & .274055126E$-$11 &.42E-05 & .10E-03 &.40E --06&.20E-09\\ - &1 &~21 & ~23 &10 & .116074629E$-$12 &.35E-05 & .10E-03 &.40E --06&.28E-06\\\hline - {\tt p7} &0 &~57 & ~57 &13 &$-$.173205081E+01 &.12E-06 & .10E-03 &.35E-0 -8&.70E-09\\ - &1 & ~27 & ~25 & 15 &$-$.173205081E+01 &.68E-08 & .10E-03 &.35E-0 -8&.15E-09\\\hline - {\tt p26} &0 & 127 & 138 & 51 & .270576724E$-$13 &.15E-08 & .10E-03 &.16E --04&.12E-09\\ - &1 & ~38 & ~38 & 31 & .322181110E$-$13 &.49E-08 & .10E-03 &.16E --04&.43E-08\\\hline - {\tt p27} &0 & 153 & 147 & 44 & .399986835E$-$01 &.24E-02 & .10E-02 &.10E- -02&.38E-04\\ - &1 & 999 & 996 &130 & .399916645E$-$01 &.39E-03 & .10E-02 &.10E --02&.21E-03\\\hline - {\tt p39} &0 &~23 & ~49 & 17 &$-$.100000000E+01 &.39E-04 & .10E-03 &.75E-0 -4&.90E-08\\ - &1 &~12 & ~25 &12 &$-$.100000000E+01 &.50E-04 & .10E-03 &.75E-0 -4&.64E-06\\\hline - {\tt p40} &0 &~~5 & ~15 & ~5 &$-$.250000002E+01 &.26E-05 & .10E-03 &.85E-0 -4&.96E-08\\ - &1 &~~5 & ~17 &~5 &$-$.250000000E+01 &.41E-04 & .10E-03 &.85E-0 -4&.43E-05\\\hline - {\tt p42} &0 &~~9 & ~10 &~6 & .138578644E+02 &.27E-05 & .10E-03 &.45E-0 -5&.51E-09\\ - &1 &~~7 & ~12 &~7 & .138578652E+02 &.26E-03 & .10E-03 &.45E-0 -5&.33E-06\\\hline - {\tt p46} &0 & ~62 & 135 &26 & .224262538E$-$10 &.11E-04 & .10E-03 &.50E --04&.57E-10 \\ - &1 & ~56 & ~25 &14 & .461984187E$-$04 &.19E-02 & .10E-03 &.50E --04&.95E-06\\\hline - {\tt p47} &0 & ~74 & 241 &38 & .162241544E$-$11 &.56E-06 & .10E-03 &.60E --04&.41E-09\\ - &1 & ~50 & 282 & 36 & .308185534E$-$01 &.11E-04 & .10E-03 &.60E --04&.26E-08 \\\hline - {\tt p56} &0 & ~31 & 147 &15 &$-$.345600000E+01 &.46E-08 & .10E-03 &.25E-0 -6&.34E-10\\ - &1 & ~14 & ~60 &14 &$-$.345600000E+01 &.88E-05 & .10E-03 &.25E-0 -6&.11E-08\\\hline - {\tt p60} &0 & ~10 & ~13 &10 & .325682003E$-$01 &.29E-05 &.10E-03 &.55E- -04&.27E-09\\ - &1 & ~~9 & ~14 &~9 & .325687946E$-$01 &.21E-03 &.10E-03 &.55E- -04&.55E-04\\\hline - {\tt p61} &0 &~18 & ~38 &~8 &$-$.143646142E+03 &.35E-04 &.10E-03 &.25E- -06&.13E-07\\ - &1 &~38 & ~17 &~9 &$-$.143646142E+03 &.67E-07 &.10E-03 &.25E- -06&.27E-12\\\hline - {\tt p63} &0 &~~8 & ~10 &~8 & .961715172E+03 &.12E-06 &.10E-03 &.60E- -05&.15E-10\\ - &1 &~~6 & ~10 &~6 & .961715172E+03 &.25E-04 &.10E-03 &.60E- -05&.65E-07\\\hline - {\tt p71} &0 &~~9 & ~24 &~8 & .170140173E+02 &.34E-07 &.10E-03 &.70E- -05&.35E-11\\ - &1 &~~6 & ~19 &~6 & .170140173E+02 &.79E-09 &.10E-03 &.70E- -05&.28E-08\\\hline - {\tt p74} &0 &~14 & ~43 &14 & .512649811E+04 &.65E-06 &.10E-03 &.65E-05 -&.21E-10\\ - &1 &~41 & 123 &41 & .512649811E+04 &.31E-04 &.10E-03 &.65E-05 -&.16E-08\\\hline - {\tt p75} &0 &~13 & ~39 &13 & .517441270E+04 &.84E-08 &.10E-03 &.10E-07 -&.25E-11\\ -* &1 &~28 & ~84 &28 & .517441270E+04 &.35E-08 &.10E-03 &.10E-07 -&.19E-08\\\hline - {\tt p77} &0 &~15 & ~37 &15 & .241505129E+00 &.30E-05 &.10E-03 &.35E-04 -&.68E-07\\ - &1 &~18 & ~48 &19 & .241505211E+00 &.61E-04 &.10E-03 &.35E-04 -&.14E-05\\\hline - {\tt p78} &0 &~~9 & ~41 &~9 &$-$.291970041E+01 &.83E-07 &.10E-03 &.15E-05 -&.45E-10\\ - &1 &~~8 & ~26 &~8 &$-$.291970041E+01 &.11E-03 &.10E-03 &.15E-05 -&.11E-08\\\hline - {\tt p79} &0 &~~7 & ~24 &~7 & .974340336E$-$01 &.12E-04 & .10E-03 &.15E --03&.41E-07\\ - &1 &~10 & ~34 &10 & .974340336E$-$01 &.66E-05 & .10E-03 &.15E --03&.40E-07\\\hline - {\tt p80} &0 & ~66 & 198 & 20 & .539498478E$-$01 &.25E-08 & .10E-03 &.15E --07&.25E-12\\ - &1 & ~~7 & ~21 & ~7 & .539498478E$-$01 &.91E-08 & .10E-03 &.15E --07&.11E-07\\\hline - {\tt p81} &0 & ~59 & 177 & 20 & .539498478E$-$01 &.55E-05 & .10E-03 &.80E --06&.36E-09\\ - &1 & ~~8 & ~24 & ~8 & .539498419E$-$01 &.63E-05 & .10E-03 &.80E --06&.17E-06\\\hline - {\tt p99} & 0& 111 & 269 & 38 &$-$.831079886E+09 &.17E+03 & .10E-03 &.10E --07&.92E-09 \\ - & 1& 130 & 1229 &130 &$-$.831079886E+09 &.33E+01 & .10E-03 &.10E-0 -7&.50E-01 \\\hline - {\tt p107}&0 & ~16 & 116 & 14 & .505501180E+04 & .56E-02& .10E-03 &.10E-0 -7&.48E-09 \\ - &1 & ~16 & 109 & 16 & .505501180E+04 &.69E-03 & .10E-03 &.10E-0 -7&.39E-09\\\hline - {\tt p109}&0 & & & * & & & .10E-03 &.10E-0 -7& \\ - &1 & & & * & & & .10E-03 &.10E-0 -7& \\\hline - {\tt p114}&0 & & & * & & & .10E-02 &.10E-0 -3& \\ - &1 &18241 & 941 &924 &$-$.176880696E+04 &.51E-05 & .10E-02 &.10E-0 -3&.22E-12 \\\hline -\end{tabular} -} - -\nopagebreak -\vspace{0.4em} -\hspace{8em}Table 3: Results for General Problems with FSQP Version 3.2 - -\end{document}
deleted file mode 100644 --- a/libcruft/fsqp/manual.sty +++ /dev/null @@ -1,384 +0,0 @@ -% manual.sty 9-Jun-87 - -\typeout{Document Style `manual' <9 Jun 87>.} - - -\def\@ptsize{0} \@namedef{ds@11pt}{\def\@ptsize{1}} -\@namedef{ds@12pt}{\def\@ptsize{2}} -\def\ds@twoside{\@twosidetrue \@mparswitchtrue} -\def\ds@draft{\overfullrule -5pt} -\@options -% art12.sty 9-Jun-87 - -\lineskip 1pt \normallineskip 1pt -\def\baselinestretch{1} - -\def\@normalsize{\@setsize\normalsize{14.5pt}\xiipt\@xiipt -\abovedisplayskip 12pt plus3pt minus7pt\belowdisplayskip -\abovedisplayskip -\abovedisplayshortskip \z@ plus3pt\belowdisplayshortskip 6.5pt plus3.5pt -minus3pt\let\@listi\@listI} -\def\small{\@setsize\small{13.6pt}\xipt\@xipt -\abovedisplayskip 11pt plus3pt minus6pt\belowdisplayskip -\abovedisplayskip -\abovedisplayshortskip \z@ plus3pt\belowdisplayshortskip 6.5pt plus3.5pt -minus3pt -\def\@listi{\parsep 4.5pt plus 2pt minus 1pt - \itemsep \parsep - \topsep 9pt plus 3pt minus 5pt}} -\def\footnotesize{\@setsize\footnotesize{12pt}\xpt\@xpt -\abovedisplayskip 10pt plus2pt minus5pt\belowdisplayskip -\abovedisplayskip -\abovedisplayshortskip \z@ plus3pt -\belowdisplayshortskip 6pt plus3pt minus3pt -\def\@listi{\topsep 6pt plus 2pt minus 2pt\parsep 3pt plus 2pt minus 1pt -\itemsep \parsep}} -\def\scriptsize{\@setsize\scriptsize{9.5pt}\viiipt\@viiipt} -\def\tiny{\@setsize\tiny{7pt}\vipt\@vipt} -\def\large{\@setsize\large{18pt}\xivpt\@xivpt} -\def\Large{\@setsize\Large{22pt}\xviipt\@xviipt} -\def\LARGE{\@setsize\LARGE{25pt}\xxpt\@xxpt} -\def\huge{\@setsize\huge{30pt}\xxvpt\@xxvpt} -\let\Huge=\huge -\normalsize - -\if@twoside \oddsidemargin 21pt \evensidemargin 59pt -\marginparwidth 85pt -\else \oddsidemargin 39.5pt \evensidemargin 39.5pt - \marginparwidth 68pt -\fi -\marginparsep 10pt - \topmargin 27pt \headheight 12pt \headsep 25pt \footskip 30pt - -\textheight = 36\baselineskip -\advance\textheight by \topskip -\textwidth 390pt \columnsep 10pt \columnseprule 0pt - -\footnotesep 8.4pt -\skip\footins 10.8pt plus 4pt minus 2pt -\floatsep 14pt plus 2pt minus 4pt \textfloatsep 20pt plus 2pt minus 4pt -\intextsep 14pt plus 4pt minus 4pt \@maxsep 20pt -\dblfloatsep 14pt plus 2pt -minus 4pt \dbltextfloatsep 20pt plus 2pt minus 4pt \@dblmaxsep 20pt -\@fptop 0pt plus 1fil \@fpsep 10pt plus 2fil \@fpbot 0pt plus 1fil -\@dblfptop 0pt plus 1fil \@dblfpsep 10pt plus 2fil -\@dblfpbot 0pt plus 1fil -\marginparpush 7pt - -\parskip 0pt plus 1pt \parindent 1.5em \partopsep 3pt plus 2pt minus 2pt -\@lowpenalty 51 \@medpenalty 151 \@highpenalty 301 -\@beginparpenalty -\@lowpenalty \@endparpenalty -\@lowpenalty -\@itempenalty --\@lowpenalty - - -\def\part{\par \addvspace{4ex} \@afterindentfalse \secdef\@part\@spart} -\def\@part[#1]#2{\ifnum \c@secnumdepth >\m@ne \refstepcounter{part} -\addcontentsline{toc}{part}{\thepart \hspace{1em}#1}\else -\addcontentsline{toc}{part}{#1}\fi { \parindent 0pt \raggedright - \ifnum \c@secnumdepth >\m@ne \Large \bf Part -\thepart \par\nobreak \fi \huge -\bf #2\markboth{}{}\par } \nobreak \vskip 3ex \@afterheading } -\def\@spart#1{{\parindent 0pt \raggedright - \huge \bf - #1\par} \nobreak \vskip 3ex \@afterheading } -\def\section{\@startsection {section}{1}{\z@}{-3.5ex plus -1ex minus - -.2ex}{2.3ex plus .2ex}{\bf}} -\def\subsection{\@startsection{subsection}{2}{\z@} -{-3.25ex plus -1ex minus - -.2ex}{1.5ex plus .2ex}{\normalsize\bf}} -\def\subsubsection{\@startsection{subsubsection}{3}{\z@}{-3.25ex plus - -1ex minus -.2ex}{1.5ex plus .2ex}{\normalsize\bf}} -\def\paragraph{\@startsection - {paragraph}{4}{\z@}{3.25ex plus 1ex minus .2ex}{-1em}{\normalsize\bf}} -\def\subparagraph{\@startsection - {subparagraph}{4}{\parindent}{3.25ex plus 1ex minus - .2ex}{-1em}{\normalsize\bf}} - - -\setcounter{secnumdepth}{3} - -\def\appendix{\par - \setcounter{section}{0} - \setcounter{subsection}{0} - \def\thesection{\Alph{section}}} - - -\leftmargini 2.5em -\leftmarginii 2.2em \leftmarginiii 1.87em -\leftmarginiv 1.7em \leftmarginv 1em -\leftmarginvi 1em -\leftmargin\leftmargini -\labelsep .5em -\labelwidth\leftmargini\advance\labelwidth-\labelsep -\def\@listI{\leftmargin\leftmargini -\parsep 5pt plus 2.5pt minus 1pt\topsep -10pt plus 4pt minus 6pt\itemsep 5pt plus 2.5pt minus 1pt} -\let\@listi\@listI -\@listi -\def\@listii{\leftmargin\leftmarginii - \labelwidth\leftmarginii\advance\labelwidth-\labelsep - \topsep 5pt plus 2.5pt minus 1pt - \parsep 2.5pt plus 1pt minus 1pt - \itemsep \parsep} -\def\@listiii{\leftmargin\leftmarginiii - \labelwidth\leftmarginiii\advance\labelwidth-\labelsep - \topsep 2.5pt plus 1pt minus 1pt - \parsep \z@ \partopsep 1pt plus 0pt minus 1pt - \itemsep \topsep} -\def\@listiv{\leftmargin\leftmarginiv - \labelwidth\leftmarginiv\advance\labelwidth-\labelsep} -\def\@listv{\leftmargin\leftmarginv - \labelwidth\leftmarginv\advance\labelwidth-\labelsep} -\def\@listvi{\leftmargin\leftmarginvi - \labelwidth\leftmarginvi\advance\labelwidth-\labelsep} -\relax - - -\def\labelenumi{\arabic{enumi}.} -\def\theenumi{\arabic{enumi}} -\def\labelenumii{(\alph{enumii})} -\def\theenumii{\alph{enumii}} -\def\p@enumii{\theenumi} -\def\labelenumiii{\roman{enumiii}.} -\def\theenumiii{\roman{enumiii}} -\def\p@enumiii{\theenumi(\theenumii)} -\def\labelenumiv{\Alph{enumiv}.} -\def\theenumiv{\Alph{enumiv}} -\def\p@enumiv{\p@enumiii\theenumiii} - -\def\labelitemi{$\bullet$} -\def\labelitemii{\bf --} -\def\labelitemiii{$\ast$} -\def\labelitemiv{$\cdot$} - -\def\verse{\let\\=\@centercr - \list{}{\itemsep\z@ \itemindent -1.5em\listparindent \itemindent - \rightmargin\leftmargin\advance\leftmargin 1.5em}\item[]} -\let\endverse\endlist -\def\quotation{\list{}{\listparindent 1.5em - \itemindent\listparindent - \rightmargin\leftmargin \parsep 0pt plus 1pt}\item[]} -\let\endquotation=\endlist -\def\quote{\list{}{\rightmargin\leftmargin}\item[]} -\let\endquote=\endlist - -%\def\descriptionlabel#1{\hspace\labelsep \bf #1} -%\def\description{\list{}{\labelwidth\z@ \itemindent-\leftmargin -% \let\makelabel\descriptionlabel}} -%\let\enddescription\endlist - -\def\descriptionlabel#1{\it #1 \hfill} -\def\description{\list{}{\labelwidth=0.7in -\itemindent=0in \leftmargin=0.9in - \labelsep=0in \let\makelabel\descriptionlabel}} -\let\enddescription\endlist - -\def\describelabel#1{\hspace{0.1in} \tt #1 \hfill} -\def\describe{\list{}{\labelwidth=0.8in -\itemindent=0in \leftmargin=0.8in - \labelsep=0in \let\makelabel\describelabel}} -\let\enddescribe\endlist - - - -\def\theequation{\arabic{equation}} - - -\def\titlepage{\@restonecolfalse\if@twocolumn\@restonecoltrue\onecolumn - \else \newpage \fi \thispagestyle{empty}\c@page\z@} -\def\endtitlepage{\if@restonecol\twocolumn \else \newpage \fi} - -\arraycolsep 5pt \tabcolsep 6pt \arrayrulewidth .4pt \doublerulesep 2pt -\tabbingsep \labelsep - -\skip\@mpfootins = \skip\footins -\fboxsep = 3pt \fboxrule = .4pt - -\newcounter{part} -\newcounter {section} -\newcounter {subsection}[section] -\newcounter {subsubsection}[subsection] -\newcounter {paragraph}[subsubsection] -\newcounter {subparagraph}[paragraph] - -\def\thepart{\Roman{part}} \def\thesection {\arabic{section}} -\def\thesubsection {\thesection.\arabic{subsection}} -\def\thesubsubsection {\thesubsection .\arabic{subsubsection}} -\def\theparagraph {\thesubsubsection.\arabic{paragraph}} -\def\thesubparagraph {\theparagraph.\arabic{subparagraph}} - -\def\@pnumwidth{1.55em} -\def\@tocrmarg {2.55em} -\def\@dotsep{4.5} -\setcounter{tocdepth}{3} - -\def\tableofcontents{\section*{Contents\@mkboth{CONTENTS}{CONTENTS}} - \@starttoc{toc}} -\def\l@part#1#2{\addpenalty{\@secpenalty} - \addvspace{2.25em plus 1pt} \begingroup - \@tempdima 3em \parindent \z@ \rightskip \@pnumwidth \parfillskip --\@pnumwidth - {\large \bf \leavevmode #1\hfil \hbox to\@pnumwidth{\hss #2}}\par - \nobreak \endgroup} -\def\l@section#1#2{\addpenalty{\@secpenalty} \addvspace{1.0em plus 1pt} -\@tempdima 1.5em \begingroup - \parindent \z@ \rightskip \@pnumwidth - \parfillskip -\@pnumwidth - \bf \leavevmode #1\hfil \hbox to\@pnumwidth{\hss #2}\par - \endgroup} -\def\l@subsection{\@dottedtocline{2}{1.5em}{2.3em}} -\def\l@subsubsection{\@dottedtocline{3}{3.8em}{3.2em}} -\def\l@paragraph{\@dottedtocline{4}{7.0em}{4.1em}} -\def\l@subparagraph{\@dottedtocline{5}{10em}{5em}} -\def\listoffigures{\section*{List of Figures\@mkboth - {LIST OF FIGURES}{LIST OF FIGURES}}\@starttoc{lof}} -\def\l@figure{\@dottedtocline{1}{1.5em}{2.3em}} -\def\listoftables{\section*{List of Tables\@mkboth - {LIST OF TABLES}{LIST OF TABLES}}\@starttoc{lot}} -\let\l@table\l@figure - - -\def\thebibliography#1{\section*{References\@mkboth - {REFERENCES}{REFERENCES}}\list - {[\arabic{enumi}]}{\settowidth\labelwidth{[#1]}\leftmargin\labelwidth - \advance\leftmargin\labelsep - \usecounter{enumi}} - \def\newblock{\hskip .11em plus .33em minus -.07em} - \sloppy\clubpenalty4000\widowpenalty4000 - \sfcode`\.=1000\relax} -\let\endthebibliography=\endlist - - -\newif\if@restonecol -\def\theindex{\@restonecoltrue\if@twocolumn\@restonecolfalse\fi -\columnseprule \z@ -\columnsep 35pt\twocolumn[\section*{Index}] - \@mkboth{INDEX}{INDEX}\thispagestyle{plain}\parindent\z@ - \parskip\z@ plus .3pt\relax\let\item\@idxitem} -\def\@idxitem{\par\hangindent 40pt} -\def\subitem{\par\hangindent 40pt \hspace*{20pt}} -\def\subsubitem{\par\hangindent 40pt \hspace*{30pt}} -\def\endtheindex{\if@restonecol\onecolumn\else\clearpage\fi} -\def\indexspace{\par \vskip 10pt plus 5pt minus 3pt\relax} - -\def\footnoterule{\kern-3\p@ - \hrule width .4\columnwidth - \kern 2.6\p@} - -\long\def\@makefntext#1{\parindent 1em\noindent - \hbox to 1.8em{\hss$^{\@thefnmark}$}#1} - - -\setcounter{topnumber}{2} -\def\topfraction{.7} -\setcounter{bottomnumber}{1} -\def\bottomfraction{.3} -\setcounter{totalnumber}{3} -\def\textfraction{.2} -\def\floatpagefraction{.5} -\setcounter{dbltopnumber}{2} -\def\dbltopfraction{.7} -\def\dblfloatpagefraction{.5} - -\long\def\@makecaption#1#2{ - \vskip 10pt - \setbox\@tempboxa\hbox{#1: #2} - \ifdim \wd\@tempboxa >\hsize #1: #2\par \else \hbox -to\hsize{\hfil\box\@tempboxa\hfil} - \fi} - - -\newcounter{figure} -\def\thefigure{\@arabic\c@figure} -\def\fps@figure{tbp} -\def\ftype@figure{1} -\def\ext@figure{lof} -\def\fnum@figure{Figure \thefigure} -\def\figure{\@float{figure}} -\let\endfigure\end@float -\@namedef{figure*}{\@dblfloat{figure}} -\@namedef{endfigure*}{\end@dblfloat} -\newcounter{table} -\def\thetable{\@arabic\c@table} -\def\fps@table{tbp} -\def\ftype@table{2} -\def\ext@table{lot} -\def\fnum@table{Table \thetable} -\def\table{\@float{table}} -\let\endtable\end@float -\@namedef{table*}{\@dblfloat{table}} -\@namedef{endtable*}{\end@dblfloat} - - -\def\maketitle{\par - \begingroup - \def\thefootnote{\fnsymbol{footnote}} - \def\@makefnmark{\hbox - to 0pt{$^{\@thefnmark}$\hss}} - \if@twocolumn - \twocolumn[\@maketitle] - \else \newpage - \global\@topnum\z@ \@maketitle \fi\thispagestyle{plain}\@thanks - \endgroup - \setcounter{footnote}{0} - \let\maketitle\relax - \let\@maketitle\relax - \gdef\@thanks{}\gdef\@author{}\gdef\@title{}\let\thanks\relax} -\def\@maketitle{\newpage - \null - \vskip 2em \begin{center} - {\@title \par} \vskip 1.5em {\normalsize \lineskip .5em -\begin{tabular}[t]{c}\@author - \end{tabular}\par} - \par - \vskip 1.5em} -\def\abstract{\if@twocolumn -\section*{Abstract} -\else \small -\begin{center} -{\normalsize\bf Abstract\vspace{-.5em}\vspace{0pt}} -\end{center} -\quotation -\fi} -\def\endabstract{\if@twocolumn\else\endquotation\fi} - -\mark{{}{}} - -\if@twoside \def\ps@headings{\let\@mkboth\markboth -\def\@oddfoot{}\def\@evenfoot{}\def\@evenhead{\rm \thepage\hfil \sl -\leftmark}\def\@oddhead{\hbox{}\sl \rightmark \hfil -\rm\thepage}\def\sectionmark##1{\markboth -{\uppercase{\ifnum \c@secnumdepth ->\z@ - \thesection\hskip 1em\relax \fi ##1}}{}} -\def\subsectionmark##1{\markright -{\ifnum \c@secnumdepth >\@ne - \thesubsection\hskip 1em\relax \fi ##1}}} -\else \def\ps@headings{\let\@mkboth\markboth -\def\@oddfoot{}\def\@evenfoot{}\def\@oddhead{\hbox {} -\sl \rightmark \hfil -\rm\thepage}\def\sectionmark##1{\markright -{\uppercase{\ifnum \c@secnumdepth ->\z@ - \thesection\hskip 1em\relax \fi ##1}}}} -\fi -%\def\ps@myheadings{\let\@mkboth\@gobbletwo -%\def\@oddhead{\hbox{}\sl\rightmark \hfil -%\rm\thepage}\def\@oddfoot{}\def\@evenhead{\rm -%\thepage\hfil\sl\leftmark\hbox -%{}}\def\@evenfoot{}\def\sectionmark##1{}\def\subsectionmark##1{}} -\def\ps@myheadings{\let\@mkboth\@gobbletwo -\def\@oddhead{\hbox{}\hfil -\rm\thepage\hfil}\def\@oddfoot{}\def\@evenhead{\hfil\rm -\thepage\hfil\hbox -{}}\def\@evenfoot{}\def\sectionmark##1{}\def\subsectionmark##1{}} - -\def\today{\ifcase\month\or - January\or February\or March\or April\or May\or June\or - July\or August\or September\or October\or November\or December\fi - \space\number\day, \number\year} - -\ps@plain \pagenumbering{arabic} \onecolumn -\if@twoside\else\raggedbottom\fi
deleted file mode 100644 --- a/libcruft/fsqp/manual.tex +++ /dev/null @@ -1,2774 +0,0 @@ -\input macros.tex -\documentstyle[12pt]{manual} -\pagestyle{myheadings} -\markboth{User's Guide for FSQP}{User's Guide for FSQP} -\renewcommand{\baselinestretch}{1.08} % more interline spacing - \textheight=8.3in -\topmargin=-.2in -\textwidth=6.5in -\oddsidemargin=-.15cm -\tolerance=1000 % to avoid overfull boxes - \pagenumbering{arabic} -\begin{document} -\thispagestyle{empty} -\begin{titlepage} -\begin{center} -{\large \bf User's Guide for FSQP Version 3.2:\\ -\vspace{1mm} - A FORTRAN Code for Solving Constrained Nonlinear \\ -\vspace{1mm} - (Minimax) Optimization Problems, Generating Iterates \\ -\vspace{1mm} - Satisfying All Inequality and Linear Constraints\footnote{ -This research was supported in part by NSF's Engineering Research Centers -Program No. NSFD-CDR-88-03012, by NSF grant No. DMC-88-15996 and by a grant -from the Westinghouse Corporation.}}\\ -\vspace{4mm} - {\it Jian L. Zhou and Andr\'{e} L. Tits} \\ -\vspace{4mm} - Electrical Engineering Department\\ - and\\ - Institute for Systems Research\\ - University of Maryland, College Park, MD 20742\\ - (Systems Research Center TR-92-107r2) -\end{center} -\vspace{3mm} -\noindent{\bf Abstract} -\vspace{1em} - -\hspace{4mm}FSQP 3.2 is a set of FORTRAN subroutines -for the minimization of the maximum of a set of smooth -objective functions (possibly a single one) subject to -general smooth constraints. -If the initial guess provided by the user is infeasible for -some inequality constraint or some linear equality constraint, FSQP first -generates a feasible point for these constraints; -subsequently the successive iterates generated by -FSQP all satisfy these constraints. Nonlinear equality constraints -are turned into inequality constraints (to be satisfied by all iterates) -and the maximum of the objective functions is replaced -by an exact penalty function which -penalizes nonlinear equality constraint violations only. -The user has the option of either -requiring that the (modified) objective function decrease -at each iteration after feasibility for nonlinear inequality and -linear constraints has been reached (monotone line search), or -requiring a decrease within at most four iterations (nonmonotone line search). -He/She must provide subroutines that define the objective functions -and constraint functions and may either provide subroutines -to compute the gradients of these functions or require that FSQP -estimate them by forward finite differences. - -\hspace{4mm} FSQP 3.2 implements two algorithms based on Sequential -Quadratic Programming~(SQP),~modified so as to generate -feasible iterates. In the first one (monotone line search), a certain -Armijo type arc search is used with the property that the step of one -is eventually accepted, a requirement for superlinear convergence. -In the second one the same effect is achieved by means -of a (nonmonotone) search along a straight line. The merit function -used in both searches is the maximum of the objective functions if -there is no nonlinear equality constraint. -\end{titlepage} - -\begin{titlepage} -\centerline{\bf Conditions for External Use} -\bigskip -\begin{enumerate} -\item The FSQP routines may not be distributed to third parties. - Interested parties should contact the authors directly. -\item If modifications are performed on the routines, these - modifications will be communicated to the authors. - The modified routines will remain - the sole property of the authors. -\item Due acknowledgment must be made of the use of the FSQP routines in - research reports or publications. A copy of such reports or - publications should be forwarded to the authors. -\item The FSQP routines may not be used in industrial production, - unless this has been agreed upon with the authors in writing. -\end{enumerate} - -\bigskip\noindent -{\bf User's Guide for FSQP Version 3.2 (Released March 1993)} \\ -Copyright {\copyright} 1989 --- 1993 by Jian L. Zhou and Andr\'e L. Tits\\ -All Rights Reserved. -%Copyright {\copyright} 1993, University of Maryland at College Park. -%All Rights Reserved. \\ -%(Developed by Jian L. Zhou and Andr\'e L. Tits.) - -\bigskip -\bigskip -\noindent Enquiries should be directed to - -\bigskip -\hspace{5em}Prof. Andr\'e L. Tits - -\hspace{5em}Electrical Engineering Dept. - -\hspace{5em}and Institute for Systems Research - -\hspace{5em}University of Maryland - -\hspace{5em}College Park, Md 20742 - -\hspace{5em}U. S. A. - -\smallskip -\hspace{5em}Phone$\,\,$:~~~301-405-3669 - -\hspace{5em}Fax~~~$\,\;$:~~~301-405-6707 - -\hspace{5em}E-mail$\,$:~~~andre@src.umd.edu -\end{titlepage} - -%\begin{titlepage} -\tableofcontents -%\end{titlepage} - -\newpage -\section{Introduction} -\label{intro} -FSQP~(Feasible Sequential Quadratic Programming) 3.2 -is a set of FORTRAN subroutines -for the minimization of the maximum of a set of smooth -objective functions (possibly a single one) subject to -nonlinear equality and inequality constraints, -linear equality and inequality constraints, -and simple bounds on the variables. Specifically, FSQP -tackles optimization problems of the form -\smallskip -$$ - (P)~~~~~~ \min ~ \max\limits_{i\in I^f} \{f_i(x)\} - \mbox{~~~s.t.~~}x\in X -$$ -where $I^f=\{1,\ldots,n_f\}$ and $X$ is the set of point $x\in R^n$ -satisfying -$$\begin{array}{l} - bl \leq x \leq bu \\ - g_j(x) \leq 0,~~~j=1,\ldots,n_i\\ - g_j(x)\equiv \langle c_{j-n_i},x\rangle - d_{j-n_i} \leq 0, - ~~~j=n_i+1,\ldots,t_i \\ - h_j(x)=0,~~~j=1,\ldots,n_e\\ - h_j(x)\equiv\langle a_{j-n_e},x \rangle-b_{j-n_e}=0, ~~~j=n_e+1,\ldots,t_ -e -\end{array}$$ -with $bl\in R^n$; $bu\in R^n$; -$f_i:R^n\rightarrow R,$ $i=1,\ldots,n_f$ smooth; -$g_j:R^n\rightarrow R,~j=1,\ldots,n_i$ nonlinear and smooth; -$c_j\in R^n$, $d_j\in R$, $j=1,\ldots,t_i-n_i$; -$h_j:R^n\rightarrow R,~j=1,\ldots,n_e$ nonlinear and smooth; -$a_j\in R^n$, $b_j\in R$, $j=1,\ldots,t_e-n_e$. - -If the initial guess provided by the user is infeasible for nonlinear -inequality constraints and linear constraints, FSQP first -generates a point satisfying all these constraints -by iterating on the problem of minimizing -the maximum of these constraints. Then, -using Mayne-Polak's scheme\Lspace \Lcitemark 1\Rcitemark \Rspace{}, -nonlinear equality constraints are turned into -inequality constraints\footnote{For every $j$ for which $h_j(x_0)>0$ -($x_0$ is the initial point), ``$h_j(x)=0$'' is first replaced by -``$-h_j(x)=0$'' and $-h_j$ is renamed $h_j$.} -$$h_j(x)\leq 0,~~~~j=1,\ldots,n_e$$ -and the original objective function $\max_{i\in I^f}\{f_i(x)\}$ -is replaced by the modified objective function -$$f_m(x,p)=\max\limits_{i\in I^f}\{f_i(x)\}-\sum_{j=1}^{n_e}p_jh_j(x),$$ -where $p_j$, $j=1,\ldots,n_e$, are positive penalty parameters -and are iteratively adjusted. -The resulting optimization problem therefore involves only -linear constraints and nonlinear inequality constraints. -Subsequently, the successive iterates generated by -FSQP all satisfy these constraints. The user has the option of -either requiring that the exact penalty function -(the maximum value of the objective functions if without nonlinear equality -constraints) decrease at each iteration after feasibility for -original nonlinear inequality and linear constraints has been reached, -or requiring a decrease within at most three iterations. -He/She must provide subroutines that define the objective functions -and constraint functions and may either provide subroutines -to compute the gradients of these functions or require that FSQP -estimate them by forward finite differences. - -Thus, FSQP 3.2 solves the original problem with nonlinear equality constraints -by solving a modified optimization problem with only linear constraints -and nonlinear inequality constraints. For the transformed problem, -it implements algorithms that are described -and analyzed in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -\Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \Rspace{}, w -ith some additional refinements. -These algorithms are based on a Sequential Quadratic Programming~(SQP) -iteration, modified so as to generate feasible iterates. -The merit function is the objective function. -An Armijo-type line search is used to generate an initial feasible point -when required. -After obtaining feasibility, either $(i)$ an Armijo-type line -search may be used, yielding a monotone decrease of the -objective function at each iteration\Lspace \Lcitemark 2\Rcitemark \Rspace{}; -or $(ii)$ a nonmonotone line -search (inspired from\Lspace \Lcitemark 5\Rcitemark \Rspace{} and analyzed -in\Lspace \Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \R -space{} in this context) -may be selected, forcing a decrease of -the objective function within at most four iterations. -In the monotone line search scheme, the SQP direction is first -``tilted'' if nonlinear constraints are present -to yield a feasible direction, then possibly ``bent'' to ensure -that close to a solution the step of one is accepted, -a requirement for superlinear convergence. -The nonmonotone line search scheme achieves superlinear convergence -with no bending of the search direction, thus avoiding function -evaluations at auxiliary points and subsequent solution of -an additional quadratic program. After turning nonlinear equality -constraints into inequality constraints, these algorithms are -used directly to solve the modified problems. Certain procedures -(see, e.g.,\Lspace \Lcitemark 6\Rcitemark \Rspace{}) -are adopted to obtain proper values of $p_j$'s in order to -ensure that a solution of the modified problem is also a solution -of the original problem, as described below. - -For the solution of the quadratic programming subproblems, FSQP 3.2 -is set up to call QLD\Lspace \Lcitemark 7\Rcitemark \Rspace{} which is provided - -with the FSQP distribution for the user's convenience. - -\section{Description of the Algorithms} -\label{algo} -The algorithms described and analyzed -in\Lspace \Lcitemark 2\Rcitemark \Rspace{},\Lspace \Lcitemark 3\Rcitemark \Rspa -ce{} -and\Lspace \Lcitemark 4\Rcitemark \Rspace{} are as follows. -Given a feasible iterate $x$, the basic SQP direction -$d^0$ is first computed by solving a standard quadratic program -using a positive definite estimate $H$ of -the Hessian of the Lagrangian. -$d^0$ is a direction of descent for the objective function; it is -almost feasible in the sense that it is at worst tangent to -the feasible set if there are nonlinear constraints and it is feasible -otherwise. - -In\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -an essentially arbitrary feasible descent direction $d^1=d^{1}(x)$ is -then computed. Then for a certain -scalar $\rho =\rho (x)\in [0,1]$, a feasible descent -direction $d=(1-\rho)d^0+\rho d^1$ is obtained, asymptotically -close to $d^0.$ Finally a second order -correction $\tilde d=\tilde{d}(x,d,H)$ is computed, involving -auxiliary function evaluations at $x+d,$ -and an Armijo type search is performed along the -arc $x+td+t^2 \tilde d.$ -The purpose of $\tilde d$ is to allow a full step of one to be taken -close to a solution, thus allowing superlinear convergence to -take place. Conditions are given -in\Lspace \Lcitemark 2\Rcitemark \Rspace{} on -$d^{1}(\cdot)$, $\rho(\cdot)$ and $\tilde d(\cdot ,\cdot)$ -that result in a globally convergent, -locally superlinear convergent algorithm. - -The algorithm in\Lspace \Lcitemark 3\Rcitemark \Rspace{} is somewhat -more sophisticated. An essential difference is that while feasibility -is still required, the requirement of decrease of the max objective -value is replaced by the weaker requirement that the max -objective value at the new point be lower than its maximum over the last -four iterates. The main payoff is that the auxiliary function -evaluations -can be dispensed with, except possibly at the first few iterations. -First a direction $d^1=d^1(x)$ is computed, which is feasible even at -Karush-Kuhn-Tucker points. Then for a certain -scalar $\rho ^{\ell} =\rho ^{\ell}(x)\in [0,1],$ -a ``local'' feasible -direction $d ^{\ell}=(1-\rho ^{\ell})d^0+\rho ^{\ell}d^1$ is obtained, -and at $x+d^{\ell}$ the objective functions are tested -and feasibility is -checked. If the requirements pointed out above are satisfied, $x+d^\ell$ -is accepted as next iterate. This will always be the case close to a -solution. Whenever $x+d^\ell$ is not accepted, a ``global'' -feasible {\it descent} -direction $d ^g=(1-\rho ^g)d^0+\rho ^gd^1$ is obtained with -$\rho ^g =\rho ^g(x)\in [0,\rho ^{\ell}].$ -A second order correction $\tilde d=\tilde{d}(x,d^g,H)$ is computed -the same way as in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -and a ``nonmonotone'' search is performed along the -arc $x+td^g+t^2 \tilde d.$ -Here the purpose of $\tilde d$ -is to suitably initialize the sequence for the ``four iterate'' rule. -Conditions are given in\Lspace \Lcitemark 3\Rcitemark \Rspace{} on -$d^{1}(\cdot)$, $\rho ^{\ell}(\cdot)$, $\rho ^g(\cdot)$, -and $\tilde d(\cdot ,\cdot)$ that result in a -globally convergent, locally superlinear convergent algorithm. -In\Lspace \Lcitemark 4\Rcitemark \Rspace{}, the algorithm of\Lspace \Lcitemark -3\Rcitemark \Rspace{} is refined -for the case of unconstrained minimax problems. -The major difference over the algorithm of\Lspace \Lcitemark 3\Rcitemark \Rspac -e{} -is that there is no need of $d^1$. -As in\Lspace \Lcitemark 3\Rcitemark \Rspace{}, $\tilde d$ is required to initia -lize superlinear -convergence. - -The FSQP implementation corresponds to a specific choice of -$d^1(\cdot)$, $\rho(\cdot)$, $\tilde{d}(\cdot,\cdot)$, -$\rho^\ell(\cdot)$, and $\rho^g(\cdot)$, -with some modifications as follows. If the first algorithm -is used, $d^1$ is computed as -a function not only of $x$ but also of $d^0$~(thus of $H$), as it -appears beneficial to keep $d^1$ relatively close to $d^0$. -In the case of the second algorithm, the construction -of $d^{\ell}$ is modified so that the function -evaluations at different auxiliary points can -be avoided during early iteration -when $\rho ^g\neq \rho ^{\ell}$; -the quadratic program that yields $\tilde{d}$ involves only a -subset of ``active'' functions, thus decreasing the number -of function evaluations. -The details are given below. -The analysis in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -\Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \Rspace{} -can be easily extended to these modified algorithms. -Also obvious simplifications are introduced concerning -linear constraints: the iterates are allowed (for inequality constraints) -or are forced (for equality constraints) to stay -on the boundary of these constraints and these constraints -are not checked in the line search. Finally, FSQP automatically switches to -a ``phase 1'' mode if the initial guess provided by -the user is not in the feasible set. - -Below we call FSQP-AL -the algorithm with the Armijo line search, and FSQP-NL the algorithm -with nonmonotone line search. We make use of the notations -$$f_{I^f}(x)=\max\limits _{i\in I^f} \{f_i(x)\}$$ -$$f'(x,d,p)=\max\limits_{i\in I^f}\{f_i(x)+ - \langle \nabla f_i(x),d\rangle\} - f_{I^f}(x) - -\sum\limits_{j=1}^{n_e}p_j\langle\nabla h_j(x),d\rangle$$ -and, for any subset $I\subset I^f$, -$$\tilde {f}'_I(x+d,x,\tilde d,p)=\max\limits_{i\in I}\{f_i(x+d)+ - \langle \nabla f_i(x),\tilde d\rangle\} - f_{I}(x+d) - -\sum\limits_{j=1}^{n_e}p_j\langle\nabla h_j(x),\tilde d\rangle.$$ -At each iteration $k$, the quadratic program $QP(x_k,H_k,p_k)$ that yields -the SQP direction $d^0_k$ is defined -at $x_k$ for $H_k$ symmetric positive definite by -\smallskip -$$\begin{array}{ll} - \min\limits_{d^0\in R^n}~~ & {1 \over {2}}\langle {d^0},H_k {d^0} - \rangle+f'(x_k,d^0,p_k) \\ - {\rm ~~s.t.} & bl \leq x_k+d^0 \leq bu \\ - & g_j(x_k)+\langle\nabla g_j(x_k),d^0 \rangle - \leq 0, ~~~j=1,\ldots , t_i \\ - & h_j(x_k)+\langle\nabla h_j(x_k),d^0 \rangle - \leq 0, ~~~j=1,\ldots ,n_e \\ - & \langle a_j,x_k + d^0 \rangle=b_j, - ~~~j=1,\ldots , t_e-n_e. \end{array}$$ -Let $\zeta _{k,j}$'s with $\sum_{j=1}^{n_f} \zeta _{k,j} =1$, -$\xi_{k,j}$'s, $\lambda _{k,j}$'s, and $\mu_{k,j}$'s denote -the multipliers, for the various objective functions, simple -bounds (only $n$ possible active bounds at each iteration), inequality, -and equality constraints respectively, associated -with this quadratic program. -Define the set of active objective functions, -for any $i$ such that $\zeta_{k,i}>0$, by -$$ -I^f_k(d_k)=\{j\in I^f: |f_j(x_k)-f_i(x_k)|\leq -0.2\|d_k\|\cdot\|\nabla f_j(x_k)-\nabla f_i(x_k)\|\} -\cup\{j\in I^f:\zeta_{k,j}>0\} -$$ -and the set of active constraints by -$$ -I^g_k(d_k)\!=\!\{j\!\in\!\{1,\ldots,t_i\}:|g_j(x_k)|\leq -0.2\|d_k\|\cdot\|\nabla g_j(x_k)\|\} -\cup\{j\in\{1,\ldots,t_i\}:\lambda_{k,j}>0\}. -$$ - -\vspace{1em} -\noindent{\bf Algorithm FSQP-AL.} - -\vspace{1em} -\noindent{\it Parameters.} $\eta =0.1$, $\nu=0.01$, $\alpha=0.1$, -$\beta=0.5$, $\kappa = 2.1$, $\tau _1=\tau _2 = 2.5$, $\underline t=0.1$, -$\epsilon_1=1$, $\epsilon_2=10$, $\delta=5$. - -\smallskip -\noindent{\it Data.} $x_0\in R^n$, $\epsilon > 0$, $\epsilon_e>0$ and -$p_{0,j}=\epsilon_2$ for $j=1,\ldots,n_e$. - -\smallskip -\noindent{\it Step 0: Initialization.} Set $k=0$ and $H_0=$ the -identity matrix. Set $nset=0$. If $x_0$ is infeasible for some constraint -other than a nonlinear equality constraint, -substitute a feasible point, obtained as discussed below. -For $j=1,\ldots,n_e$, replace $h_j(x)$ by $-h_j(x)$ whenever -$h_j(x_0)>0$. - -\smallskip -\noindent{\it Step 1: Computation of a search arc.} - -\begin{itemize} -\item[\it i.]Compute $d_{k}^{0}$, the solution of the quadratic program -$QP(x_k,H_k,p_k)$. -If $\|d_k^0\|\leq \epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq \epsilon_e$, stop. -If $n_i+n_e=0$ and $n_f=1,$ set $d_k=d^0_k$ and $\tilde d_k =0$ and -go to {\it Step~2}. If $n_i+n_e=0$ and $n_f > 1$, set $d_k=d^0_k$ and -go to {\it Step~1~iv}. - -\item[\it ii.]Compute $d_{k}^{1}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{ll} \min\limits_{d^1\in R^n,\gamma \in R} - & \frac{\eta}{2} - \langle d_{k}^{0}-d^1,d_{k}^{0}-d^1 \rangle +\gamma \\ - {\rm ~~~~s.t.} & bl \leq x_k+d^1 \leq bu\\ - & f'(x_k,d^1,p_k) \leq \gamma\\ - & g_j(x_k)+\langle \nabla g_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_i\\ - & \langle c_j,x_k + d^1 \rangle \leq d_j, - ~~~~j=1,\ldots,t_i-n_i \\ - & h_j(x_k)+\langle \nabla h_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k + d^1 \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -\smallskip -\item[\it iii.] Set $d_k=(1-\rho_k)d_k^0+\rho_kd_k^1$~ - with $\rho_k=\|d_k^0\|^{\kappa}/(\|d_k^0\|^{\kappa}+v_k)$,~ - where $v_k = \max(0.5,~\|d_k^1\|^{\tau _1}).$ - -\item[\it iv.] -Compute $\tilde d_k$ by solving the strictly convex -quadratic program -\smallskip -$$\begin{array}{ll} \min\limits_{\tilde d \in R^n} & \frac{1}{2} - \langle (d_k+\tilde d),H_{k}(d_k+\tilde d)\rangle - +f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k) \\ - {\rm ~s.t.} & bl \leq x_k+d_k+\tilde d \leq bu\\ - & g_j(x_k+d_k) +\langle \nabla g_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k\|,~\|d_k\|^{\tau _2}),~ - j\in I^g_k(d_k)\cap\{j:j\leq n_i\}\\ -% & \hspace{20em} j\in I^g_k(d_k)\cap\{j:j\leq n_i\}\\ - & \langle c_{j-n_i},x_k+d_k + \tilde d \rangle \leq d_{j-n_i}, - ~~~~j\in I^g_k(d_k)\cap\{j:j>n_i\}\\ - & h_j(x_k+d_k) +\langle \nabla h_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k\|,~\|d_k\|^{\tau _2}),~j=1,\ldots,n_e\\ - & \langle a_j,x_k+d_k + \tilde d \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -where $f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k)=f'(x_k,d_k+\tilde d,p_k)$ -if $n_f = 1,$ and -$f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k)=\tilde{f}'_{I^f_k(d_k)}(x_k+d_k,x_k,\til -de d,p_k)$ -if $n_f > 1$. -If the quadratic program has no solution or -if $\|\tilde d_k\|>\|d_{k}\|$, set $\tilde d_k=0$. -\end{itemize} - -\noindent{\it Step 2. Arc search.} -Let $\delta _k=f'(x_k,d_k,p_k)$ if $n_i+n_e\ne 0$ -and $\delta _k=-\langle d_k^0,H_kd_k^0\rangle$ otherwise. -Compute $t_{k}$, the first number $t$ in -the sequence $\mbox\{1,\beta,\beta^{2},\ldots\}$ satisfying -\begin{eqnarray*} -\textstyle -& f_m(x_{k}+td_{k}+t^{2}\tilde d_{k},p_k)\leq f_m(x_k,p_k)+\alpha t\delta_k & \ -\ -& g_j(x_k+td_k+t^2\tilde d_k)\leq0,~~j=1,\ldots,n_i & \\ -&\langle c_{j-n_i},x_k+td_k + t^2\tilde{d}_k \rangle \leq d_{j-n_i}, - ~~~~\forall j>n_i~\&~j\not\in I^g_k(d_k)\\ -&h_j(x_k+td_k+t^2\tilde d_k)\leq0,~~j=1,\ldots,n_e. & -\end{eqnarray*} -Specifically, the line search proceeds as follows. -First, the linear constraints that were not used -in computing $\tilde{d}_k$ are checked until all of them are -satisfied, resulting in a stepsize, say, $\bar{t}_k$. Due to -the convexity of linear constraints, these constraints -will be satisfied for any $t\leq \bar{t}_k$. Then, for $t=\bar{t}_k$, -nonlinear constraints are checked first and, -for both objectives and constraints, those with nonzero -multipliers in the QP yielding $d^0_k$ are evaluated first. -For $t<\bar{t}_k$, the function that caused the previous value of $t$ to -be rejected is checked first; all functions of the same type -(``objective'' or ``constraint'') as the latter -will then be checked first. - -\smallskip -\smallskip -\noindent{\it Step 3. Updates.} -\begin{itemize} -\item[$\cdot$] If $nset>5n$ and $t_k<\underline t$, set $H_{k+1}=H_0$ -and $nset=0$. -Otherwise, set $nset=nset+1$ and compute a new approximation $H_{k+1}$ -to the Hessian of the Lagrangian using the BFGS formula with Powell's -modification\Lspace \Lcitemark 8\Rcitemark \Rspace{}. -\item[$\cdot$] Set $x_{k+1}=x_{k}+t_{k}d_{k}+t_{k}^{2}\tilde d_{k}$. -\item[$\cdot$] Solve the unconstrained -quadratic problem in $\bar{\mu}$ -$$\begin{array}{cl} -\min\limits_{\bar{\mu}\in R^{t_e}} & -\|\sum\limits_{j=1}^{n_f}\zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda_{k,j}\nabla g_j(x_k) - +\sum\limits_{j=1}^{t_e}\bar{\mu}_j\nabla h_j(x_k)\|^2, -\end{array}$$ -where the $\zeta_{k,j}$'s, $\xi_k$ and the $\lambda_{k,j}$'s -are the multipliers associated with $QP(x_k,H_k,p_k)$ for the objective -functions, variable bounds, and inequality constraints -respectively.\footnote{This is a refinement (saving much computation -and memory) of the scheme proposed in\Lspace \Lcitemark 1\Rcitemark \Rspace{}.} -Update $p_k$ as follows: for $j=1,\ldots,n_e$, -$$p_{k+1,j}=\left\{\begin{array}{ll} -p_{k,j} & \mbox{if } p_{k,j}+\bar\mu_j \geq \epsilon_1\\ -\max\{\epsilon_1-\bar\mu_j,~\delta p_{k,j}\} & \mbox{otherwise.} -\end{array}\right.$$ -\item[$\cdot$] Increase $k$ by 1. -\item[$\cdot$] Go back to {\it Step 1}. -\end{itemize} - -\hfill{\large \bf $\Box$} - -\vspace{1em} -\noindent{\bf Algorithm FSQP-NL.} - -\vspace{1em} -\noindent{\it Parameters.} $\eta =3.0$, $\nu=0.01$, -$\alpha=0.1$, $\beta=0.5$, $\theta=0.2$, $\bar{\rho}=0.5$, $\gamma = 2.5$, -$\underline{C}=0.01$, $\underline{d}=5.0$, $\underline t=0.1$, -$\epsilon_1=0.1$, $\epsilon_2=10$, $\delta=5$. - -\smallskip -\noindent{\it Data.} $x_0\in R^n$, $\epsilon > 0$, $\epsilon_e>0$ and -$p_{0,j}=\epsilon_2$ for $j=1, \ldots, n_e$. - -\smallskip -\noindent{\it Step 0: Initialization.} Set $k=0$, $H_0=$ the identity -matrix, and $C_0 = \underline{C}.$ If $x_0$ is infeasible for -constraints other than nonlinear equality constraints, substitute a -feasible point, obtained as discussed below. -Set $x_{-3}=x_{-2}=x_{-1}=x_0$ and $nset=0$. -For $j=1,\ldots,n_e$, replace $h_j(x)$ by $-h_j(x)$ whenever -$h_j(x_0)>0$. - -\smallskip -\noindent{\it Step 1: Computation of a new iterate.} - -\begin{itemize} -\item[\it ~~~i.] Compute $d_{k}^{0}$, the solution of quadratic program -$QP(x_k,H_k,p_k)$. -%Compute the Kuhn-Tucker vector -%$$\begin{array}{lll} -%\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)& = & -%\sum\limits_{j=1}^{n_f} \zeta _{k,j}\nabla f_j(x_k)+ -%\sum\limits_{j=1}^{n} \xi _{k,j}+\sum\limits_{j=1}^{t_i} -% \lambda _{k,j}\nabla g_j(x_k) \\ -%& & ~~~+\sum\limits_{j=1}^{n_e}(\mu_{k,j}-p_{k,j})\nabla h_j(x_k) -% +\sum\limits_{j=n_e+1}^{t_e}\mu_{k,j}\nabla h_j(x_k).\end{array}$$ - -%If $\|\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)\|\leq \epsilon$ -If $\|d_k^0\|\leq \epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq\epsilon_e$, stop. -If $n_i+n_e=0$ and $n_f=1,$ set $d_k=d^0_k$ and $\tilde d_k =0$ and -go to {\it Step~1~viii}. If $n_i+n_e=0$ and $n_f >1,$ -set $\rho _k^{\ell}=\rho _k^g=0$ and go to {\it Step~1~v}. - -\item[\it ~~ii.] Compute $d_{k}^{1}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{ll} \min\limits_{d^1\in R^n,\gamma \in R} - & \frac{\eta}{2}\|d^1\|^2+\gamma \\ - {\rm ~~~~s.t.} & bl \leq x_k+d^1 \leq bu\\ - & g_j(x_k)+\langle \nabla g_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_i\\ - & \langle c_j,x_k + d^1 \rangle \leq d_j, - ~~~~j=1,\ldots,t_i-n_i \\ - & h_j(x_k)+\langle \nabla h_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k + d^1 \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ - -\item[\it ~iii.] Set $v_{k}=\min \{C_k\|d^0_k\|^2,\|d^0_k\|\}$. -Define values -$\rho^g_{k,j}$ for $j=1,\ldots,n_i$ by $\rho^g_{k,j}$ equal to zero if -\smallskip -$$g_j(x_k)+\langle \nabla g_j(x_k),d^0_k\rangle \leq -v_k$$ -\smallskip -or equal to the maximum $\rho$ in $[0,1]$ such that -\smallskip -$$g_j(x_k)+\langle \nabla g_j(x_k),(1-\rho)d^0_k+ - \rho d^1_k\rangle \geq -v_k$$ -\smallskip -otherwise. Similarly, define values $\rho^h_{k,j}$ for $j=1,\ldots,n_e$. -Let $$\rho ^{\ell}_k=\max\left\{\max _{j=1,\ldots,n_i}\{\rho^g_{k,j}\},~ -\max _{j=1,\ldots,n_e}\{\rho^h_{k,j}\}\right\}.$$ - -\item[\it ~~iv.] Define $\rho _k^g$ as the largest number $\rho$ -in $[0,\rho ^{\ell}_k]$ such that -\smallskip -$$f'(x_k,(1-\rho)d^0_k+\rho d^1_k,p_k)\leq \theta f'(x_k,d^0_k,p_k).$$ -If ($k\geq 1$ \& $t_{k-1}<1$) or ($\rho _k^{\ell} > \bar{\rho}$), set -$\rho _k^\ell = \min \{\rho _k^\ell, \rho _k^g\}.$ - -\item[\it ~~~v.] Construct a ``local'' direction -\smallskip -$$d_k^{\ell}=(1-\rho _k^{\ell})d^0_k+\rho _k^{\ell} d^1_k.$$ -Set $M=3$, $\delta_k=f'(x_k,d_k^0)$ if $n_i+n_e\ne 0$, -and $M=2$, $\delta_k=-\langle d_k^0,H_kd_k^0\rangle$ otherwise. -If -$$f_m(x_k+d^{\ell}_k,p_k)\leq -\max\limits_{\ell=0,\ldots,M}\{f_m(x_{k-\ell},p_k)\} + - \alpha \delta_k$$ -$$g_j(x_k+d^{\ell}_k)\leq 0,~~j=1,\ldots,n_i$$ -and -$$h_j(x_k+d^{\ell}_k)\leq 0,~~j=1,\ldots,n_e,$$ -\smallskip -set $t_k=1$, $x_{k+1}=x_k+d_k^{\ell}$ and go to {\it Step 2}. - -\item[\it ~~vi.] Construct a ``global'' direction -\smallskip -$$d_k^{g}=(1-\rho _k^{g})d^0_k+\rho _k^{g}d^1_k.$$ - -\item[\it ~vii.] -Compute $\tilde d_{k}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{cl} \min\limits_{\tilde d \in R^n} & \frac{1}{2} - \langle (d_k^g+\tilde d),H_{k}(d^g_k+\tilde d)\rangle - +f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k) \\ - \mbox{s.t.} & bl \leq x_k+d_k^g+\tilde d \leq bu\\ - & g_j(x_k+d_k^g) +\langle \nabla g_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k^g\|,~\|d_k^g\|^{\tau}), - ~~~j\in I^g_k(d^g_k)\cap\{j:j\leq n_i\}\\ - & \langle c_{j-n_i},x_k+d_k^g + \tilde d \rangle \leq d_{j-n_i}, - ~~~~j\in I^g_k(d^g_k)\cap\{j:j>n_i\}\\ - & h_j(x_k+d_k^g) +\langle \nabla h_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k^g\|,~\|d_k^g\|^{\tau}), - ~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k+d_k^g + \tilde d \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -where $f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k)=f'(x_k,d_k^g+\tilde d,p_k)$ if - $n_f=1,$ -and $f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k)= -\tilde{f}'_{I^f_k(d_k^g)}(x_k+d_k^g,x_k,\tilde d,p_k)$ -if $n_f>1$. If the quadratic program has no solution or -if $\|\tilde d_k\|>\|d_k^g\|$, set $\tilde d_k=0$. - -\item[\it viii.] Set $M=3$, $\delta_k=f'(x_k,d^g_k,p_k)$ if $n_i+n_e\ne 0$, -and $M=2$, $\delta_k=-\langle d^g_k,H_kd^g_k\rangle$ otherwise. -Compute $t_k$, the first number $t$ in -the sequence $\mbox\{1,\beta,\beta^{2},\ldots\}$ satisfying -\smallskip -\begin{eqnarray*} -\textstyle -& f_m(x_{k}+td^g_k+t^{2}\tilde d_k,p_k)\leq - \max\limits_{\ell=0,\ldots,M}\{f_m(x_{k-\ell},p_k)\}+ -\alpha t \delta_k &\\ -& g_{j}(x_{k}+td_k^g+t^{2}\tilde d_{k})\leq0,~~j=1,\ldots,n_i & \\ -&\langle c_{j-n_i},x_k+td_k^g +t^2 \tilde{d}_k \rangle \leq d_{j-n_i}, - ~~~~j>n_i~\&~j\not\in I^g_k(d^g_k) &\\ -& h_{j}(x_{k}+td_k^g+t^{2}\tilde d_{k})\leq0,~~j=1,\ldots,n_e & -\end{eqnarray*} -and set $x_{k+1}=x_k+t_kd_k^g+t_k^2\tilde d_k.$ \\ -Specifically, the line search proceeds as follows. -First, the linear constraints that were not used -in computing $\tilde{d}_k$ are checked until all of them are -satisfied, resulting in a stepsize, say, $\bar{t}_k$. Due to -the convexity of linear constraints, these constraints -will be satisfied for any $t\leq \bar{t}_k$. Then, for $t=\bar{t}_k$, -nonlinear constraints are checked first and, -for both objectives and constraints, those with nonzero -multipliers in the QP yielding $d^0_k$ are evaluated first. -For $t<\bar{t}_k$, the function that caused the previous value of $t$ to -be rejected is checked first; all functions of the same type -(``objective'' or ``constraint'') as the latter -will then be checked first. -\end{itemize} - -\noindent{\it Step 2. Updates.} -\begin{itemize} -\item[$\cdot$] If $nset>5n$ and $t_k<\underline t$, set $H_{k+1}=H_0$ -and $nset=0$. Otherwise, set $nset=nset+1$ and -compute a new approximation $H_{k+1}$ -to the Hessian of the Lagrangian using the BFGS formula with Powell's -modification\Lcitemark 8\Rcitemark . -\item[$\cdot$] If $\|d^0_k\|>\underline{d}$, -set $C_{k+1}=\max \{0.5C_k,\underline{C}\}.$ -Otherwise, if $g_j(x_k+d_k^\ell) \leq 0,~~j=1,\ldots,n_i$, -set $C_{k+1}=C_k$. Otherwise, set $C_{k+1}=10C_k$. -\item[$\cdot$] Solve the unconstrained -quadratic problem in $\bar{\mu}$ -$$\begin{array}{cl} -\min\limits_{\bar{\mu}\in R^{t_e}} & -\|\sum\limits_{j=1}^{n_f}\zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda_{k,j}\nabla g_j(x_k) - +\sum\limits_{j=1}^{t_e}\bar{\mu}_j\nabla h_j(x_k)\|^2, -\end{array}$$ -where the $\zeta_{k,j}$'s, $\xi_k$ and the $\lambda_{k,j}$'s -are the multipliers associated with $QP(x_k,H_k,p_k)$ for the objective -functions, variable bounds, and inequality constraints -respectively.\footnote{See footnote to corresponding step in description -of FSQP-AL.} - -Update $p_k$ as follows: for $j=1,\ldots,n_e$, -$$p_{k+1,j}=\left\{\begin{array}{ll} -p_{k,j} & \mbox{if } p_{k,j}+\bar\mu_j \geq \epsilon_1\\ -\max\{\epsilon_1-\bar\mu_j,~\delta p_{k,j}\} & \mbox{otherwise.} -\end{array}\right.$$ -\item[$\cdot$] Increase $k$ by 1. -\item[$\cdot$] Go back to {\it Step 1}. -\end{itemize} - -\hfill{\large \bf $\Box$} - -\noindent{\bf Remark:} The Hessian matrix is reset -in both algorithms whenever stepsize is too small and -the updating of the matrix goes through $n$ iterations. -This is helpful in some situations where the Hessian matrix -becomes singular. - -\vspace{1em} -If the initial guess $x_0$ provided by the user is not feasible -for some inequality constraint or some linear equality constraint, -FSQP first solves a strictly convex quadratic program -\smallskip -$$\begin{array}{cl} - \min\limits_{v\in R^n} & \langle v,v\rangle \\ - \mbox{s.t.} & bl \leq x_0+v \leq bu\\ - & \langle c_j,x_0 + v \rangle \leq d_j, - ~~~j=1,\ldots,t_i-n_i\\ - & \langle a_j,x_0 + v \rangle=b_j, - ~~~j=1,\ldots,t_e-n_e. \end{array}$$ - -\vspace{.5em} -\noindent{}Then, starting from the point $x=x_0+v$, it will iterate, -using algorithm FSQP-AL, on the problem -\smallskip -$$\begin{array}{cl} - \min\limits_{x\in R^n} & \max\limits_{j=1,\ldots,n_i}\{g_j(x)\} \\ - \mbox{s.t.} & ~~bl \leq x \leq bu\\ - & ~~\langle c_j,x\rangle \leq d_j,~~~j=1,\ldots,t_i-n_i\\ - & ~~\langle a_j,x \rangle =b_j,~~~j=1,\ldots , t_e-n_e - \end{array}$$ -until $\max\limits_{j=1,\ldots,n_i}\{g_j(x)\} \leq 0$ is achieved. -The corresponding iterate $x$ will then be feasible -for all constraints other than nonlinear equality constraints of -the original problem. - -\section{Specification of Subroutine FSQPD 3.2} -\label{specs} -Only a double precision version of FSQP, FSQPD is currently available. -The specification of FSQPD is as follows: -\vspace{1em} -\begin{quote} -\begin{verbatim} - subroutine FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint,miter, - * inform,bigbnd,eps,epseqn,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj,constr,gradob,gradcn) - integer nparam,nf,nineqn,nineq,neqn,neq,mode,iprint,miter,inform, - * iwsize,nwsize - integer iw(iwsize) - double precision bigbnd,eps,epseqn,udelta - double precision bl(nparam),bu(nparam),x(nparam), - * f(nf),g(nineq+neq),w(nwsize) - external obj,constr,gradob,gradcn -\end{verbatim} -\end{quote} -\vspace{1em} -{\bf Important:} all real variables and arrays must be declared as -double precision in the routine that calls FSQPD. The following are -specifications of parameters and workspace. - -\vspace{1em} -\begin{description} -\item[\tt nparam] {\bf (Input)}~Number of free variables, - i.e., the dimension of {\tt x}. -\item[\tt nf] {\bf (Input)}~Number of objective - functions ($n_f$ in the algorithm description). -\item[\tt nineqn] {\bf (Input)}~Number (possibly zero) of - nonlinear inequality constraints ($n_i$ in the - algorithm description). -\item[\tt nineq] {\bf (Input)}~Total number (possibly equal - to {\tt nineqn}) of - inequality constraints ($t_i$ in the algorithm - description). -\item[\tt neqn] {\bf (Input)}~Number (possibly zero) of - nonlinear equality constraints ($n_e$ in the - algorithm description). -\item[\tt neq] {\bf (Input)}~Total number (possibly equal to {\tt neqn}) of - equality constraints ($t_e$ in the algorithm - description). -\item[\tt mode] {\bf (Input)}~${\tt mode} = 1BA$ with the following - meanings: - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[${\tt A} = 0$~:~~] $(P)$ is to be solved. - \item[${\tt A} = 1$~:~~] $(PL_\infty)$ is to be solved. - $(PL_\infty)$ is defined as follows -$$ - (PL_\infty)~~~~~ \min ~ \max\limits_{i\in I^f} |f_i(x)| - \mbox{~~~s.t.~~}x\in X -$$ - where $X$ is the same as for $(P).$ It is handled - in this code by splitting $|f_i(x)|$ as $f_i(x)$ - and $-f_i(x)$ for each $i.$ The user is required - to provide only $f_i(x)$ for $i\in I^f$. - \item[${\tt B} = 0$~:~~]Algorithm FSQP-AL is - selected, resulting in a - decrease of the (modified) objective - - function at each iteration. - \item[${\tt B} = 1$~:~~]Algorithm FSQP-NL is - selected, resulting in a - decrease of the (modified) objective - function within at - most four iterations (or three - iterations, see Algorithm FSQP-NL). - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt iprint] {\bf (Input)}~Parameter indicating the - desired output (see \S~\ref{output} for details): - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[~~${\tt iprint} =0$~:~~] No information except - for user-input errors is displayed. This value - is imposed during phase 1. - \item[~~${\tt iprint} =1$~:~~] - Objective and constraint values - at the initial feasible point are displayed. - At the end of execution, status ({\tt inform}), - iterate, objective values, constraint values, - number of evaluations of objectives and - nonlinear constraints, norm of the Kuhn-Tucker - vector, and sum of feasibility violation - are displayed. - \item[~~${\tt iprint} =2$~:~~] At the end of each - iteration, the same information as with - ${\tt iprint}=1$ is displayed. - \item[~~${\tt iprint} =3$~:~~] At each iteration, - the same information as with ${\tt iprint}=2$, - including detailed information on the search - direction computation, on the line search, - and on the update, is displayed. - \item[~~${\tt iprint} =10*N+M,~N~{\rm any~positive~integer}, - M=2~{\rm or}~3$~:~~] - Information corresponding to {\tt iprint}=$M$ - is displayed at every $(10\times N)$th - iteration and at the last iteration. - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt miter] {\bf (Input)}~Maximum number of iterations -allowed by the user before termination of execution. -\item[\tt inform] {\bf (Output)}~Parameter indicating the status of - the execution of FSQPD: - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[~~${\tt inform} = 0$~:~] Normal termination of - execution in the sense that - $\|d^0\|\leq {\tt eps}$ - and (if ${\tt neqn} \ne 0$) - $\sum_{j=1}^{n_e}|h_j(x)|\leq {\tt epseqn}$. - \item[~~${\tt inform} = 1$~:~] The user-provided - initial guess - is infeasible for - linear constraints and - FSQPD is unable to - generate a point - satisfying all these - constraints. - \item[~~${\tt inform} = 2$~:~] The user-provided - initial guess - is infeasible for nonlinear - inequality constraints and - linear constraints; and - FSQPD is unable to - generate a point - satisfying all these - constraints. - \item[~~${\tt inform} = 3$~:~] The maximum - number~{\tt miter} - of iterations has been - reached before a - solution is obtained. - \item[~~${\tt inform} = 4$~:~] The line search fails - to find a new - iterate (trial step size - being - smaller than the machine - precision - {\tt epsmac} computed by FSQPD). - \item[~~${\tt inform} = 5$~:~] Failure of the QP solver - in attempting - to construct $d^0$. A more - robust QP solver may succeed. - \item[~~${\tt inform} = 6$~:~] Failure of the QP solver - in attempting - to construct $d^1$. A more - robust QP solver may succeed. - \item[~~${\tt inform} = 7$~:~] Input data are not - consistent~(with - printout - indicating the error). - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt bigbnd] {\bf (Input)}~(see also {\tt bl} - and {\tt bu} below)~It plays the role of - Infinite Bound. -\item[\tt eps] {\bf (Input)}~Final norm requirement for -% the Kuhn-Tucker vector ($\epsilon$ in the - the Newton direction $d_k^0$ ($\epsilon$ in the - algorithm description). It must be bigger - than the machine - precision {\tt epsmac} (computed by FSQPD). - (If the user does not have a good feeling of - what value should be chosen, a very small - number could be provided and $\mbox{\tt iprint}=2$ - be selected so that the user would be able to keep track of - the process of optimization and terminate FSQPD - at appropriate time.) -\item[\tt epseqn] {\bf (Input)}~Maximum violation of nonlinear equality - constraints allowed by the user at an optimal point - ($\epsilon_e$ in the algorithm description). - It is in effect only if $n_e\ne 0$ and - must be bigger than the machine - precision {\tt epsmac} (computed by FSQPD). -\item[\tt udelta] {\bf (Input)}~The perturbation - size the user suggests to use in - approximating gradients by finite difference. - The perturbation size actually used is defined by -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times \max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} - is the square root of {\tt epsmac}). {\tt udelta} - should be set to zero if the user has no idea - how to choose it. -\item[\tt bl] {\bf (Input)}~Array of - dimension {\tt nparam} containing - lower bounds for the components of {\tt x}. - To specify a non-existent lower - bound (i.e., ${\tt bl}(j)=-\infty$ for - some $j$), the value used must - satisfy ${\tt bl}(j)\leq -{\tt bigbnd}$. -\item[\tt bu] {\bf (Input)}~Array of - dimension {\tt nparam} containing - upper bounds for the components of {\tt x}. - To specify a non-existent upper - bound (i.e., ${\tt bu}(j)=\infty$ for - some $j$), the value used must - satisfy ${\tt bu}(j)\geq {\tt bigbnd}$. -\item[\tt x] {\bf (Input)}~Initial guess.\\ - {\bf (Output)}~Iterate at the end of execution. -\item[\tt f] Array of dimension $\max\{1, {\tt nf}\}$.\\ - {\bf (Output)}~Value of functions - $f_i,i=1,\ldots,n_f$, at {\tt x} at the end of - execution. -\item[\tt g] Array of dimension $\max\{1,{\tt nineq}+{\tt neq}\}$.\\ - {\bf (Output)}~Values of constraints at {\tt x} at - the end of execution. -\item[\tt iw] Workspace vector of dimension {\tt iwsize}. -\item[\tt iwsize] {\bf (Input)}~Workspace length - for {\tt iw}. It must be at least as big as - $6\times {\tt nparam}+8\times ({\tt nineq}+{\tt neq}) - +7\times{\tt nf}+30$. This estimate is usually very conservative - and the smallest suitable value will be - displayed if the user-supplied value is too small. -\item[\tt w] {\bf (Input)}~Workspace of dimension {\tt nwsize}. \\ - {\bf (Output)}~Estimate of Lagrange multipliers at - the end of execution of phase 2 in the - first ${\tt nparam}+{\tt nineq+neq+nff}$ entries; - where ${\tt nff}=0$ if (in {\tt mode}) ${\tt A}=0$ and - ${\tt nf}=1$, and ${\tt nff}={\tt nf}$ otherwise. - They are ordered as $\xi$'s (variables), $\lambda$'s (inequality - constraints), $\mu$'s (equality constraints), and $\zeta$ - (objective functions). - $\lambda _j \geq 0~~\forall j=1,\ldots,t_i$ - and $\mu _j \ge 0~~\forall j=1,\ldots,t_e.$ $\xi _i > 0$ - indicates that $x_i$ reaches its upper bound and $\xi _i <0$ - indicates that $x_i$ reaches its lower bound. When - (in {\tt mode}) ${\tt A}=0$ and ${\tt nf}>1$, $\zeta _i \geq0.$ - When ${\tt B}=1$, $\zeta _i >0$ refers to - $+f_i(x)$ and $\zeta _i<0$ to $-f_i(x)$. -\item[\tt nwsize] {\bf (Input)}~Workspace length for {\tt w}. - It must be at least as big as - $4\times {\tt nparam}^{2}+ - 5\times ({\tt nineq}+{\tt neq})\times{\tt nparam}+ - 3\times{\tt nf}\times{\tt nparam}+ - 26\times ({\tt nparam}+{\tt nf})+45\times ({\tt nineq}+{\tt neq})+100$ -. This estimate - is usually very conservative and the - smallest suitable value will be - displayed if the user-supplied value is too small. -\item[\tt obj] {\bf (Input)}~Name of the user-defined subroutine - that computes the value of the objective - functions $f_i(x),~~\forall i=1,\ldots,n_f.$ This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The detailed specification is given in \S~\ref{subobj} below. -\item[\tt constr] {\bf (Input)}~Name of the user-defined subroutine - that computes the value of the constraints. This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The detailed specification is given in \S~\ref{subconstr} below. -\item[\tt gradob] {\bf (Input)}~Name of the subroutine that - computes the gradients of the objective - functions $f_i(x),~~\forall i=1,\ldots,n_f.$ This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The user must pass the subroutine name - {\tt grobfd}~(and declare it as {\bf external}), - if he/she wishes that FSQPD evaluate - these gradients automatically, by forward finite differences. - The detailed specification is given in \S~\ref{subgradob} below. -\item[\tt gradcn] {\bf (Input)}~Name of the subroutine that - computes the gradients of the constraints. - This name must be declared as {\bf external} in the calling - routine and passed as an argument to FSQPD. - The user must pass the subroutine name {\tt grcnfd}~(and - declare it as {\bf external}), if he/she wishes that - FSQPD evaluate these gradients automatically, - by forward finite differences. - The detailed specification is given in \S~\ref{subgradcn} below. -\end{description} - -\section{User-Accessible Stopping Criterion} -\label{stopcri} -As is clear from the two algorithms, the optimization process -normally terminates if both -$\|d_k^0\|\leq\epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq\epsilon_e$ are satisfied. -Very small value of either of these two parameters may request -exceedingly long execution time, depending on the complexity -of underlying problem and the nonlinearity of various functions. -FSQP allows users to specify their own stopping criterion in any one of -the four user-supplied subroutines mentioned above via the following -common block -\begin{verbatim} - integer nstop - common /fsqpst/nstop -\end{verbatim} -if (s)he wishes to. -${\tt nstop}=0$ should be returned to FSQP when the stopping criterion -is satisfied. FSQP will check the value of {\tt nstop} at appropriate places -during the optimization process and will terminate when -either the user's criterion or the default criterion is satisfied. - -\section{Description of the Output} -\label{output} -No output will be displayed before a feasible starting -point is obtained. The following information is displayed -at the end of execution when -${\tt iprint} = 1$ or at each iteration when ${\tt iprint}=2$: -\begin{description} -\item[\tt iteration] Total number of iterations (${\tt iprint}=1$) or - iteration number (${\tt iprint}=2$). -\item[\tt inform] See \S~\ref{specs}. It is displayed only - at the end of execution. -\item[\tt x] Iterate. -\item[\tt objectives] Value of objective functions $f_i(x),~~\forall - i=1,\ldots,n_f$ at {\tt x}. -\item[\tt objmax] (displayed only if $\mbox{\tt nf} > 1$)~The - maximum value of the set of objective - functions (i.e., $\max f_i(x) \mbox{ or } \max |f_i(x)|,~~ - \forall i=1,\ldots,n_f$) at {\tt x}. -\item[\tt objective max4] (displayed only if $\mbox{\tt B} = 1$ - in {\tt mode})~Largest value of - the maximum of the objective functions over the - last four (or three, see FSQP-NL) - iterations (including the current one). -\item[\tt constraints] Values of the constraints at {\tt x}. -\item[\tt ncallf] Number of evaluations (so far) of - individual~(scalar) objective function $f_i(x)$ - for $1\leq i \leq n_f.$ -\item[\tt ncallg] Number of evaluations (so far) of - individual~(scalar) nonlinear constraints. -\item[\tt d0norm] Norm of the Newton direction $d_k^0$. -\item[\tt ktnorm] Norm of the Kuhn-Tucker vector at the current - iteration. The Kuhn-Tucker vector is given by -$$\begin{array}{lll} -\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)& = & -\sum\limits_{j=1}^{n_f} \zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda _{k,j}\nabla g_j(x_k) \\ -& &~+\sum\limits_{j=1}^{n_e}(\mu_{k,j}-p_{k,j})\nabla h_j(x_k) - +\sum\limits_{j=n_e+1}^{t_e}\mu_{k,j}\nabla h_j(x_k).\end{array}$$ -\item[\tt SCV] Sum of the violation of nonlinear equality constraints -at a solution. -\end{description} - -{\noindent}For ${\tt iprint}=3$, in addition to the same - information as the one for ${\tt iprint}=2$, - the following is printed at every iteration. - -\vspace{1em} -Details in the computation of a search direction: -\begin{description} -\item[\tt d0] Quasi-Newton direction $d^0_k$. -\item[\tt d1] First order direction $d^1_k$. -\item[\tt d1norm] Norm of $d^1_k$. -\item[\tt d] (${\tt B}=0$ in {\tt mode})~Feasible descent - direction $d_k=(1-\rho _k)d^0_k+\rho _k d^1_k$. -\item[\tt dnorm] (${\tt B}=0$ in {\tt mode})~Norm of $d_k$. -\item[\tt rho] (${\tt B}=0$ in {\tt mode})~Coefficient $\rho_k$ in - constructing $d_k$. -\item[\tt dl] (${\tt B}=1$ in {\tt mode})~Local direction - $d^\ell_k=(1-\rho^\ell_k)d_k^0+\rho^\ell_kd^1_k$. -\item[\tt dlnorm] (${\tt B}=1$ in {\tt mode})~Norm of $d_k^\ell$. -\item[\tt rhol] (${\tt B}=1$ in {\tt mode})~Coefficient $\rho_k^{\ell}$ in - constructing $d_k^{\ell}$. -\item[\tt dg] (${\tt B}=1$ in {\tt mode})~Global search direction - $d^g=(1-\rho^g_k)d_k^0+\rho^g_kd^1_k$. -\item[\tt dgnorm] (${\tt B}=1$ in {\tt mode})~Norm of $d_k^g$. -\item[\tt rhog] (${\tt B}=1$ in {\tt mode})~Coefficient $\rho_k^g$ in - constructing $d_k^g$. -\item[\tt dtilde] Second order correction $\tilde d_k$. -\item[\tt dtnorm] Norm of $\tilde d_k$. -\end{description} - -Details in the line search: -\begin{description} -\item[\tt trial step] Trial steplength $t$ in the search direction. -\item[\tt trial point] Trial iterate along the search arc - with {\tt trial step}. -\item[\tt trial objectives] This gives the indices $i$ and - the corresponding - values of the functions - $f_i(x)-\sum_{j=1}^{n_e}p_jh_j(x)$ - for $1\leq i \leq n_f$ up to the one which fails - in line search at the {\tt trial point}. The - indices $i$ - are not necessarily in the natural order (see - remark at the end of {\it Step 2} in FSQP-AL and of - the end of {\it Step~1~viii}\ in FSQP-NL). -\item[\tt trial constraints] This gives the indices $j$ and the - corresponding values of nonlinear constraints - for $1\leq j \leq n_i+n_e$ up to the - one which is not feasible at the {\tt trial point}. - The indices $j$ - are not necessarily in the natural order (see - remark at the end of {\it Step 2} in FSQP-AL and of - the end of {\it Step~1~viii}\ in FSQP-NL). -\end{description} - -Details in the updates: -\begin{description} -\item[\tt delta] Perturbation size for each variable - in finite difference gradients computation. -\item[\tt gradf] Gradients of - functions $f_i(x),~\forall i=1,\ldots,n_f,$ - at the new iterate. -\item[\tt gradg] Gradients of constraints at the new iterate. -\item[\tt p] Penalty parameters for nonlinear equality constraints at - the new iterate. -\item[\tt multipliers] Multiplier estimates ordered as $\xi$'s, - $\lambda$'s, $\mu$'s, and $\zeta$'s (from quadratic program - computing $d^0_k$). $\lambda _j \geq 0~~\forall j=1,\ldots,t_i$ - and $\mu _j \ge 0~~\forall j=1,\ldots,t_e$. $\xi _i > 0$ - indicates that $x_i$ reaches its upper bound and $\xi _i <0$ - indicates that $x_i$ reaches its lower bound. When - (in {\tt mode}) ${\tt A}=0$ and ${\tt nf}>1$, $\zeta _i \geq0$. - When (in {\tt mode}) ${\tt A}=1$, $\zeta _i >0$ refers to - $+f_i(x)$ and $\zeta _i<0$ to $-f_i(x)$. - (cf.\ \S~\ref{specs} under item {\tt w}.) -\item[\tt hess] Estimate of the Hessian matrix of the Lagrangian. -\item[\tt Ck] The value $C_k$ as defined in Algorithm FSQP-NL. -\end{description} - -\section{User-Supplied Subroutines} -At least two of the following four Fortran 77 subroutines, -namely {\tt obj} and {\tt constr}, -must be provided by the user in order to define the problem. -The name of all four routines can be changed at the user's will, -as they are passed as arguments to FSQPD. - -\subsection{Subroutine obj} -\label{subobj} -The subroutine {\bf obj}, to be provided by the user, -computes the value of the objective functions. -A (dummy) subroutine must be provided due to Fortran 77 compiling -requirement if $\mbox{\tt nf}=0$ (This may happen when the user -is only interested in finding a feasible point). -The specification of {\bf obj} for FSQPD is -\begin{quote} -\begin{verbatim} - subroutine obj(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj - c - c for given j, assign to fj the value of the jth objective - c evaluated at x - c - return - end -\end{verbatim} -\end{quote} -\noindent Arguments: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of the objective to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt fj] {\bf (Output)}~Value of the {\tt j}th objective function - at {\tt x}. -\end{description} - -\subsection{Subroutine constr} -\label{subconstr} -The subroutine {\bf constr}, to be provided by the user, -computes the value of -the constraints. If there are no constraints, -a (dummy) subroutine must be -provided anyway due to Fortran 77 compiling requirement. -The specification of {\tt constr} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine constr(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj - c - c for given j, assign to gj the value of the jth constraint - c evaluated at x - c - return - end -\end{verbatim} -\end{quote} -\noindent Arguments: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of the constraint to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gj] {\bf (Output)}~Value of the {\tt j}th constraint at {\tt x}. -\end{description} -\bigskip -The order of the constraints must be as follows. -First the {\tt nineqn} (possibly zero) nonlinear inequality constraints. -Then the ${\tt nineq-nineqn}$ (possibly zero) linear inequality constraints. -Finally, the {\tt neqn} (possibly zero) nonlinear equality constraints -followed by the ${\tt neq-neqn}$ (possibly zero) linear equality constraints. - -\subsection{Subroutine gradob} -\label{subgradob} -The subroutine {\bf gradob} computes the gradients of the -objective functions. -The user may omit to provide this routine and require that -forward finite difference -approximation be used by FSQPD via calling {\tt grobfd} instead~ -(see argument {\tt gradob} of FSQPD in \S~\ref{specs}). -The specification of {\tt gradob} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine gradob(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision x(nparam),gradfj(nparam) - double precision dummy - external dummy -c -c assign to gradfj the gradient of the jth objective function -c evaluated at x -c - return - end -\end{verbatim} -\end{quote} -\noindent{Arguments}: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of objective for - which gradient is to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gradfj] {\bf (Output)}~Gradient of the {\tt j}th objective - function at x. -\item[\tt dummy] {\bf (Input)}~Used by {\tt grobfd}. -\end{description} -Note that {\tt dummy} is -passed as arguments to {\tt gradob} to allow for forward finite -difference computation of the gradient. - -\subsection{Subroutine gradcn} -\label{subgradcn} -The subroutine {\bf gradcn} computes the gradients of the constraints. -The user may omit to provide this routine and require that forward -finite difference approximation be used by FSQPD via -calling {\tt grcnfd} instead (see argument {\tt gradcn} of -FSQPD in \S~\ref{specs}). -The specification of {\tt gradcn} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine gradcn (nparam,j,x,gradgj,dummy) - integer nparam,j - double precision x(nparam),gradgj(nparam) - double precision dummy - external dummy -c -c assign to gradgj the gradient of the jth constraint -c evaluated at x -c - return - end -\end{verbatim} -\end{quote} -\noindent{Arguments}: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of constraint for which - gradient is to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gradgj] {\bf (Output)}~Gradient of the {\tt j}th - constraint evaluated at {\tt x}. -\item[\tt dummy] {\bf (Input)}~Used by {\tt grcnfd}. -\end{description} - -\noindent Note that {\tt dummy} is passed as arguments -to {\tt gradcn} to allow for forward finite difference -computation of the gradients. - -\section{Organization of FSQPD and Main Subroutines} -\subsection{Main Subroutines} -\label{mainorg} -FSQPD first checks for inconsistencies of input parameters using the -subroutine {\tt check}. It then checks if the starting -point given by the user satisfies the linear -constraints and if not, generates a point -satisfying these constraints using -subroutine {\tt initpt}. It then calls FSQPD1 for generating a point -satisfying linear and nonlinear inequality constraints. Finally, -it attempts to find -a point satisfying the optimality condition using again FSQPD1. -\begin{description} -\item[\tt check] Check that all upper bounds on variables - are no smaller than lower bounds; - check that all input integers are nonnegative - and appropriate (${\tt nineq} \geq {\tt nineqn}$, etc.); - and check that {\tt eps} ($\epsilon$) - and (if ${\tt neqn}\ne 0$) {\tt epseqn} - ($\epsilon_e$) are at least as large as - the machine precision {\tt epsmac} (computed by FSQPD). -\item[\tt initpt] Attempt to generate a feasible point satisfying - simple bounds and all linear constraints. -\item[\tt FSQPD1] Main subroutine used possibly twice by FSQPD, - first for generating - a feasible iterate as explained at the - end of \S~\ref{algo} and - second for generating an optimal iterate - from that feasible iterate. -\end{description} -FSQPD1 uses the following subroutines: -\begin{description} -\item[\tt dir] Compute various directions $d_k^0$, $d^1_0$ and $\tilde d_k$. -\item[\tt step]Compute a step size along a certain search direction. - It is also called to check if $x_k+d_k^\ell$ is acceptable - in {\it Step 1 v} of Algorithm FSQP-NL. -\item[\tt hesian] Perform the Hessian matrix updating. -\item[\tt out] Print the output for ${\tt iprint=1}$ - or ${\tt iprint}=2$. -\item[\tt grobfd] (optional)~Compute the gradient of an objective - function - by forward finite differences with mesh size equal to -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times\max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} is the - square root of {\tt epsmac}, the machine - precision computed by FSQPD). -\item[\tt grcnfd] (optional)~Compute the gradient of a constraint by - forward finite differences with mesh size equal to -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times\max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} is the - square root of {\tt epsmac}, the machine - precision computed by FSQPD). -\end{description} - -\subsection{Other Subroutines} -\label{othsub} -In addition to QLD, the following subroutines are used: -\begin{verbatim} - diagnl di1 dqp error estlam fool fuscmp indexs matrcp - matrvc nullvc resign sbout1 sbout2 scaprd shift slope small -\end{verbatim} - -\subsection{Reserved Common Blocks} -\label{reserved} -The following named common blocks are used in FSQPD and QLD: -\begin{verbatim} - fsqpp1 fsqpp2 fsqpp3 fsqpq1 fsqpq2 fsqplo fsqpqp fsqpst CMACHE -\end{verbatim} - - -\input manua2 -\input macros.tex -\documentstyle[12pt]{manual} -\pagestyle{myheadings} -\markboth{User's Guide for FSQP}{User's Guide for FSQP} -\renewcommand{\baselinestretch}{1.08} % more interline spacing - \textheight=8.3in -\topmargin=-.2in -\textwidth=6.5in -\oddsidemargin=-.15cm -\tolerance=1000 % to avoid overfull boxes - \pagenumbering{arabic} -\begin{document} -\thispagestyle{empty} -\begin{titlepage} -\begin{center} -{\large \bf User's Guide for FSQP Version 3.1:\\ -\vspace{1mm} - A FORTRAN Code for Solving Constrained Nonlinear \\ -\vspace{1mm} - (Minimax) Optimization Problems, Generating Iterates \\ -\vspace{1mm} - Satisfying All Inequality and Linear Constraints\footnote{ -This research was supported in part by NSF's Engineering Research Centers -Program No. NSFD-CDR-88-03012, by NSF grant No. DMC-88-15996 and by a grant -from the Westinghouse Corporation.}}\\ -\vspace{4mm} - {\it Jian L. Zhou and Andr\'{e} L. Tits} \\ -\vspace{4mm} - Electrical Engineering Department\\ - and\\ - Institute for Systems Research\\ - University of Maryland, College Park, MD 20742\\ - (Systems Research Center TR-92-107r2) -\end{center} -\vspace{3mm} -\noindent{\bf Abstract} -\vspace{1em} - -\hspace{4mm}FSQP 3.1 is a set of FORTRAN subroutines -for the minimization of the maximum of a set of smooth -objective functions (possibly a single one) subject to -general smooth constraints. -If the initial guess provided by the user is infeasible for -some inequality constraint or some linear equality constraint, FSQP first -generates a feasible point for these constraints; -subsequently the successive iterates generated by -FSQP all satisfy these constraints. Nonlinear equality constraints -are turned into inequality constraints (to be satisfied by all iterates) -and the maximum of the objective functions is replaced -by an exact penalty function which -penalizes nonlinear equality constraint violations only. -The user has the option of either -requiring that the (modified) objective function decrease -at each iteration after feasibility for nonlinear inequality and -linear constraints has been reached (monotone line search), or -requiring a decrease within at most four iterations (nonmonotone line search). -He/She must provide subroutines that define the objective functions -and constraint functions and may either provide subroutines -to compute the gradients of these functions or require that FSQP -estimate them by forward finite differences. - -\hspace{4mm} FSQP 3.1 implements two algorithms based on Sequential -Quadratic Programming~(SQP),~modified so as to generate -feasible iterates. In the first one (monotone line search), a certain -Armijo type arc search is used with the property that the step of one -is eventually accepted, a requirement for superlinear convergence. -In the second one the same effect is achieved by means -of a (nonmonotone) search along a straight line. The merit function -used in both searches is the maximum of the objective functions if -there is no nonlinear equality constraint. -\end{titlepage} - -\begin{titlepage} -\centerline{\bf Conditions for External Use} -\bigskip -\begin{enumerate} -\item The FSQP routines may not be distributed to third parties. - Interested parties should contact the authors directly. -\item If modifications are performed on the routines, these - modifications will be communicated to the authors. - The modified routines will remain - the sole property of the authors. -\item Due acknowledgment must be made of the use of the FSQP routines in - research reports or publications. A copy of such reports or - publications should be forwarded to the authors. -\item The FSQP routines may not be used in industrial production, - unless this has been agreed upon with the authors in writing. -\end{enumerate} - -\bigskip\noindent -{\bf User's Guide for FSQP Version 3.1 (Released November 1992)} \\ -Copyright {\copyright} 1989 --- 1992 by Jian L. Zhou and Andr\'e L. Tits\\ -All Rights Reserved. -%Copyright {\copyright} 1992, University of Maryland at College Park. -%All Rights Reserved. \\ -%(Developed by Jian L. Zhou and Andr\'e L. Tits.) - -\bigskip -\bigskip -\noindent Enquiries should be directed to - -\bigskip -\hspace{5em}Prof. Andr\'e L. Tits - -\hspace{5em}Electrical Engineering Dept. - -\hspace{5em}and Institute for Systems Research - -\hspace{5em}University of Maryland - -\hspace{5em}College Park, Md 20742 - -\hspace{5em}U. S. A. - -\smallskip -\hspace{5em}Phone$\,\,$:~~~301-405-3669 - -\hspace{5em}Fax~~~$\,\;$:~~~301-405-6707 - -\hspace{5em}E-mail$\,$:~~~andre@src.umd.edu -\end{titlepage} - -%\begin{titlepage} -\tableofcontents -%\end{titlepage} - -\newpage -\section{Introduction} -FSQP~(Feasible Sequential Quadratic Programming) 3.1 -is a set of FORTRAN subroutines -for the minimization of the maximum of a set of smooth -objective functions (possibly a single one) subject to -nonlinear equality and inequality constraints, -linear equality and inequality constraints, -and simple bounds on the variables. Specifically, FSQP -tackles optimization problems of the form -\smallskip -$$ - (P)~~~~~~ \min ~ \max\limits_{i\in I^f} \{f_i(x)\} - \mbox{~~~s.t.~~}x\in X -$$ -where $I^f=\{1,\ldots,n_f\}$ and $X$ is the set of point $x\in R^n$ -satisfying -$$\begin{array}{l} - bl \leq x \leq bu \\ - g_j(x) \leq 0,~~~j=1,\ldots,n_i\\ - g_j(x)\equiv \langle c_{j-n_i},x\rangle - d_{j-n_i} \leq 0, - ~~~j=n_i+1,\ldots,t_i \\ - h_j(x)=0,~~~j=1,\ldots,n_e\\ - h_j(x)\equiv\langle a_{j-n_e},x \rangle-b_{j-n_e}=0, ~~~j=n_e+1,\ldots,t_ -e -\end{array}$$ -with $bl\in R^n$; $bu\in R^n$; -$f_i:R^n\rightarrow R,$ $i=1,\ldots,n_f$ smooth; -$g_j:R^n\rightarrow R,~j=1,\ldots,n_i$ nonlinear and smooth; -$c_j\in R^n$, $d_j\in R$, $j=1,\ldots,t_i-n_i$; -$h_j:R^n\rightarrow R,~j=1,\ldots,n_e$ nonlinear and smooth; -$a_j\in R^n$, $b_j\in R$, $j=1,\ldots,t_e-n_e$. - -If the initial guess provided by the user is infeasible for nonlinear -inequality constraints and linear constraints, FSQP first -generates a point satisfying all these constraints -by iterating on the problem of minimizing -the maximum of these constraints. Then, -using Mayne-Polak's scheme\Lspace \Lcitemark 1\Rcitemark \Rspace{}, -nonlinear equality constraints are turned into -inequality constraints\footnote{For every $j$ for which $h_j(x_0)>0$ -($x_0$ is the initial point), ``$h_j(x)=0$'' is first replaced by -``$-h_j(x)=0$'' and $-h_j$ is renamed $h_j$.} -$$h_j(x)\leq 0,~~~~j=1,\ldots,n_e$$ -and the original objective function $\max_{i\in I^f}\{f_i(x)\}$ -is replaced by the modified objective function -$$f_m(x,p)=\max\limits_{i\in I^f}\{f_i(x)\}-\sum_{j=1}^{n_e}p_jh_j(x),$$ -where $p_j$, $j=1,\ldots,n_e$, are positive penalty parameters -and are iteratively adjusted. -The resulting optimization problem therefore involves only -linear constraints and nonlinear inequality constraints. -Subsequently, the successive iterates generated by -FSQP all satisfy these constraints. The user has the option of -either requiring that the exact penalty function -(the maximum value of the objective functions if without nonlinear equality -constraints) decrease at each iteration after feasibility for -original nonlinear inequality and linear constraints has been reached, -or requiring a decrease within at most three iterations. -He/She must provide subroutines that define the objective functions -and constraint functions and may either provide subroutines -to compute the gradients of these functions or require that FSQP -estimate them by forward finite differences. - -Thus, FSQP 3.1 solves the original problem with nonlinear equality constraints -by solving a modified optimization problem with only linear constraints -and nonlinear inequality constraints. For the transformed problem, -it implements algorithms that are described -and analyzed in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -\Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \Rspace{}, w -ith some additional refinements. -These algorithms are based on a Sequential Quadratic Programming~(SQP) -iteration, modified so as to generate feasible iterates. -The merit function is the objective function. -An Armijo-type line search is used to generate an initial feasible point -when required. -After obtaining feasibility, either $(i)$ an Armijo-type line -search may be used, yielding a monotone decrease of the -objective function at each iteration\Lspace \Lcitemark 2\Rcitemark \Rspace{}; -or $(ii)$ a nonmonotone line -search (inspired from\Lspace \Lcitemark 5\Rcitemark \Rspace{} and analyzed -in\Lspace \Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \R -space{} in this context) -may be selected, forcing a decrease of -the objective function within at most four iterations. -In the monotone line search scheme, the SQP direction is first -``tilted'' if nonlinear constraints are present -to yield a feasible direction, then possibly ``bent'' to ensure -that close to a solution the step of one is accepted, -a requirement for superlinear convergence. -The nonmonotone line search scheme achieves superlinear convergence -with no bending of the search direction, thus avoiding function -evaluations at auxiliary points and subsequent solution of -an additional quadratic program. After turning nonlinear equality -constraints into inequality constraints, these algorithms are -used directly to solve the modified problems. Certain procedures -(see, e.g.,\Lspace \Lcitemark 6\Rcitemark \Rspace{}) -are adopted to obtain proper values of $p_j$'s in order to -ensure that a solution of the modified problem is also a solution -of the original problem, as described below. - -For the solution of the quadratic programming subproblems, FSQP 3.1 -is set up to call QLD\Lspace \Lcitemark 7\Rcitemark \Rspace{} which is provided - -with the FSQP distribution for the user's convenience. - -\section{Description of the Algorithms} -The algorithms described and analyzed -in\Lspace \Lcitemark 2\Rcitemark \Rspace{},\Lspace \Lcitemark 3\Rcitemark \Rspa -ce{} -and\Lspace \Lcitemark 4\Rcitemark \Rspace{} are as follows. -Given a feasible iterate $x$, the basic SQP direction -$d^0$ is first computed by solving a standard quadratic program -using a positive definite estimate $H$ of -the Hessian of the Lagrangian. -$d^0$ is a direction of descent for the objective function; it is -almost feasible in the sense that it is at worst tangent to -the feasible set if there are nonlinear constraints and it is feasible -otherwise. - -In\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -an essentially arbitrary feasible descent direction $d^1=d^{1}(x)$ is -then computed. Then for a certain -scalar $\rho =\rho (x)\in [0,1]$, a feasible descent -direction $d=(1-\rho)d^0+\rho d^1$ is obtained, asymptotically -close to $d^0.$ Finally a second order -correction $\tilde d=\tilde{d}(x,d,H)$ is computed, involving -auxiliary function evaluations at $x+d,$ -and an Armijo type search is performed along the -arc $x+td+t^2 \tilde d.$ -The purpose of $\tilde d$ is to allow a full step of one to be taken -close to a solution, thus allowing superlinear convergence to -take place. Conditions are given -in\Lspace \Lcitemark 2\Rcitemark \Rspace{} on -$d^{1}(\cdot)$, $\rho(\cdot)$ and $\tilde d(\cdot ,\cdot)$ -that result in a globally convergent, -locally superlinear convergent algorithm. - -The algorithm in\Lspace \Lcitemark 3\Rcitemark \Rspace{} is somewhat -more sophisticated. An essential difference is that while feasibility -is still required, the requirement of decrease of the max objective -value is replaced by the weaker requirement that the max -objective value at the new point be lower than its maximum over the last -four iterates. The main payoff is that the auxiliary function -evaluations -can be dispensed with, except possibly at the first few iterations. -First a direction $d^1=d^1(x)$ is computed, which is feasible even at -Karush-Kuhn-Tucker points. Then for a certain -scalar $\rho ^{\ell} =\rho ^{\ell}(x)\in [0,1],$ -a ``local'' feasible -direction $d ^{\ell}=(1-\rho ^{\ell})d^0+\rho ^{\ell}d^1$ is obtained, -and at $x+d^{\ell}$ the objective functions are tested -and feasibility is -checked. If the requirements pointed out above are satisfied, $x+d^\ell$ -is accepted as next iterate. This will always be the case close to a -solution. Whenever $x+d^\ell$ is not accepted, a ``global'' -feasible {\it descent} -direction $d ^g=(1-\rho ^g)d^0+\rho ^gd^1$ is obtained with -$\rho ^g =\rho ^g(x)\in [0,\rho ^{\ell}].$ -A second order correction $\tilde d=\tilde{d}(x,d^g,H)$ is computed -the same way as in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -and a ``nonmonotone'' search is performed along the -arc $x+td^g+t^2 \tilde d.$ -Here the purpose of $\tilde d$ -is to suitably initialize the sequence for the ``four iterate'' rule. -Conditions are given in\Lspace \Lcitemark 3\Rcitemark \Rspace{} on -$d^{1}(\cdot)$, $\rho ^{\ell}(\cdot)$, $\rho ^g(\cdot)$, -and $\tilde d(\cdot ,\cdot)$ that result in a -globally convergent, locally superlinear convergent algorithm. -In\Lspace \Lcitemark 4\Rcitemark \Rspace{}, the algorithm of\Lspace \Lcitemark -3\Rcitemark \Rspace{} is refined -for the case of unconstrained minimax problems. -The major difference over the algorithm of\Lspace \Lcitemark 3\Rcitemark \Rspac -e{} -is that there is no need of $d^1$. -As in\Lspace \Lcitemark 3\Rcitemark \Rspace{}, $\tilde d$ is required to initia -lize superlinear -convergence. - -The FSQP implementation corresponds to a specific choice of -$d^1(\cdot)$, $\rho(\cdot)$, $\tilde{d}(\cdot,\cdot)$, -$\rho^\ell(\cdot)$, and $\rho^g(\cdot)$, -with some modifications as follows. If the first algorithm -is used, $d^1$ is computed as -a function not only of $x$ but also of $d^0$~(thus of $H$), as it -appears beneficial to keep $d^1$ relatively close to $d^0$. -In the case of the second algorithm, the construction -of $d^{\ell}$ is modified so that the function -evaluations at different auxiliary points can -be avoided during early iteration -when $\rho ^g\neq \rho ^{\ell}$; -the quadratic program that yields $\tilde{d}$ involves only a -subset of ``active'' functions, thus decreasing the number -of function evaluations. -The details are given below. -The analysis in\Lspace \Lcitemark 2\Rcitemark \Rspace{}, -\Lcitemark 3\Rcitemark \Rspace{} and\Lspace \Lcitemark 4\Rcitemark \Rspace{} -can be easily extended to these modified algorithms. -Also obvious simplifications are introduced concerning -linear constraints: the iterates are allowed (for inequality constraints) -or are forced (for equality constraints) to stay -on the boundary of these constraints and these constraints -are not checked in the line search. Finally, FSQP automatically switches to -a ``phase 1'' mode if the initial guess provided by -the user is not in the feasible set. - -Below we call FSQP-AL -the algorithm with the Armijo line search, and FSQP-NL the algorithm -with nonmonotone line search. We make use of the notations -$$f_{I^f}(x)=\max\limits _{i\in I^f} \{f_i(x)\}$$ -$$f'(x,d,p)=\max\limits_{i\in I^f}\{f_i(x)+ - \langle \nabla f_i(x),d\rangle\} - f_{I^f}(x) - -\sum\limits_{j=1}^{n_e}p_j\langle\nabla h_j(x),d\rangle$$ -and, for any subset $I\subset I^f$, -$$\tilde {f}'_I(x+d,x,\tilde d,p)=\max\limits_{i\in I}\{f_i(x+d)+ - \langle \nabla f_i(x),\tilde d\rangle\} - f_{I}(x+d) - -\sum\limits_{j=1}^{n_e}p_j\langle\nabla h_j(x),\tilde d\rangle.$$ -At each iteration $k$, the quadratic program $QP(x_k,H_k,p_k)$ that yields -the SQP direction $d^0_k$ is defined -at $x_k$ for $H_k$ symmetric positive definite by -\smallskip -$$\begin{array}{ll} - \min\limits_{d^0\in R^n}~~ & {1 \over {2}}\langle {d^0},H_k {d^0} - \rangle+f'(x_k,d^0,p_k) \\ - {\rm ~~s.t.} & bl \leq x_k+d^0 \leq bu \\ - & g_j(x_k)+\langle\nabla g_j(x_k),d^0 \rangle - \leq 0, ~~~j=1,\ldots , t_i \\ - & h_j(x_k)+\langle\nabla h_j(x_k),d^0 \rangle - \leq 0, ~~~j=1,\ldots ,n_e \\ - & \langle a_j,x_k + d^0 \rangle=b_j, - ~~~j=1,\ldots , t_e-n_e. \end{array}$$ -Let $\zeta _{k,j}$'s with $\sum_{j=1}^{n_f} \zeta _{k,j} =1$, -$\xi_{k,j}$'s, $\lambda _{k,j}$'s, and $\mu_{k,j}$'s denote -the multipliers, for the various objective functions, simple -bounds (only $n$ possible active bounds at each iteration), inequality, -and equality constraints respectively, associated -with this quadratic program. -Define the set of active objective functions, -for any $i$ such that $\zeta_{k,i}>0$, by -$$ -I^f_k(d_k)=\{j\in I^f: |f_j(x_k)-f_i(x_k)|\leq -0.2\|d_k\|\cdot\|\nabla f_j(x_k)-\nabla f_i(x_k)\|\} -\cup\{j\in I^f:\zeta_{k,j}>0\} -$$ -and the set of active constraints by -$$ -I^g_k(d_k)\!=\!\{j\!\in\!\{1,\ldots,t_i\}:|g_j(x_k)|\leq -0.2\|d_k\|\cdot\|\nabla g_j(x_k)\|\} -\cup\{j\in\{1,\ldots,t_i\}:\lambda_{k,j}>0\}. -$$ - -\vspace{1em} -\noindent{\bf Algorithm FSQP-AL.} - -\vspace{1em} -\noindent{\it Parameters.} $\eta =0.1$, $\nu=0.01$, $\alpha=0.1$, -$\beta=0.5$, $\kappa = 2.1$, $\tau _1=\tau _2 = 2.5$, $\underline t=0.1$, -$\epsilon_1=1$, $\epsilon_2=10$, $\delta=5$. - -\smallskip -\noindent{\it Data.} $x_0\in R^n$, $\epsilon > 0$, $\epsilon_e>0$ and -$p_{0,j}=\epsilon_2$ for $j=1,\ldots,n_e$. - -\smallskip -\noindent{\it Step 0: Initialization.} Set $k=0$ and $H_0=$ the -identity matrix. Set $nset=0$. If $x_0$ is infeasible for some constraint -other than a nonlinear equality constraint, -substitute a feasible point, obtained as discussed below. -For $j=1,\ldots,n_e$, replace $h_j(x)$ by $-h_j(x)$ whenever -$h_j(x_0)>0$. - -\smallskip -\noindent{\it Step 1: Computation of a search arc.} - -\begin{itemize} -\item[\it i.]Compute $d_{k}^{0}$, the solution of the quadratic program -$QP(x_k,H_k,p_k)$. -If $\|d_k^0\|\leq \epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq \epsilon_e$, stop. -If $n_i+n_e=0$ and $n_f=1,$ set $d_k=d^0_k$ and $\tilde d_k =0$ and -go to {\it Step~2}. If $n_i+n_e=0$ and $n_f > 1$, set $d_k=d^0_k$ and -go to {\it Step~1~iv}. - -\item[\it ii.]Compute $d_{k}^{1}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{ll} \min\limits_{d^1\in R^n,\gamma \in R} - & \frac{\eta}{2} - \langle d_{k}^{0}-d^1,d_{k}^{0}-d^1 \rangle +\gamma \\ - {\rm ~~~~s.t.} & bl \leq x_k+d^1 \leq bu\\ - & f'(x_k,d^1,p_k) \leq \gamma\\ - & g_j(x_k)+\langle \nabla g_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_i\\ - & \langle c_j,x_k + d^1 \rangle \leq d_j, - ~~~~j=1,\ldots,t_i-n_i \\ - & h_j(x_k)+\langle \nabla h_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k + d^1 \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -\smallskip -\item[\it iii.] Set $d_k=(1-\rho_k)d_k^0+\rho_kd_k^1$~ - with $\rho_k=\|d_k^0\|^{\kappa}/(\|d_k^0\|^{\kappa}+v_k)$,~ - where $v_k = \max(0.5,~\|d_k^1\|^{\tau _1}).$ - -\item[\it iv.] -Compute $\tilde d_k$ by solving the strictly convex -quadratic program -\smallskip -$$\begin{array}{ll} \min\limits_{\tilde d \in R^n} & \frac{1}{2} - \langle (d_k+\tilde d),H_{k}(d_k+\tilde d)\rangle - +f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k) \\ - {\rm ~s.t.} & bl \leq x_k+d_k+\tilde d \leq bu\\ - & g_j(x_k+d_k) +\langle \nabla g_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k\|,~\|d_k\|^{\tau _2}),~ - j\in I^g_k(d_k)\cap\{j:j\leq n_i\}\\ -% & \hspace{20em} j\in I^g_k(d_k)\cap\{j:j\leq n_i\}\\ - & \langle c_{j-n_i},x_k+d_k + \tilde d \rangle \leq d_{j-n_i}, - ~~~~j\in I^g_k(d_k)\cap\{j:j>n_i\}\\ - & h_j(x_k+d_k) +\langle \nabla h_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k\|,~\|d_k\|^{\tau _2}),~j=1,\ldots,n_e\\ - & \langle a_j,x_k+d_k + \tilde d \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -where $f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k)=f'(x_k,d_k+\tilde d,p_k)$ -if $n_f = 1,$ and -$f'_{I^f_k(d_k)}(x_k,d_k,\tilde d,p_k)=\tilde{f}'_{I^f_k(d_k)}(x_k+d_k,x_k,\til -de d,p_k)$ -if $n_f > 1$. -If the quadratic program has no solution or -if $\|\tilde d_k\|>\|d_{k}\|$, set $\tilde d_k=0$. -\end{itemize} - -\noindent{\it Step 2. Arc search.} -Let $\delta _k=f'(x_k,d_k,p_k)$ if $n_i+n_e\ne 0$ -and $\delta _k=-\langle d_k^0,H_kd_k^0\rangle$ otherwise. -Compute $t_{k}$, the first number $t$ in -the sequence $\mbox\{1,\beta,\beta^{2},\ldots\}$ satisfying -\begin{eqnarray*} -\textstyle -& f_m(x_{k}+td_{k}+t^{2}\tilde d_{k},p_k)\leq f_m(x_k,p_k)+\alpha t\delta_k & \ -\ -& g_j(x_k+td_k+t^2\tilde d_k)\leq0,~~j=1,\ldots,n_i & \\ -&\langle c_{j-n_i},x_k+td_k + t^2\tilde{d}_k \rangle \leq d_{j-n_i}, - ~~~~\forall j>n_i~\&~j\not\in I^g_k(d_k)\\ -&h_j(x_k+td_k+t^2\tilde d_k)\leq0,~~j=1,\ldots,n_e. & -\end{eqnarray*} -Specifically, the line search proceeds as follows. -First, the linear constraints that were not used -in computing $\tilde{d}_k$ are checked until all of them are -satisfied, resulting in a stepsize, say, $\bar{t}_k$. Due to -the convexity of linear constraints, these constraints -will be satisfied for any $t\leq \bar{t}_k$. Then, for $t=\bar{t}_k$, -nonlinear constraints are checked first and, -for both objectives and constraints, those with nonzero -multipliers in the QP yielding $d^0_k$ are evaluated first. -For $t<\bar{t}_k$, the function that caused the previous value of $t$ to -be rejected is checked first; all functions of the same type -(``objective'' or ``constraint'') as the latter -will then be checked first. - -\smallskip -\smallskip -\noindent{\it Step 3. Updates.} -\begin{itemize} -\item[$\cdot$] If $nset>5n$ and $t_k<\underline t$, set $H_{k+1}=H_0$ -and $nset=0$. -Otherwise, set $nset=nset+1$ and compute a new approximation $H_{k+1}$ -to the Hessian of the Lagrangian using the BFGS formula with Powell's -modification\Lspace \Lcitemark 8\Rcitemark \Rspace{}. -\item[$\cdot$] Set $x_{k+1}=x_{k}+t_{k}d_{k}+t_{k}^{2}\tilde d_{k}$. -\item[$\cdot$] Solve the unconstrained -quadratic problem in $\bar{\mu}$ -$$\begin{array}{cl} -\min\limits_{\bar{\mu}\in R^{t_e}} & -\|\sum\limits_{j=1}^{n_f}\zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda_{k,j}\nabla g_j(x_k) - +\sum\limits_{j=1}^{t_e}\bar{\mu}_j\nabla h_j(x_k)\|^2, -\end{array}$$ -where the $\zeta_{k,j}$'s, $\xi_k$ and the $\lambda_{k,j}$'s -are the multipliers associated with $QP(x_k,H_k,p_k)$ for the objective -functions, variable bounds, and inequality constraints -respectively.\footnote{This is a refinement (saving much computation -and memory) of the scheme proposed in\Lspace \Lcitemark 1\Rcitemark \Rspace{}.} -Update $p_k$ as follows: for $j=1,\ldots,n_e$, -$$p_{k+1,j}=\left\{\begin{array}{ll} -p_{k,j} & \mbox{if } p_{k,j}+\bar\mu_j \geq \epsilon_1\\ -\max\{\epsilon_1-\bar\mu_j,~\delta p_{k,j}\} & \mbox{otherwise.} -\end{array}\right.$$ -\item[$\cdot$] Increase $k$ by 1. -\item[$\cdot$] Go back to {\it Step 1}. -\end{itemize} - -\hfill{\large \bf $\Box$} - -\vspace{1em} -\noindent{\bf Algorithm FSQP-NL.} - -\vspace{1em} -\noindent{\it Parameters.} $\eta =3.0$, $\nu=0.01$, -$\alpha=0.1$, $\beta=0.5$, $\theta=0.2$, $\bar{\rho}=0.5$, $\gamma = 2.5$, -$\underline{C}=0.01$, $\underline{d}=5.0$, $\underline t=0.1$, -$\epsilon_1=0.1$, $\epsilon_2=10$, $\delta=5$. - -\smallskip -\noindent{\it Data.} $x_0\in R^n$, $\epsilon > 0$, $\epsilon_e>0$ and -$p_{0,j}=\epsilon_2$ for $j=1, \ldots, n_e$. - -\smallskip -\noindent{\it Step 0: Initialization.} Set $k=0$, $H_0=$ the identity -matrix, and $C_0 = \underline{C}.$ If $x_0$ is infeasible for -constraints other than nonlinear equality constraints, substitute a -feasible point, obtained as discussed below. -Set $x_{-3}=x_{-2}=x_{-1}=x_0$ and $nset=0$. -For $j=1,\ldots,n_e$, replace $h_j(x)$ by $-h_j(x)$ whenever -$h_j(x_0)>0$. - -\smallskip -\noindent{\it Step 1: Computation of a new iterate.} - -\begin{itemize} -\item[\it ~~~i.] Compute $d_{k}^{0}$, the solution of quadratic program -$QP(x_k,H_k,p_k)$. -%Compute the Kuhn-Tucker vector -%$$\begin{array}{lll} -%\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)& = & -%\sum\limits_{j=1}^{n_f} \zeta _{k,j}\nabla f_j(x_k)+ -%\sum\limits_{j=1}^{n} \xi _{k,j}+\sum\limits_{j=1}^{t_i} -% \lambda _{k,j}\nabla g_j(x_k) \\ -%& & ~~~+\sum\limits_{j=1}^{n_e}(\mu_{k,j}-p_{k,j})\nabla h_j(x_k) -% +\sum\limits_{j=n_e+1}^{t_e}\mu_{k,j}\nabla h_j(x_k).\end{array}$$ - -%If $\|\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)\|\leq \epsilon$ -If $\|d_k^0\|\leq \epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq\epsilon_e$, stop. -If $n_i+n_e=0$ and $n_f=1,$ set $d_k=d^0_k$ and $\tilde d_k =0$ and -go to {\it Step~1~viii}. If $n_i+n_e=0$ and $n_f >1,$ -set $\rho _k^{\ell}=\rho _k^g=0$ and go to {\it Step~1~v}. - -\item[\it ~~ii.] Compute $d_{k}^{1}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{ll} \min\limits_{d^1\in R^n,\gamma \in R} - & \frac{\eta}{2}\|d^1\|^2+\gamma \\ - {\rm ~~~~s.t.} & bl \leq x_k+d^1 \leq bu\\ - & g_j(x_k)+\langle \nabla g_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_i\\ - & \langle c_j,x_k + d^1 \rangle \leq d_j, - ~~~~j=1,\ldots,t_i-n_i \\ - & h_j(x_k)+\langle \nabla h_j(x_k),d^1 \rangle - \leq\gamma, ~~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k + d^1 \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ - -\item[\it ~iii.] Set $v_{k}=\min \{C_k\|d^0_k\|^2,\|d^0_k\|\}$. -Define values -$\rho^g_{k,j}$ for $j=1,\ldots,n_i$ by $\rho^g_{k,j}$ equal to zero if -\smallskip -$$g_j(x_k)+\langle \nabla g_j(x_k),d^0_k\rangle \leq -v_k$$ -\smallskip -or equal to the maximum $\rho$ in $[0,1]$ such that -\smallskip -$$g_j(x_k)+\langle \nabla g_j(x_k),(1-\rho)d^0_k+ - \rho d^1_k\rangle \geq -v_k$$ -\smallskip -otherwise. Similarly, define values $\rho^h_{k,j}$ for $j=1,\ldots,n_e$. -Let $$\rho ^{\ell}_k=\max\left\{\max _{j=1,\ldots,n_i}\{\rho^g_{k,j}\},~ -\max _{j=1,\ldots,n_e}\{\rho^h_{k,j}\}\right\}.$$ - -\item[\it ~~iv.] Define $\rho _k^g$ as the largest number $\rho$ -in $[0,\rho ^{\ell}_k]$ such that -\smallskip -$$f'(x_k,(1-\rho)d^0_k+\rho d^1_k,p_k)\leq \theta f'(x_k,d^0_k,p_k).$$ -If ($k\geq 1$ \& $t_{k-1}<1$) or ($\rho _k^{\ell} > \bar{\rho}$), set -$\rho _k^\ell = \min \{\rho _k^\ell, \rho _k^g\}.$ - -\item[\it ~~~v.] Construct a ``local'' direction -\smallskip -$$d_k^{\ell}=(1-\rho _k^{\ell})d^0_k+\rho _k^{\ell} d^1_k.$$ -Set $M=3$, $\delta_k=f'(x_k,d_k^0)$ if $n_i+n_e\ne 0$, -and $M=2$, $\delta_k=-\langle d_k^0,H_kd_k^0\rangle$ otherwise. -If -$$f_m(x_k+d^{\ell}_k,p_k)\leq -\max\limits_{\ell=0,\ldots,M}\{f_m(x_{k-\ell},p_k)\} + - \alpha \delta_k$$ -$$g_j(x_k+d^{\ell}_k)\leq 0,~~j=1,\ldots,n_i$$ -and -$$h_j(x_k+d^{\ell}_k)\leq 0,~~j=1,\ldots,n_e,$$ -\smallskip -set $t_k=1$, $x_{k+1}=x_k+d_k^{\ell}$ and go to {\it Step 2}. - -\item[\it ~~vi.] Construct a ``global'' direction -\smallskip -$$d_k^{g}=(1-\rho _k^{g})d^0_k+\rho _k^{g}d^1_k.$$ - -\item[\it ~vii.] -Compute $\tilde d_{k}$ by solving the strictly convex -quadratic program -\smallskip -$$ \begin{array}{cl} \min\limits_{\tilde d \in R^n} & \frac{1}{2} - \langle (d_k^g+\tilde d),H_{k}(d^g_k+\tilde d)\rangle - +f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k) \\ - \mbox{s.t.} & bl \leq x_k+d_k^g+\tilde d \leq bu\\ - & g_j(x_k+d_k^g) +\langle \nabla g_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k^g\|,~\|d_k^g\|^{\tau}), - ~~~j\in I^g_k(d^g_k)\cap\{j:j\leq n_i\}\\ - & \langle c_{j-n_i},x_k+d_k^g + \tilde d \rangle \leq d_{j-n_i}, - ~~~~j\in I^g_k(d^g_k)\cap\{j:j>n_i\}\\ - & h_j(x_k+d_k^g) +\langle \nabla h_j(x_k),\tilde d\rangle\leq - -\min(\nu\|d_k^g\|,~\|d_k^g\|^{\tau}), - ~~~j=1,\ldots,n_e\\ - & \langle a_j,x_k+d_k^g + \tilde d \rangle=b_j, - ~~~~j=1,\ldots,t_e-n_e\end{array}$$ -where $f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k)=f'(x_k,d_k^g+\tilde d,p_k)$ if - $n_f=1,$ -and $f'_{I^f_k(d_k^g)}(x_k,d_k^g,\tilde d,p_k)= -\tilde{f}'_{I^f_k(d_k^g)}(x_k+d_k^g,x_k,\tilde d,p_k)$ -if $n_f>1$. If the quadratic program has no solution or -if $\|\tilde d_k\|>\|d_k^g\|$, set $\tilde d_k=0$. - -\item[\it viii.] Set $M=3$, $\delta_k=f'(x_k,d^g_k,p_k)$ if $n_i+n_e\ne 0$, -and $M=2$, $\delta_k=-\langle d^g_k,H_kd^g_k\rangle$ otherwise. -Compute $t_k$, the first number $t$ in -the sequence $\mbox\{1,\beta,\beta^{2},\ldots\}$ satisfying -\smallskip -\begin{eqnarray*} -\textstyle -& f_m(x_{k}+td^g_k+t^{2}\tilde d_k,p_k)\leq - \max\limits_{\ell=0,\ldots,M}\{f_m(x_{k-\ell},p_k)\}+ -\alpha t \delta_k &\\ -& g_{j}(x_{k}+td_k^g+t^{2}\tilde d_{k})\leq0,~~j=1,\ldots,n_i & \\ -&\langle c_{j-n_i},x_k+td_k^g +t^2 \tilde{d}_k \rangle \leq d_{j-n_i}, - ~~~~j>n_i~\&~j\not\in I^g_k(d^g_k) &\\ -& h_{j}(x_{k}+td_k^g+t^{2}\tilde d_{k})\leq0,~~j=1,\ldots,n_e & -\end{eqnarray*} -and set $x_{k+1}=x_k+t_kd_k^g+t_k^2\tilde d_k.$ \\ -Specifically, the line search proceeds as follows. -First, the linear constraints that were not used -in computing $\tilde{d}_k$ are checked until all of them are -satisfied, resulting in a stepsize, say, $\bar{t}_k$. Due to -the convexity of linear constraints, these constraints -will be satisfied for any $t\leq \bar{t}_k$. Then, for $t=\bar{t}_k$, -nonlinear constraints are checked first and, -for both objectives and constraints, those with nonzero -multipliers in the QP yielding $d^0_k$ are evaluated first. -For $t<\bar{t}_k$, the function that caused the previous value of $t$ to -be rejected is checked first; all functions of the same type -(``objective'' or ``constraint'') as the latter -will then be checked first. -\end{itemize} - -\noindent{\it Step 2. Updates.} -\begin{itemize} -\item[$\cdot$] If $nset>5n$ and $t_k<\underline t$, set $H_{k+1}=H_0$ -and $nset=0$. Otherwise, set $nset=nset+1$ and -compute a new approximation $H_{k+1}$ -to the Hessian of the Lagrangian using the BFGS formula with Powell's -modification\Lcitemark 8\Rcitemark . -\item[$\cdot$] If $\|d^0_k\|>\underline{d}$, -set $C_{k+1}=\max \{0.5C_k,\underline{C}\}.$ -Otherwise, if $g_j(x_k+d_k^\ell) \leq 0,~~j=1,\ldots,n_i$, -set $C_{k+1}=C_k$. Otherwise, set $C_{k+1}=10C_k$. -\item[$\cdot$] Solve the unconstrained -quadratic problem in $\bar{\mu}$ -$$\begin{array}{cl} -\min\limits_{\bar{\mu}\in R^{t_e}} & -\|\sum\limits_{j=1}^{n_f}\zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda_{k,j}\nabla g_j(x_k) - +\sum\limits_{j=1}^{t_e}\bar{\mu}_j\nabla h_j(x_k)\|^2, -\end{array}$$ -where the $\zeta_{k,j}$'s, $\xi_k$ and the $\lambda_{k,j}$'s -are the multipliers associated with $QP(x_k,H_k,p_k)$ for the objective -functions, variable bounds, and inequality constraints -respectively.\footnote{See footnote to corresponding step in description -of FSQP-AL.} - -Update $p_k$ as follows: for $j=1,\ldots,n_e$, -$$p_{k+1,j}=\left\{\begin{array}{ll} -p_{k,j} & \mbox{if } p_{k,j}+\bar\mu_j \geq \epsilon_1\\ -\max\{\epsilon_1-\bar\mu_j,~\delta p_{k,j}\} & \mbox{otherwise.} -\end{array}\right.$$ -\item[$\cdot$] Increase $k$ by 1. -\item[$\cdot$] Go back to {\it Step 1}. -\end{itemize} - -\hfill{\large \bf $\Box$} - -\noindent{\bf Remark:} The Hessian matrix is reset -in both algorithms whenever stepsize is too small and -the updating of the matrix goes through $n$ iterations. -This is helpful in some situations where the Hessian matrix -becomes singular. - -\vspace{1em} -If the initial guess $x_0$ provided by the user is not feasible -for some inequality constraint or some linear equality constraint, -FSQP first solves a strictly convex quadratic program -\smallskip -$$\begin{array}{cl} - \min\limits_{v\in R^n} & \langle v,v\rangle \\ - \mbox{s.t.} & bl \leq x_0+v \leq bu\\ - & \langle c_j,x_0 + v \rangle \leq d_j, - ~~~j=1,\ldots,t_i-n_i\\ - & \langle a_j,x_0 + v \rangle=b_j, - ~~~j=1,\ldots,t_e-n_e. \end{array}$$ - -\vspace{.5em} -\noindent{}Then, starting from the point $x=x_0+v$, it will iterate, -using algorithm FSQP-AL, on the problem -\smallskip -$$\begin{array}{cl} - \min\limits_{x\in R^n} & \max\limits_{j=1,\ldots,n_i}\{g_j(x)\} \\ - \mbox{s.t.} & ~~bl \leq x \leq bu\\ - & ~~\langle c_j,x\rangle \leq d_j,~~~j=1,\ldots,t_i-n_i\\ - & ~~\langle a_j,x \rangle =b_j,~~~j=1,\ldots , t_e-n_e - \end{array}$$ -until $\max\limits_{j=1,\ldots,n_i}\{g_j(x)\} \leq 0$ is achieved. -The corresponding iterate $x$ will then be feasible -for all constraints other than nonlinear equality constraints of -the original problem. - -\section{Specification of Subroutine FSQPD 3.1} -Only a double precision version of FSQP, FSQPD is currently available. -The specification of FSQPD is as follows: -\vspace{1em} -\begin{quote} -\begin{verbatim} - subroutine FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint,miter, - * inform,bigbnd,eps,epseqn,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj,constr,gradob,gradcn) - integer nparam,nf,nineqn,nineq,neqn,neq,mode,iprint,miter,inform, - * iwsize,nwsize - integer iw(iwsize) - double precision bigbnd,eps,epseqn,udelta - double precision bl(nparam),bu(nparam),x(nparam), - * f(nf),g(nineq+neq),w(nwsize) - external obj,constr,gradob,gradcn -\end{verbatim} -\end{quote} -\vspace{1em} -{\bf Important:} all real variables and arrays must be declared as -double precision in the routine that calls FSQPD. The following are -specifications of parameters and workspace. - -\vspace{1em} -\begin{description} -\item[\tt nparam] {\bf (Input)}~Number of free variables, - i.e., the dimension of {\tt x}. -\item[\tt nf] {\bf (Input)}~Number of objective - functions ($n_f$ in the algorithm description). -\item[\tt nineqn] {\bf (Input)}~Number (possibly zero) of - nonlinear inequality constraints ($n_i$ in the - algorithm description). -\item[\tt nineq] {\bf (Input)}~Total number (possibly equal - to {\tt nineqn}) of - inequality constraints ($t_i$ in the algorithm - description). -\item[\tt neqn] {\bf (Input)}~Number (possibly zero) of - nonlinear equality constraints ($n_e$ in the - algorithm description). -\item[\tt neq] {\bf (Input)}~Total number (possibly equal to {\tt neqn}) of - equality constraints ($t_e$ in the algorithm - description). -\item[\tt mode] {\bf (Input)}~${\tt mode} = 1BA$ with the following - meanings: - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[${\tt A} = 0$~:~~] $(P)$ is to be solved. - \item[${\tt A} = 1$~:~~] $(PL_\infty)$ is to be solved. - $(PL_\infty)$ is defined as follows -$$ - (PL_\infty)~~~~~ \min ~ \max\limits_{i\in I^f} |f_i(x)| - \mbox{~~~s.t.~~}x\in X -$$ - where $X$ is the same as for $(P).$ It is handled - in this code by splitting $|f_i(x)|$ as $f_i(x)$ - and $-f_i(x)$ for each $i.$ The user is required - to provide only $f_i(x)$ for $i\in I^f$. - \item[${\tt B} = 0$~:~~]Algorithm FSQP-AL is - selected, resulting in a - decrease of the (modified) objective - - function at each iteration. - \item[${\tt B} = 1$~:~~]Algorithm FSQP-NL is - selected, resulting in a - decrease of the (modified) objective - function within at - most four iterations (or three - iterations, see Algorithm FSQP-NL). - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt iprint] {\bf (Input)}~Parameter indicating the - desired output (see \S 4 for details): - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[~~${\tt iprint} =0$~:~~] No information except - for user-input errors is displayed. This value - is imposed during phase 1. - \item[~~${\tt iprint} =1$~:~~] - Objective and constraint values - at the initial feasible point are displayed. - At the end of execution, status ({\tt inform}), - iterate, objective values, constraint values, - number of evaluations of objectives and - nonlinear constraints, norm of the Kuhn-Tucker - vector, and sum of feasibility violation - are displayed. - \item[~~${\tt iprint} =2$~:~~] At the end of each - iteration, the same information as with - ${\tt iprint}=1$ is displayed. - \item[~~${\tt iprint} =3$~:~~] At each iteration, - the same information as with ${\tt iprint}=2$, - including detailed information on the search - direction computation, on the line search, - and on the update is displayed. - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt miter] {\bf (Input)}~Maximum number of iterations -allowed by the user before termination of execution. -\item[\tt inform] {\bf (Output)}~Parameter indicating the status of - the execution of FSQPD: - \begin{quote} - \begin{quote} - \begin{quote} - \begin{itemize} - \item[~~${\tt inform} = 0$~:~] Normal termination of - execution in the sense that - $\|d^0\|\leq {\tt eps}$ - and (if ${\tt neqn} \ne 0$) - $\sum_{j=1}^{n_e}|h_j(x)|\leq {\tt epseqn}$. - \item[~~${\tt inform} = 1$~:~] The user-provided - initial guess - is infeasible for - linear constraints and - FSQPD is unable to - generate a point - satisfying all these - constraints. - \item[~~${\tt inform} = 2$~:~] The user-provided - initial guess - is infeasible for nonlinear - inequality constraints and - linear constraints; and - FSQPD is unable to - generate a point - satisfying all these - constraints. - \item[~~${\tt inform} = 3$~:~] The maximum - number~{\tt miter} - of iterations has been - reached before a - solution is obtained. - \item[~~${\tt inform} = 4$~:~] The line search fails - to find a new - iterate (trial step size - being - smaller than the machine - precision - {\tt epsmac} computed by FSQPD). - \item[~~${\tt inform} = 5$~:~] Failure of the QP solver - in attempting - to construct $d^0$. A more - robust QP solver may succeed. - \item[~~${\tt inform} = 6$~:~] Failure of the QP solver - in attempting - to construct $d^1$. A more - robust QP solver may succeed. - \item[~~${\tt inform} = 7$~:~] Input data are not - consistent~(with - printout - indicating the error). - \end{itemize} - \end{quote} - \end{quote} - \end{quote} -\item[\tt bigbnd] {\bf (Input)}~(see also {\tt bl} - and {\tt bu} below)~It plays the role of - Infinite Bound. -\item[\tt eps] {\bf (Input)}~Final norm requirement for -% the Kuhn-Tucker vector ($\epsilon$ in the - the Newton direction $d_k^0$ ($\epsilon$ in the - algorithm description). It must be bigger - than the machine - precision {\tt epsmac} (computed by FSQPD). - (If the user does not have a good feeling of - what value should be chosen, a very small - number could be provided and $\mbox{\tt iprint}=2$ - be selected so that the user would be able to keep track of - the process of optimization and terminate FSQPD - at appropriate time.) -\item[\tt epseqn] {\bf (Input)}~Maximum violation of nonlinear equality - constraints allowed by the user at an optimal point - ($\epsilon_e$ in the algorithm description). - It is in effect only if $n_e\ne 0$ and - must be bigger than the machine - precision {\tt epsmac} (computed by FSQPD). -\item[\tt udelta] {\bf (Input)}~The perturbation - size the user suggests to use in - approximating gradients by finite difference. - The perturbation size actually used is defined by -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times \max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} - is the square root of {\tt epsmac}). {\tt udelta} - should be set to zero if the user has no idea - how to choose it. -\item[\tt bl] {\bf (Input)}~Array of - dimension {\tt nparam} containing - lower bounds for the components of {\tt x}. - To specify a non-existent lower - bound (i.e., ${\tt bl}(j)=-\infty$ for - some $j$), the value used must - satisfy ${\tt bl}(j)\leq -{\tt bigbnd}$. -\item[\tt bu] {\bf (Input)}~Array of - dimension {\tt nparam} containing - upper bounds for the components of {\tt x}. - To specify a non-existent upper - bound (i.e., ${\tt bu}(j)=\infty$ for - some $j$), the value used must - satisfy ${\tt bu}(j)\geq {\tt bigbnd}$. -\item[\tt x] {\bf (Input)}~Initial guess.\\ - {\bf (Output)}~Iterate at the end of execution. -\item[\tt f] Array of dimension $\max\{1, {\tt nf}\}$.\\ - {\bf (Output)}~Value of functions - $f_i,i=1,\ldots,n_f$, at {\tt x} at the end of - execution. -\item[\tt g] Array of dimension $\max\{1,{\tt nineq}+{\tt neq}\}$.\\ - {\bf (Output)}~Values of constraints at {\tt x} at - the end of execution. -\item[\tt iw] Workspace vector of dimension {\tt iwsize}. -\item[\tt iwsize] {\bf (Input)}~Workspace length - for {\tt iw}. It must be at least as big as - $6\times {\tt nparam}+8\times ({\tt nineq}+{\tt neq}) - +7\times{\tt nf}+30$. This estimate is usually very conservative - and the smallest suitable value will be - displayed if the user-supplied value is too small. -\item[\tt w] {\bf (Input)}~Workspace of dimension {\tt nwsize}. \\ - {\bf (Output)}~Estimate of Lagrange multipliers at - the end of execution of phase 2 in the - first ${\tt nparam}+{\tt nineq+neq+nff}$ entries; - where ${\tt nff}=0$ if (in {\tt mode}) ${\tt A}=0$ and - ${\tt nf}=1$, and ${\tt nff}={\tt nf}$ otherwise. - They are ordered as $\xi$'s (variables), $\lambda$'s (inequality - constraints), $\mu$'s (equality constraints), and $\zeta$ - (objective functions). - $\lambda _j \geq 0~~\forall j=1,\ldots,t_i$ - and $\mu _j \ge 0~~\forall j=1,\ldots,t_e.$ $\xi _i > 0$ - indicates that $x_i$ reaches its upper bound and $\xi _i <0$ - indicates that $x_i$ reaches its lower bound. When - (in {\tt mode}) ${\tt A}=0$ and ${\tt nf}>1$, $\zeta _i \geq0.$ - When ${\tt B}=1$, $\zeta _i >0$ refers to - $+f_i(x)$ and $\zeta _i<0$ to $-f_i(x)$. -\item[\tt nwsize] {\bf (Input)}~Workspace length for {\tt w}. - It must be at least as big as - $4\times {\tt nparam}^{2}+ - 5\times ({\tt nineq}+{\tt neq})\times{\tt nparam}+ - 3\times{\tt nf}\times{\tt nparam}+ - 26\times ({\tt nparam}+{\tt nf})+45\times ({\tt nineq}+{\tt neq})+100$ -. This estimate - is usually very conservative and the - smallest suitable value will be - displayed if the user-supplied value is too small. -\item[\tt obj] {\bf (Input)}~Name of the user-defined subroutine - that computes the value of the objective - functions $f_i(x),~~\forall i=1,\ldots,n_f.$ This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The detailed specification is given in \S 5.1 below. -\item[\tt constr] {\bf (Input)}~Name of the user-defined subroutine - that computes the value of the constraints. This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The detailed specification is given in \S 5.2 below. -\item[\tt gradob] {\bf (Input)}~Name of the subroutine that - computes the gradients of the objective - functions $f_i(x),~~\forall i=1,\ldots,n_f.$ This name must - be declared as {\bf external} in the calling routine - and passed as an argument to FSQPD. - The user must pass the subroutine name - {\tt grobfd}~(and declare it as {\bf external}), - if he/she wishes that FSQPD evaluate - these gradients automatically, by forward finite differences. - The detailed specification is given in \S 5.3 below. -\item[\tt gradcn] {\bf (Input)}~Name of the subroutine that - computes the gradients of the constraints. - This name must be declared as {\bf external} in the calling - routine and passed as an argument to FSQPD. - The user must pass the subroutine name {\tt grcnfd}~(and - declare it as {\bf external}), if he/she wishes that - FSQPD evaluate these gradients automatically, - by forward finite differences. - The detailed specification is given in \S 5.4 below. -\end{description} - -\section{User-Accessible Stopping Criterion} -As is clear from the two algorithms, the optimization process -normally terminates if both -$\|d_k^0\|\leq\epsilon$ -and $\sum_{j=1}^{n_e}|h_j(x_k)|\leq\epsilon_e$ are satisfied. -Very small value of either of these two parameters may request -exceedingly long execution time, depending on the complexity -of underlying problem and the nonlinearity of various functions. -FSQP allows users to specify their own stopping criterion in any one of -the four user-supplied subroutines mentioned above via the following -common block -\begin{verbatim} - integer nstop - common /fsqpst/nstop -\end{verbatim} -if (s)he wishes to. -${\tt nstop}=0$ should be returned to FSQP when the stopping criterion -is satisfied. FSQP will check the value of {\tt nstop} at appropriate places -during the optimization process and will terminate when -either the user's criterion or the default criterion is satisfied. - -\section{Description of the Output} -No output will be displayed before a feasible starting -point is obtained. The following information is displayed -at the end of execution when -${\tt iprint} = 1$ or at each iteration when ${\tt iprint}=2$: -\begin{description} -\item[\tt iteration] Total number of iterations (${\tt iprint}=1$) or - iteration number (${\tt iprint}=2$). -\item[\tt inform] See \S 3. It is displayed only - at the end of execution. -\item[\tt x] Iterate. -\item[\tt objectives] Value of objective functions $f_i(x),~~\forall - i=1,\ldots,n_f$ at {\tt x}. -\item[\tt objmax] (displayed only if $\mbox{\tt nf} > 1$)~The - maximum value of the set of objective - functions (i.e., $\max f_i(x) \mbox{ or } \max |f_i(x)|,~~ - \forall i=1,\ldots,n_f$) at {\tt x}. -\item[\tt objective max4] (displayed only if $\mbox{\tt B} = 1$ - in {\tt mode})~Largest value of - the maximum of the objective functions over the - last four (or three, see FSQP-NL) - iterations (including the current one). -\item[\tt constraints] Values of the constraints at {\tt x}. -\item[\tt ncallf] Number of evaluations (so far) of - individual~(scalar) objective function $f_i(x)$ - for $1\leq i \leq n_f.$ -\item[\tt ncallg] Number of evaluations (so far) of - individual~(scalar) nonlinear constraints. -\item[\tt d0norm] Norm of the Newton direction $d_k^0$. -\item[\tt ktnorm] Norm of the Kuhn-Tucker vector at the current - iteration. The Kuhn-Tucker vector is given by -$$\begin{array}{lll} -\nabla L(x_k,\zeta_k,\xi_k,\lambda_k,\mu_k,p_k)& = & -\sum\limits_{j=1}^{n_f} \zeta _{k,j}\nabla f_j(x_k)+ -\xi_k+\sum\limits_{j=1}^{t_i}\lambda _{k,j}\nabla g_j(x_k) \\ -& &~+\sum\limits_{j=1}^{n_e}(\mu_{k,j}-p_{k,j})\nabla h_j(x_k) - +\sum\limits_{j=n_e+1}^{t_e}\mu_{k,j}\nabla h_j(x_k).\end{array}$$ -\item[\tt SCV] Sum of the violation of nonlinear equality constraints -at a solution. -\end{description} - -{\noindent}For ${\tt iprint}=3$, in addition to the same - information as the one for ${\tt iprint}=2$, - the following is printed at every iteration. - -\vspace{1em} -Details in the computation of a search direction: -\begin{description} -\item[\tt d0] Quasi-Newton direction $d^0_k$. -\item[\tt d1] First order direction $d^1_k$. -\item[\tt d1norm] Norm of $d^1_k$. -\item[\tt d] (${\tt B}=0$ in {\tt mode})~Feasible descent - direction $d_k=(1-\rho _k)d^0_k+\rho _k d^1_k$. -\item[\tt dnorm] (${\tt B}=0$ in {\tt mode})~Norm of $d_k$. -\item[\tt rho] (${\tt B}=0$ in {\tt mode})~Coefficient $\rho_k$ in - constructing $d_k$. -\item[\tt dl] (${\tt B}=1$ in {\tt mode})~Local direction - $d^\ell_k=(1-\rho^\ell_k)d_k^0+\rho^\ell_kd^1_k$. -\item[\tt dlnorm] (${\tt B}=1$ in {\tt mode})~Norm of $d_k^\ell$. -\item[\tt rhol] (${\tt B}=1$ in {\tt mode})~Coefficient $\rho_k^{\ell}$ in - constructing $d_k^{\ell}$. -\item[\tt dg] (${\tt B}=1$ in {\tt mode})~Global search direction - $d^g=(1-\rho^g_k)d_k^0+\rho^g_kd^1_k$. -\item[\tt dgnorm] (${\tt B}=1$ in {\tt mode})~Norm of $d_k^g$. -\item[\tt rhog] (${\tt B}=1$ in {\tt mode})~Coefficient $\rho_k^g$ in - constructing $d_k^g$. -\item[\tt dtilde] Second order correction $\tilde d_k$. -\item[\tt dtnorm] Norm of $\tilde d_k$. -\end{description} - -Details in the line search: -\begin{description} -\item[\tt trial step] Trial steplength $t$ in the search direction. -\item[\tt trial point] Trial iterate along the search arc - with {\tt trial step}. -\item[\tt trial objectives] This gives the indices $i$ and - the corresponding - values of the functions - $f_i(x)-\sum_{j=1}^{n_e}p_jh_j(x)$ - for $1\leq i \leq n_f$ up to the one which fails - in line search at the {\tt trial point}. The - indices $i$ - are not necessarily in the natural order (see - remark at the end of {\it Step 2} in FSQP-AL and of - the end of {\it Step~1~viii}\ in FSQP-NL). -\item[\tt trial constraints] This gives the indices $j$ and the - corresponding values of nonlinear constraints - for $1\leq j \leq n_i+n_e$ up to the - one which is not feasible at the {\tt trial point}. - The indices $j$ - are not necessarily in the natural order (see - remark at the end of {\it Step 2} in FSQP-AL and of - the end of {\it Step~1~viii}\ in FSQP-NL). -\end{description} - -Details in the updates: -\begin{description} -\item[\tt delta] Perturbation size for each variable - in finite difference gradients computation. -\item[\tt gradf] Gradients of - functions $f_i(x),~\forall i=1,\ldots,n_f,$ - at the new iterate. -\item[\tt gradg] Gradients of constraints at the new iterate. -\item[\tt p] Penalty parameters for nonlinear equality constraints at - the new iterate. -\item[\tt multipliers] Multiplier estimates ordered as $\xi$'s, - $\lambda$'s, $\mu$'s, and $\zeta$'s (from quadratic program - computing $d^0_k$). $\lambda _j \geq 0~~\forall j=1,\ldots,t_i$ - and $\mu _j \ge 0~~\forall j=1,\ldots,t_e$. $\xi _i > 0$ - indicates that $x_i$ reaches its upper bound and $\xi _i <0$ - indicates that $x_i$ reaches its lower bound. When - (in {\tt mode}) ${\tt A}=0$ and ${\tt nf}>1$, $\zeta _i \geq0$. - When (in {\tt mode}) ${\tt A}=1$, $\zeta _i >0$ refers to - $+f_i(x)$ and $\zeta _i<0$ to $-f_i(x)$. - (cf.\ \S 3 under item {\tt w}.) -\item[\tt hess] Estimate of the Hessian matrix of the Lagrangian. -\item[\tt Ck] The value $C_k$ as defined in Algorithm FSQP-NL. -\end{description} - -\section{User-Supplied Subroutines} -At least two of the following four Fortran 77 subroutines, -namely {\tt obj} and {\tt constr}, -must be provided by the user in order to define the problem. -The name of all four routines can be changed at the user's will, -as they are passed as arguments to FSQPD. - -\subsection{Subroutine obj} -The subroutine {\bf obj}, to be provided by the user, -computes the value of the objective functions. -A (dummy) subroutine must be provided due to Fortran 77 compiling -requirement if $\mbox{\tt nf}=0$ (This may happen when the user -is only interested in finding a feasible point). -The specification of {\bf obj} for FSQPD is -\begin{quote} -\begin{verbatim} - subroutine obj(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj - c - c for given j, assign to fj the value of the jth objective - c evaluated at x - c - return - end -\end{verbatim} -\end{quote} -\noindent Arguments: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of the objective to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt fj] {\bf (Output)}~Value of the {\tt j}th objective function - at {\tt x}. -\end{description} - -\subsection{Subroutine constr} -The subroutine {\bf constr}, to be provided by the user, -computes the value of -the constraints. If there are no constraints, -a (dummy) subroutine must be -provided anyway due to Fortran 77 compiling requirement. -The specification of {\tt constr} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine constr(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj - c - c for given j, assign to gj the value of the jth constraint - c evaluated at x - c - return - end -\end{verbatim} -\end{quote} -\noindent Arguments: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of the constraint to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gj] {\bf (Output)}~Value of the {\tt j}th constraint at {\tt x}. -\end{description} -\bigskip -The order of the constraints must be as follows. -First the {\tt nineqn} (possibly zero) nonlinear inequality constraints. -Then the ${\tt nineq-nineqn}$ (possibly zero) linear inequality constraints. -Finally, the {\tt neqn} (possibly zero) nonlinear equality constraints -followed by the ${\tt neq-neqn}$ (possibly zero) linear equality constraints. - -\subsection{Subroutine gradob} -The subroutine {\bf gradob} computes the gradients of the -objective functions. -The user may omit to provide this routine and require that -forward finite difference -approximation be used by FSQPD via calling {\tt grobfd} instead~ -(see argument {\tt gradob} of FSQPD in \S 3). -The specification of {\tt gradob} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine gradob(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision x(nparam),gradfj(nparam) - double precision dummy - external dummy -c -c assign to gradfj the gradient of the jth objective function -c evaluated at x -c - return - end -\end{verbatim} -\end{quote} -\noindent{Arguments}: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of objective for - which gradient is to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gradfj] {\bf (Output)}~Gradient of the {\tt j}th objective - function at x. -\item[\tt dummy] {\bf (Input)}~Used by {\tt grobfd}. -\end{description} -Note that {\tt dummy} is -passed as arguments to {\tt gradob} to allow for forward finite -difference computation of the gradient. - -\subsection{Subroutine gradcn} -The subroutine {\bf gradcn} computes the gradients of the constraints. -The user may omit to provide this routine and require that forward -finite difference approximation be used by FSQPD via -calling {\tt grcnfd} instead (see argument {\tt gradcn} of FSQPD in \S 3). -The specification of {\tt gradcn} for FSQPD is as follows -\begin{quote} -\begin{verbatim} - subroutine gradcn (nparam,j,x,gradgj,dummy) - integer nparam,j - double precision x(nparam),gradgj(nparam) - double precision dummy - external dummy -c -c assign to gradgj the gradient of the jth constraint -c evaluated at x -c - return - end -\end{verbatim} -\end{quote} -\noindent{Arguments}: -\begin{description} -\item[\tt nparam] {\bf (Input)}~Dimension of {\tt x}. -\item[\tt j] {\bf (Input)}~Number of constraint for which - gradient is to be computed. -\item[\tt x] {\bf (Input)}~Current iterate. -\item[\tt gradgj] {\bf (Output)}~Gradient of the {\tt j}th - constraint evaluated at {\tt x}. -\item[\tt dummy] {\bf (Input)}~Used by {\tt grcnfd}. -\end{description} - -\noindent Note that {\tt dummy} is passed as arguments -to {\tt gradcn} to allow for forward finite difference -computation of the gradients. - -\section{Organization of FSQPD and Main Subroutines} -\subsection{Main Subroutines} -FSQPD first checks for inconsistencies of input parameters using the -subroutine {\tt check}. It then checks if the starting -point given by the user satisfies the linear -constraints and if not, generates a point -satisfying these constraints using -subroutine {\tt initpt}. It then calls FSQPD1 for generating a point -satisfying linear and nonlinear inequality constraints. Finally, -it attempts to find -a point satisfying the optimality condition using again FSQPD1. -\begin{description} -\item[\tt check] Check that all upper bounds on variables - are no smaller than lower bounds; - check that all input integers are nonnegative - and appropriate (${\tt nineq} \geq {\tt nineqn}$, etc.); - and check that {\tt eps} ($\epsilon$) - and (if ${\tt neqn}\ne 0$) {\tt epseqn} - ($\epsilon_e$) are at least as large as - the machine precision {\tt epsmac} (computed by FSQPD). -\item[\tt initpt] Attempt to generate a feasible point satisfying - simple bounds and all linear constraints. -\item[\tt FSQPD1] Main subroutine used possibly twice by FSQPD, - first for generating - a feasible iterate as explained at the - end of \S 2 and - second for generating an optimal iterate - from that feasible iterate. -\end{description} -FSQPD1 uses the following subroutines: -\begin{description} -\item[\tt dir] Compute various directions $d_k^0$, $d^1_0$ and $\tilde d_k$. -\item[\tt step]Compute a step size along a certain search direction. - It is also called to check if $x_k+d_k^\ell$ is acceptable - in {\it Step 1 v} of Algorithm FSQP-NL. -\item[\tt hesian] Perform the Hessian matrix updating. -\item[\tt out] Print the output for ${\tt iprint=1}$ - or ${\tt iprint}=2$. -\item[\tt grobfd] (optional)~Compute the gradient of an objective - function - by forward finite differences with mesh size equal to -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times\max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} is the - square root of {\tt epsmac}, the machine - precision computed by FSQPD). -\item[\tt grcnfd] (optional)~Compute the gradient of a constraint by - forward finite differences with mesh size equal to -$\mbox{sign}(x^i)\times\max \{{\tt udelta},~ - {\tt rteps}\times\max (1,\,|x^i|)\}$~ - for each component $x^i$ of $x$ ({\tt rteps} is the - square root of {\tt epsmac}, the machine - precision computed by FSQPD). -\end{description} - -\subsection{Other Subroutines} -In addition to QLD, the following subroutines are used: -\begin{verbatim} - diagnl di1 dqp error estlam fool fuscmp indexs matrcp - matrvc nullvc resign sbout1 sbout2 scaprd shift slope small -\end{verbatim} - -\subsection{Reserved Common Blocks} -The following named common blocks are used in FSQPD and QLD: -\begin{verbatim} - fsqpp1 fsqpp2 fsqpp3 fsqpq1 fsqpq2 fsqplo fsqpqp fsqpst CMACHE -\end{verbatim} - - -\input manua2
deleted file mode 100644 --- a/libcruft/fsqp/matrcp.f +++ /dev/null @@ -1,16 +0,0 @@ -c - subroutine matrcp(ndima,a,ndimb,b) -c implicit real*8(a-h,o-z) - integer ndima,ndimb,i,j - double precision a(ndima,1),b(ndimb,1) -c double precision a(ndima,ndima),b(ndimb,ndimb) -c - do 100 i=1,ndima - do 100 j=1,ndima - 100 b(i,j)=a(i,j) - if(ndimb.le.ndima) goto 9000 - do 200 i=1,ndimb - b(ndimb,i)=0.d0 - 200 b(i,ndimb)=0.d0 - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/matrvc.f +++ /dev/null @@ -1,16 +0,0 @@ -c - subroutine matrvc(l,n,la,na,a,x,y) -c implicit real*8(a-h,o-z) - integer l,n,la,na,i,j - double precision a(l,n),x(n),y(l),yi -c double precision a(l,1),x(1),y(1),yi -c -c computation of y=ax -c - do 200 i=1,la - yi=0.d0 - do 100 j=1,na - 100 yi=yi+a(i,j)*x(j) - 200 y(i)=yi - return - end
deleted file mode 100644 --- a/libcruft/fsqp/nullvc.f +++ /dev/null @@ -1,12 +0,0 @@ -c - subroutine nullvc(nparam,x) -c implicit real*8(a-h,o-z) - integer nparam,i - double precision x(nparam) -c -c set x=0 -c - do 100 i=1,nparam - 100 x(i)=0.d0 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/out.f +++ /dev/null @@ -1,113 +0,0 @@ - subroutine out(miter,nparam,nob,ncn,nn,neqn,ncnstr,x,g,f,fM, - * psf,steps,sktnom,d0norm,feasb) -c -c FSQP Version 3.3 : output for different value of iprint -c -c implicit real*8(a-h,o-z) - integer miter,nparam,nob,ncn,nn,neqn,ncnstr - double precision fM,steps,sktnom,d0norm,psf - double precision x(nparam),g(1),f(1) -c double precision x(nparam),g(ncnstr),f(nob) - logical feasb -c - integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes, - * info,idum1,iter,nstop,initvl,lstype - common /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop, - * /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,iter,initvl -c - integer i - double precision SCV,dummy,adummy(1) -c - if(nstop.eq.0) ipyes=0 - if (iter.le.miter) goto 10 - info=3 - nstop=0 - goto 120 - 10 if(iprint.eq.0.or.ipyes.gt.0) then - iter=iter+1 - goto 9000 - endif - if(info.gt.0) goto 120 - if(iprint.ne.1.or.nstop.eq.0) goto 20 - iter=iter+1 - if(initvl.eq.0) goto 9000 - if(feasb) - * call sbout1(io,nob,'objectives ',dummy,f,2,1) - if (mode.eq.1.and.iter.gt.1.and.feasb) - * call sbout1(io,0,'objective max4 ',fM,adummy,1,1) - if(nob.gt.1) call sbout1(io,0,'objmax ', - * fM,adummy,1,1) - if(ncnstr.eq.0) write(io,9909) - call sbout1(io,ncnstr,'constraints ',dummy,g,2,1) - if(ncnstr.ne.0) write(io,9909) - goto 9000 - 20 if(iprint.eq.1.and.nstop.eq.0) write(io,9900) iter - if(iprint.ge.2.and.nstop.eq.0.and.ipspan.ge.10) - * write(io,9900) iter - iter=iter+1 - if(initvl.eq.0) - * call sbout1(io,nparam,'x ',dummy,x,2,1) - call sbout1(io,nob,'objectives ',dummy,f,2,1) - if (mode.eq.1.and.iter.gt.1) - * call sbout1(io,0,'objective max4 ',fM,adummy,1,1) - if(nob.gt.1) call sbout1(io,0,'objmax ', - * fM,adummy,1,1) - if(ncnstr.eq.0) go to 110 - call sbout1(io,ncnstr,'constraints ',dummy,g,2,1) - SCV=0.d0 - do 100 i=ncn+1,ncnstr - if(i.le.nnineq) SCV=SCV+dmax1(0.d0,g(i)) - if(i.gt.nnineq) SCV=SCV+dabs(g(i)) - 100 continue - if(initvl.eq.0) - * call sbout1(io,0,'SCV ',SCV,adummy,1,1) - 110 continue - if(iter.le.1) write(io,9909) - if(iter.le.1.and.ipspan.lt.10) write(io,9900) iter - if(iter.le.1) goto 9000 - if(iprint.ge.2.and.initvl.eq.0) - * call sbout1(io,0,'step ',steps,adummy,1,1) - if(initvl.eq.0.and.(nstop.eq.0.or.info.ne.0.or.iprint.eq.2)) then - call sbout1(io,0,'d0norm ',d0norm,adummy,1,1) - call sbout1(io,0,'ktnorm ',sktnom,adummy,1,1) - endif - if(initvl.eq.0.and.feasb) write(io,9902) ncallf - if(initvl.eq.0.and.(nn.ne.0.or..not.feasb)) write(io,9903) ncallg - if(nstop.ne.0) write(io,9909) - if(nstop.ne.0.and.iter.le.miter.and.ipspan.lt.10) - * write(io,9900) iter - 120 if(nstop.ne.0.or.iprint.eq.0) goto 9000 - write(io,9909) - write(io,9901) info - if(info.eq.0) write(io,9904) - if(info.eq.0.and.sktnom.gt.0.1d0) write(io,9910) - if(info.eq.3) write(io,9905) - if(info.eq.4) write(io,9906) - if(info.eq.5) write(io,9907) - if(info.eq.6) write(io,9908) - write(io,9909) - 9000 initvl=0 - if(ipspan.ge.10) ipyes=mod(iter,ipspan) - if(iter.le.miter) return - nstop=0 - info=3 - write(io,9905) - return - 9900 format(1x,9hiteration,t22,i22) - 9901 format(1x,6hinform,t22,i22) - 9902 format(1x,6hncallf,t22,i22) - 9903 format(1x,6hncallg,t22,i22) - 9904 format(1x,'Normal termination: You have obtained a solution !!') - 9905 format(1x,'Error : Maximum iterations have been reached ', - * 'before obtaining a solution !!'/) - 9906 format(1x,'Error : Step size has been smaller than ', - * 'the computed machine precision !!'/) - 9907 format(1x,'Error : Failure of the QP solver ', - * 'in constructing d0 !!', - * /1x,' A more robust QP solver may succeed.'/) - 9908 format(1x,'Error : Failure of the QP solver ', - * 'in constructing d1 !!', - * /1x,' A more robust QP solver may succeed.'/) - 9909 format(1x,/) - 9910 format(1x,'Warning: Norm of Kuhn-Tucker vector is large !!'/) - end
deleted file mode 100644 --- a/libcruft/fsqp/ql0001.f +++ /dev/null @@ -1,226 +0,0 @@ - SUBROUTINE QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU, - 1 X,U,IOUT,IFAIL,IPRINT,WAR,LWAR,IWAR,LIWAR) -c -cCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -c -c !!!! NOTICE !!!! -c -c 1. The routines contained in this file are due to Prof. K.Schittkowski -c of the University of Bayreuth, Germany (modification of routines -c due to Prof. MJD Powell at the University of Cambridge). They can -c be freely distributed. -c -c 2. A minor modification was performed at the University of Maryland. -c It is marked in the code by "c umd". -c -c A.L. Tits and J.L. Zhou -c University of Maryland -C -C*********************************************************************** -C -C -C SOLUTION OF QUADRATIC PROGRAMMING PROBLEMS -C -C -C -C QL0001 SOLVES THE QUADRATIC PROGRAMMING PROBLEM -C -C MINIMIZE .5*X'*C*X + D'*X -C SUBJECT TO A(J)*X + B(J) = 0 , J=1,...,ME -C A(J)*X + B(J) >= 0 , J=ME+1,...,M -C XL <= X <= XU -C -C HERE C MUST BE AN N BY N SYMMETRIC AND POSITIVE MATRIX, D AN N-DIMENSIONAL -C VECTOR, A AN M BY N MATRIX AND B AN M-DIMENSIONAL VECTOR. THE ABOVE -C SITUATION IS INDICATED BY IWAR(1)=1. ALTERNATIVELY, I.E. IF IWAR(1)=0, -C THE OBJECTIVE FUNCTION MATRIX CAN ALSO BE PROVIDED IN FACTORIZED FORM. -C IN THIS CASE, C IS AN UPPER TRIANGULAR MATRIX. -C -C THE SUBROUTINE REORGANIZES SOME DATA SO THAT THE PROBLEM CAN BE SOLVED -C BY A MODIFICATION OF AN ALGORITHM PROPOSED BY POWELL (1983). -C -C -C USAGE: -C -C QL0001(M,ME,MMAX,N,NMAX,MNN,C,D,A,B,XL,XU,X,U,IOUT,IFAIL,IPRINT, -C WAR,LWAR,IWAR,LIWAR) -C -C -C DEFINITION OF THE PARAMETERS: -C -C M : TOTAL NUMBER OF CONSTRAINTS. -C ME : NUMBER OF EQUALITY CONSTRAINTS. -C MMAX : ROW DIMENSION OF A. MMAX MUST BE AT LEAST ONE AND GREATER -C THAN M. -C N : NUMBER OF VARIABLES. -C NMAX : ROW DIMENSION OF C. NMAX MUST BE GREATER OR EQUAL TO N. -C MNN : MUST BE EQUAL TO M + N + N. -C C(NMAX,NMAX): OBJECTIVE FUNCTION MATRIX WHICH SHOULD BE SYMMETRIC AND -C POSITIVE DEFINITE. IF IWAR(1) = 0, C IS SUPPOSED TO BE THE -C CHOLESKEY-FACTOR OF ANOTHER MATRIX, I.E. C IS UPPER -C TRIANGULAR. -C D(NMAX) : CONTAINS THE CONSTANT VECTOR OF THE OBJECTIVE FUNCTION. -C A(MMAX,NMAX): CONTAINS THE DATA MATRIX OF THE LINEAR CONSTRAINTS. -C B(MMAX) : CONTAINS THE CONSTANT DATA OF THE LINEAR CONSTRAINTS. -C XL(N),XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR THE VARIABLES. -C X(N) : ON RETURN, X CONTAINS THE OPTIMAL SOLUTION VECTOR. -C U(MNN) : ON RETURN, U CONTAINS THE LAGRANGE MULTIPLIERS. THE FIRST -C M POSITIONS ARE RESERVED FOR THE MULTIPLIERS OF THE M -C LINEAR CONSTRAINTS AND THE SUBSEQUENT ONES FOR THE -C MULTIPLIERS OF THE LOWER AND UPPER BOUNDS. ON SUCCESSFUL -C TERMINATION, ALL VALUES OF U WITH RESPECT TO INEQUALITIES -C AND BOUNDS SHOULD BE GREATER OR EQUAL TO ZERO. -C IOUT : INTEGER INDICATING THE DESIRED OUTPUT UNIT NUMBER, I.E. -C ALL WRITE-STATEMENTS START WITH 'WRITE(IOUT,... '. -C IFAIL : SHOWS THE TERMINATION REASON. -C IFAIL = 0 : SUCCESSFUL RETURN. -C IFAIL = 1 : TOO MANY ITERATIONS (MORE THAN 40*(N+M)). -C IFAIL = 2 : ACCURACY INSUFFICIENT TO SATISFY CONVERGENCE -C CRITERION. -C IFAIL = 5 : LENGTH OF A WORKING ARRAY IS TOO SHORT. -C IFAIL > 10 : THE CONSTRAINTS ARE INCONSISTENT. -C IPRINT : OUTPUT CONTROL. -C IPRINT = 0 : NO OUTPUT OF QL0001. -C IPRINT > 0 : BRIEF OUTPUT IN ERROR CASES. -C WAR(LWAR) : REAL WORKING ARRAY. THE LENGTH LWAR SHOULD BE GRATER THAN -C NMAX*(3*NMAX+15)/2 + 2*M. -C IWAR(LIWAR): INTEGER WORKING ARRAY. THE LENGTH LIWAR SHOULD BE AT -C LEAST N. -C IF IWAR(1)=0 INITIALLY, THEN THE CHOLESKY DECOMPOSITION -C WHICH IS REQUIRED BY THE DUAL ALGORITHM TO GET THE FIRST -C UNCONSTRAINED MINIMUM OF THE OBJECTIVE FUNCTION, IS -C PERFORMED INTERNALLY. OTHERWISE, I.E. IF IWAR(1)=1, THEN -C IT IS ASSUMED THAT THE USER PROVIDES THE INITIAL FAC- -C TORIZATION BY HIMSELF AND STORES IT IN THE UPPER TRIAN- -C GULAR PART OF THE ARRAY C. -C -C A NAMED COMMON-BLOCK /CMACHE/EPS MUST BE PROVIDED BY THE USER, -C WHERE EPS DEFINES A GUESS FOR THE UNDERLYING MACHINE PRECISION. -C -C -C AUTHOR: K. SCHITTKOWSKI, -C MATHEMATISCHES INSTITUT, -C UNIVERSITAET BAYREUTH, -C 8580 BAYREUTH, -C GERMANY, F.R. -C -C -C VERSION: 1.4 (MARCH, 1987) -C -C -C********************************************************************* -C -C - INTEGER NMAX,MMAX,N,MNN,LWAR,LIWAR - DIMENSION C(NMAX,NMAX),D(NMAX),A(MMAX,NMAX),B(MMAX), - 1 XL(N),XU(N),X(N),U(MNN),WAR(LWAR),IWAR(LIWAR) - DOUBLE PRECISION C,D,A,B,X,XL,XU,U,WAR,DIAG,ZERO, - 1 EPS,QPEPS,TEN - INTEGER M,ME,IOUT,IFAIL,IPRINT,IWAR,INW1,INW2,IN,J,LW,MN,I, - 1 IDIAG,INFO,NACT,MAXIT - LOGICAL LQL -C -C INTRINSIC FUNCTIONS: DSQRT -C - COMMON /CMACHE/EPS -C -C CONSTANT DATA -C -c################################################################# -c - - if(c(nmax,nmax).eq.0.d0) c(nmax,nmax)=eps -c -c umd -c This prevents a subsequent more major modification of the Hessian -c matrix in the important case when a minmax problem (yielding a -c singular Hessian matrix) is being solved. -c ----UMCP, April 1991, Jian L. Zhou -c################################################################# -c - LQL=.FALSE. - IF (IWAR(1).EQ.1) LQL=.TRUE. - ZERO=0.0D+0 - TEN=1.D+1 - MAXIT=40*(M+N) - QPEPS=EPS - INW1=1 - INW2=INW1+M -C -C PREPARE PROBLEM DATA FOR EXECUTION -C - IF (M.LE.0) GOTO 20 - IN=INW1 - DO 10 J=1,M - WAR(IN)=-B(J) - 10 IN=IN+1 - 20 LW=NMAX*(3*NMAX+15)/2 + M - IF (INW2+LW-1 .GT. LWAR) GOTO 80 - IF (LIWAR.LT.N) GOTO 81 - IF (MNN.LT.M+N+N) GOTO 82 - MN=M+N -C -C CALL OF QL0002 -C - CALL QL0002(N,M,ME,MMAX,MN,MNN,NMAX,LQL,A,WAR(INW1), - 1 D,C,XL,XU,X,NACT,IWAR,MAXIT,QPEPS,INFO,DIAG, - 2 WAR(INW2),LW) -C -C TEST OF MATRIX CORRECTIONS -C - IFAIL=0 - IF (INFO.EQ.1) GOTO 40 - IF (INFO.EQ.2) GOTO 90 - IDIAG=0 - IF ((DIAG.GT.ZERO).AND.(DIAG.LT.1000.0)) IDIAG=DIAG - IF ((IPRINT.GT.0).AND.(IDIAG.GT.0)) - 1 WRITE(IOUT,1000) IDIAG - IF (INFO .LT. 0) GOTO 70 -C -C REORDER MULTIPLIER -C - DO 50 J=1,MNN - 50 U(J)=ZERO - IN=INW2-1 - IF (NACT.EQ.0) GOTO 30 - DO 60 I=1,NACT - J=IWAR(I) - U(J)=WAR(IN+I) - 60 CONTINUE - 30 CONTINUE - RETURN -C -C ERROR MESSAGES -C - 70 IFAIL=-INFO+10 - IF ((IPRINT.GT.0).AND.(NACT.GT.0)) - 1 WRITE(IOUT,1100) -INFO,(IWAR(I),I=1,NACT) - RETURN - 80 IFAIL=5 - IF (IPRINT .GT. 0) WRITE(IOUT,1200) - RETURN - 81 IFAIL=5 - IF (IPRINT .GT. 0) WRITE(IOUT,1210) - RETURN - 82 IFAIL=5 - IF (IPRINT .GT. 0) WRITE(IOUT,1220) - RETURN - 40 IFAIL=1 - IF (IPRINT.GT.0) WRITE(IOUT,1300) MAXIT - RETURN - 90 IFAIL=2 - IF (IPRINT.GT.0) WRITE(IOUT,1400) - RETURN -C -C FORMAT-INSTRUCTIONS -C - 1000 FORMAT(/8X,28H***QL: MATRIX G WAS ENLARGED,I3, - 1 20H-TIMES BY UNITMATRIX) - 1100 FORMAT(/8X,18H***QL: CONSTRAINT ,I5, - 1 19H NOT CONSISTENT TO ,/,(10X,10I5)) - 1200 FORMAT(/8X,21H***QL: LWAR TOO SMALL) - 1210 FORMAT(/8X,22H***QL: LIWAR TOO SMALL) - 1220 FORMAT(/8X,20H***QL: MNN TOO SMALL) - 1300 FORMAT(/8X,37H***QL: TOO MANY ITERATIONS (MORE THAN,I6,1H)) - 1400 FORMAT(/8X,50H***QL: ACCURACY INSUFFICIENT TO ATTAIN CONVERGENCE) - END
deleted file mode 100644 --- a/libcruft/fsqp/ql0002.f +++ /dev/null @@ -1,941 +0,0 @@ -C - SUBROUTINE QL0002(N,M,MEQ,MMAX,MN,MNN,NMAX,LQL,A,B,GRAD,G, - 1 XL,XU,X,NACT,IACT,MAXIT,VSMALL,INFO,DIAG,W,LW) -C -C************************************************************************** -C -C -C THIS SUBROUTINE SOLVES THE QUADRATIC PROGRAMMING PROBLEM -C -C MINIMIZE GRAD'*X + 0.5 * X*G*X -C SUBJECT TO A(K)*X = B(K) K=1,2,...,MEQ, -C A(K)*X >= B(K) K=MEQ+1,...,M, -C XL <= X <= XU -C -C THE QUADRATIC PROGRAMMING METHOD PROCEEDS FROM AN INITIAL CHOLESKY- -C DECOMPOSITION OF THE OBJECTIVE FUNCTION MATRIX, TO CALCULATE THE -C UNIQUELY DETERMINED MINIMIZER OF THE UNCONSTRAINED PROBLEM. -C SUCCESSIVELY ALL VIOLATED CONSTRAINTS ARE ADDED TO A WORKING SET -C AND A MINIMIZER OF THE OBJECTIVE FUNCTION SUBJECT TO ALL CONSTRAINTS -C IN THIS WORKING SET IS COMPUTED. IT IS POSSIBLE THAT CONSTRAINTS -C HAVE TO LEAVE THE WORKING SET. -C -C -C DESCRIPTION OF PARAMETERS: -C -C N : IS THE NUMBER OF VARIABLES. -C M : TOTAL NUMBER OF CONSTRAINTS. -C MEQ : NUMBER OF EQUALITY CONTRAINTS. -C MMAX : ROW DIMENSION OF A, DIMENSION OF B. MMAX MUST BE AT -C LEAST ONE AND GREATER OR EQUAL TO M. -C MN : MUST BE EQUAL M + N. -C MNN : MUST BE EQUAL M + N + N. -C NMAX : ROW DIEMSION OF G. MUST BE AT LEAST N. -C LQL : DETERMINES INITIAL DECOMPOSITION. -C LQL = .FALSE. : THE UPPER TRIANGULAR PART OF THE MATRIX G -C CONTAINS INITIALLY THE CHOLESKY-FACTOR OF A SUITABLE -C DECOMPOSITION. -C LQL = .TRUE. : THE INITIAL CHOLESKY-FACTORISATION OF G IS TO BE -C PERFORMED BY THE ALGORITHM. -C A(MMAX,NMAX) : A IS A MATRIX WHOSE COLUMNS ARE THE CONSTRAINTS NORMALS. -C B(MMAX) : CONTAINS THE RIGHT HAND SIDES OF THE CONSTRAINTS. -C GRAD(N) : CONTAINS THE OBJECTIVE FUNCTION VECTOR GRAD. -C G(NMAX,N): CONTAINS THE SYMMETRIC OBJECTIVE FUNCTION MATRIX. -C XL(N), XU(N): CONTAIN THE LOWER AND UPPER BOUNDS FOR X. -C X(N) : VECTOR OF VARIABLES. -C NACT : FINAL NUMBER OF ACTIVE CONSTRAINTS. -C IACT(K) (K=1,2,...,NACT): INDICES OF THE FINAL ACTIVE CONSTRAINTS. -C INFO : REASON FOR THE RETURN FROM THE SUBROUTINE. -C INFO = 0 : CALCULATION WAS TERMINATED SUCCESSFULLY. -C INFO = 1 : MAXIMUM NUMBER OF ITERATIONS ATTAINED. -C INFO = 2 : ACCURACY IS INSUFFICIENT TO MAINTAIN INCREASING -C FUNCTION VALUES. -C INFO < 0 : THE CONSTRAINT WITH INDEX ABS(INFO) AND THE CON- -C STRAINTS WHOSE INDICES ARE IACT(K), K=1,2,...,NACT, -C ARE INCONSISTENT. -C MAXIT : MAXIMUM NUMBER OF ITERATIONS. -C VSMALL : REQUIRED ACCURACY TO BE ACHIEVED (E.G. IN THE ORDER OF THE -C MACHINE PRECISION FOR SMALL AND WELL-CONDITIONED PROBLEMS). -C DIAG : ON RETURN DIAG IS EQUAL TO THE MULTIPLE OF THE UNIT MATRIX -C THAT WAS ADDED TO G TO ACHIEVE POSITIVE DEFINITENESS. -C W(LW) : THE ELEMENTS OF W(.) ARE USED FOR WORKING SPACE. THE LENGTH -C OF W MUST NOT BE LESS THAN (1.5*NMAX*NMAX + 10*NMAX + M). -C WHEN INFO = 0 ON RETURN, THE LAGRANGE MULTIPLIERS OF THE -C FINAL ACTIVE CONSTRAINTS ARE HELD IN W(K), K=1,2,...,NACT. -C THE VALUES OF N, M, MEQ, MMAX, MN, MNN AND NMAX AND THE ELEMENTS OF -C A, B, GRAD AND G ARE NOT ALTERED. -C -C THE FOLLOWING INTEGERS ARE USED TO PARTITION W: -C THE FIRST N ELEMENTS OF W HOLD LAGRANGE MULTIPLIER ESTIMATES. -C W(IWZ+I+(N-1)*J) HOLDS THE MATRIX ELEMENT Z(I,J). -C W(IWR+I+0.5*J*(J-1)) HOLDS THE UPPER TRIANGULAR MATRIX -C ELEMENT R(I,J). THE SUBSEQUENT N COMPONENTS OF W MAY BE -C TREATED AS AN EXTRA COLUMN OF R(.,.). -C W(IWW-N+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE. -C W(IWW+I) (I=1,2,...,N) ARE USED FOR TEMPORARY STORAGE. -C W(IWD+I) (I=1,2,...,N) HOLDS G(I,I) DURING THE CALCULATION. -C W(IWX+I) (I=1,2,...,N) HOLDS VARIABLES THAT WILL BE USED TO -C TEST THAT THE ITERATIONS INCREASE THE OBJECTIVE FUNCTION. -C W(IWA+K) (K=1,2,...,M) USUALLY HOLDS THE RECIPROCAL OF THE -C LENGTH OF THE K-TH CONSTRAINT, BUT ITS SIGN INDICATES -C WHETHER THE CONSTRAINT IS ACTIVE. -C -C -C AUTHOR: K. SCHITTKOWSKI, -C MATHEMATISCHES INSTITUT, -C UNIVERSITAET BAYREUTH, -C 8580 BAYREUTH, -C GERMANY, F.R. -C -C AUTHOR OF ORIGINAL VERSION: -C M.J.D. POWELL, DAMTP, -C UNIVERSITY OF CAMBRIDGE, SILVER STREET -C CAMBRIDGE, -C ENGLAND -C -C -C REFERENCE: M.J.D. POWELL: ZQPCVX, A FORTRAN SUBROUTINE FOR CONVEX -C PROGRAMMING, REPORT DAMTP/1983/NA17, UNIVERSITY OF -C CAMBRIDGE, ENGLAND, 1983. -C -C -C VERSION : 2.0 (MARCH, 1987) -C -C -C************************************************************************* -C - INTEGER MMAX,NMAX,N,LW - DIMENSION A(MMAX,NMAX),B(MMAX),GRAD(N),G(NMAX,N),X(N),IACT(N), - 1 W(LW),XL(N),XU(N) - INTEGER M,MEQ,MN,MNN,NACT,IACT,INFO,MAXIT - DOUBLE PRECISION CVMAX,DIAG,DIAGR,FDIFF,FDIFFA,GA,GB,PARINC,PARNEW - 1 ,RATIO,RES,STEP,SUM,SUMX,SUMY,SUMA,SUMB,SUMC,TEMP,TEMPA, - 2 VSMALL,XMAG,XMAGR,ZERO,ONE,TWO,ONHA,VFACT - DOUBLE PRECISION A,B,G,GRAD,W,X,XL,XU -C -C INTRINSIC FUNCTIONS: DMAX1,DSQRT,DABS,DMIN1 -C - INTEGER IWZ,IWR,IWW,IWD,IWA,IFINC,KFINC,K,I,IA,ID,II,IR,IRA, - 1 IRB,J,NM,IZ,IZA,ITERC,ITREF,JFINC,IFLAG,IWS,IS,K1,IW,KK,IP, - 2 IPP,IL,IU,JU,KFLAG,LFLAG,JFLAG,KDROP,NU,MFLAG,KNEXT,IX,IWX, - 3 IWY,IY,JL - LOGICAL LQL,LOWER -C -C INITIAL ADDRESSES -C - IWZ=NMAX - IWR=IWZ+NMAX*NMAX - IWW=IWR+(NMAX*(NMAX+3))/2 - IWD=IWW+NMAX - IWX=IWD+NMAX - IWA=IWX+NMAX -C -C SET SOME CONSTANTS. -C - ZERO=0.D+0 - ONE=1.D+0 - TWO=2.D+0 - ONHA=1.5D+0 - VFACT=1.D+0 -C -C SET SOME PARAMETERS. -C NUMBER LESS THAN VSMALL ARE ASSUMED TO BE NEGLIGIBLE. -C THE MULTIPLE OF I THAT IS ADDED TO G IS AT MOST DIAGR TIMES -C THE LEAST MULTIPLE OF I THAT GIVES POSITIVE DEFINITENESS. -C X IS RE-INITIALISED IF ITS MAGNITUDE IS REDUCED BY THE -C FACTOR XMAGR. -C A CHECK IS MADE FOR AN INCREASE IN F EVERY IFINC ITERATIONS, -C AFTER KFINC ITERATIONS ARE COMPLETED. -C - DIAGR=TWO - XMAGR=1.0D-2 - IFINC=3 - KFINC=MAX0(10,N) -C -C FIND THE RECIPROCALS OF THE LENGTHS OF THE CONSTRAINT NORMALS. -C RETURN IF A CONSTRAINT IS INFEASIBLE DUE TO A ZERO NORMAL. -C - NACT=0 - IF (M .LE. 0) GOTO 45 - DO 40 K=1,M - SUM=ZERO - DO 10 I=1,N - 10 SUM=SUM+A(K,I)**2 - IF (SUM .GT. ZERO) GOTO 20 - IF (B(K) .EQ. ZERO) GOTO 30 - INFO=-K - IF (K .LE. MEQ) GOTO 730 - IF (B(K)) 30,30,730 - 20 SUM=ONE/DSQRT(SUM) - 30 IA=IWA+K - 40 W(IA)=SUM - 45 DO 50 K=1,N - IA=IWA+M+K - 50 W(IA)=ONE -C -C IF NECESSARY INCREASE THE DIAGONAL ELEMENTS OF G. -C - IF (.NOT. LQL) GOTO 165 - DIAG=ZERO - DO 60 I=1,N - ID=IWD+I - W(ID)=G(I,I) - DIAG=DMAX1(DIAG,VSMALL-W(ID)) - IF (I .EQ. N) GOTO 60 - II=I+1 - DO 55 J=II,N - GA=-DMIN1(W(ID),G(J,J)) - GB=DABS(W(ID)-G(J,J))+DABS(G(I,J)) - IF (GB .GT. ZERO) GA=GA+G(I,J)**2/GB - 55 DIAG=DMAX1(DIAG,GA) - 60 CONTINUE - IF (DIAG .LE. ZERO) GOTO 90 - 70 DIAG=DIAGR*DIAG - DO 80 I=1,N - ID=IWD+I - 80 G(I,I)=DIAG+W(ID) -C -C FORM THE CHOLESKY FACTORISATION OF G. THE TRANSPOSE -C OF THE FACTOR WILL BE PLACED IN THE R-PARTITION OF W. -C - 90 IR=IWR - DO 130 J=1,N - IRA=IWR - IRB=IR+1 - DO 120 I=1,J - TEMP=G(I,J) - IF (I .EQ. 1) GOTO 110 - DO 100 K=IRB,IR - IRA=IRA+1 - 100 TEMP=TEMP-W(K)*W(IRA) - 110 IR=IR+1 - IRA=IRA+1 - IF (I .LT. J) W(IR)=TEMP/W(IRA) - 120 CONTINUE - IF (TEMP .LT. VSMALL) GOTO 140 - 130 W(IR)=DSQRT(TEMP) - GOTO 170 -C -C INCREASE FURTHER THE DIAGONAL ELEMENT OF G. -C - 140 W(J)=ONE - SUMX=ONE - K=J - 150 SUM=ZERO - IRA=IR-1 - DO 160 I=K,J - SUM=SUM-W(IRA)*W(I) - 160 IRA=IRA+I - IR=IR-K - K=K-1 - W(K)=SUM/W(IR) - SUMX=SUMX+W(K)**2 - IF (K .GE. 2) GOTO 150 - DIAG=DIAG+VSMALL-TEMP/SUMX - GOTO 70 -C -C STORE THE CHOLESKY FACTORISATION IN THE R-PARTITION -C OF W. -C - 165 IR=IWR - DO 166 I=1,N - DO 166 J=1,I - IR=IR+1 - 166 W(IR)=G(J,I) -C -C SET Z THE INVERSE OF THE MATRIX IN R. -C - 170 NM=N-1 - DO 220 I=1,N - IZ=IWZ+I - IF (I .EQ. 1) GOTO 190 - DO 180 J=2,I - W(IZ)=ZERO - 180 IZ=IZ+N - 190 IR=IWR+(I+I*I)/2 - W(IZ)=ONE/W(IR) - IF (I .EQ. N) GOTO 220 - IZA=IZ - DO 210 J=I,NM - IR=IR+I - SUM=ZERO - DO 200 K=IZA,IZ,N - SUM=SUM+W(K)*W(IR) - 200 IR=IR+1 - IZ=IZ+N - 210 W(IZ)=-SUM/W(IR) - 220 CONTINUE -C -C SET THE INITIAL VALUES OF SOME VARIABLES. -C ITERC COUNTS THE NUMBER OF ITERATIONS. -C ITREF IS SET TO ONE WHEN ITERATIVE REFINEMENT IS REQUIRED. -C JFINC INDICATES WHEN TO TEST FOR AN INCREASE IN F. -C - ITERC=1 - ITREF=0 - JFINC=-KFINC -C -C SET X TO ZERO AND SET THE CORRESPONDING RESIDUALS OF THE -C KUHN-TUCKER CONDITIONS. -C - 230 IFLAG=1 - IWS=IWW-N - DO 240 I=1,N - X(I)=ZERO - IW=IWW+I - W(IW)=GRAD(I) - IF (I .GT. NACT) GOTO 240 - W(I)=ZERO - IS=IWS+I - K=IACT(I) - IF (K .LE. M) GOTO 235 - IF (K .GT. MN) GOTO 234 - K1=K-M - W(IS)=XL(K1) - GOTO 240 - 234 K1=K-MN - W(IS)=-XU(K1) - GOTO 240 - 235 W(IS)=B(K) - 240 CONTINUE - XMAG=ZERO - VFACT=1.D+0 - IF (NACT) 340,340,280 -C -C SET THE RESIDUALS OF THE KUHN-TUCKER CONDITIONS FOR GENERAL X. -C - 250 IFLAG=2 - IWS=IWW-N - DO 260 I=1,N - IW=IWW+I - W(IW)=GRAD(I) - IF (LQL) GOTO 259 - ID=IWD+I - W(ID)=ZERO - DO 251 J=I,N - 251 W(ID)=W(ID)+G(I,J)*X(J) - DO 252 J=1,I - ID=IWD+J - 252 W(IW)=W(IW)+G(J,I)*W(ID) - GOTO 260 - 259 DO 261 J=1,N - 261 W(IW)=W(IW)+G(I,J)*X(J) - 260 CONTINUE - IF (NACT .EQ. 0) GOTO 340 - DO 270 K=1,NACT - KK=IACT(K) - IS=IWS+K - IF (KK .GT. M) GOTO 265 - W(IS)=B(KK) - DO 264 I=1,N - IW=IWW+I - W(IW)=W(IW)-W(K)*A(KK,I) - 264 W(IS)=W(IS)-X(I)*A(KK,I) - GOTO 270 - 265 IF (KK .GT. MN) GOTO 266 - K1=KK-M - IW=IWW+K1 - W(IW)=W(IW)-W(K) - W(IS)=XL(K1)-X(K1) - GOTO 270 - 266 K1=KK-MN - IW=IWW+K1 - W(IW)=W(IW)+W(K) - W(IS)=-XU(K1)+X(K1) - 270 CONTINUE -C -C PRE-MULTIPLY THE VECTOR IN THE S-PARTITION OF W BY THE -C INVERS OF R TRANSPOSE. -C - 280 IR=IWR - IP=IWW+1 - IPP=IWW+N - IL=IWS+1 - IU=IWS+NACT - DO 310 I=IL,IU - SUM=ZERO - IF (I .EQ. IL) GOTO 300 - JU=I-1 - DO 290 J=IL,JU - IR=IR+1 - 290 SUM=SUM+W(IR)*W(J) - 300 IR=IR+1 - 310 W(I)=(W(I)-SUM)/W(IR) -C -C SHIFT X TO SATISFY THE ACTIVE CONSTRAINTS AND MAKE THE -C CORRESPONDING CHANGE TO THE GRADIENT RESIDUALS. -C - DO 330 I=1,N - IZ=IWZ+I - SUM=ZERO - DO 320 J=IL,IU - SUM=SUM+W(J)*W(IZ) - 320 IZ=IZ+N - X(I)=X(I)+SUM - IF (LQL) GOTO 329 - ID=IWD+I - W(ID)=ZERO - DO 321 J=I,N - 321 W(ID)=W(ID)+G(I,J)*SUM - IW=IWW+I - DO 322 J=1,I - ID=IWD+J - 322 W(IW)=W(IW)+G(J,I)*W(ID) - GOTO 330 - 329 DO 331 J=1,N - IW=IWW+J - 331 W(IW)=W(IW)+SUM*G(I,J) - 330 CONTINUE -C -C FORM THE SCALAR PRODUCT OF THE CURRENT GRADIENT RESIDUALS -C WITH EACH COLUMN OF Z. -C - 340 KFLAG=1 - GOTO 930 - 350 IF (NACT .EQ. N) GOTO 380 -C -C SHIFT X SO THAT IT SATISFIES THE REMAINING KUHN-TUCKER -C CONDITIONS. -C - IL=IWS+NACT+1 - IZA=IWZ+NACT*N - DO 370 I=1,N - SUM=ZERO - IZ=IZA+I - DO 360 J=IL,IWW - SUM=SUM+W(IZ)*W(J) - 360 IZ=IZ+N - 370 X(I)=X(I)-SUM - INFO=0 - IF (NACT .EQ. 0) GOTO 410 -C -C UPDATE THE LAGRANGE MULTIPLIERS. -C - 380 LFLAG=3 - GOTO 740 - 390 DO 400 K=1,NACT - IW=IWW+K - 400 W(K)=W(K)+W(IW) -C -C REVISE THE VALUES OF XMAG. -C BRANCH IF ITERATIVE REFINEMENT IS REQUIRED. -C - 410 JFLAG=1 - GOTO 910 - 420 IF (IFLAG .EQ. ITREF) GOTO 250 -C -C DELETE A CONSTRAINT IF A LAGRANGE MULTIPLIER OF AN -C INEQUALITY CONSTRAINT IS NEGATIVE. -C - KDROP=0 - GOTO 440 - 430 KDROP=KDROP+1 - IF (W(KDROP) .GE. ZERO) GOTO 440 - IF (IACT(KDROP) .LE. MEQ) GOTO 440 - NU=NACT - MFLAG=1 - GOTO 800 - 440 IF (KDROP .LT. NACT) GOTO 430 -C -C SEEK THE GREATEAST NORMALISED CONSTRAINT VIOLATION, DISREGARDING -C ANY THAT MAY BE DUE TO COMPUTER ROUNDING ERRORS. -C - 450 CVMAX=ZERO - IF (M .LE. 0) GOTO 481 - DO 480 K=1,M - IA=IWA+K - IF (W(IA) .LE. ZERO) GOTO 480 - SUM=-B(K) - DO 460 I=1,N - 460 SUM=SUM+X(I)*A(K,I) - SUMX=-SUM*W(IA) - IF (K .LE. MEQ) SUMX=DABS(SUMX) - IF (SUMX .LE. CVMAX) GOTO 480 - TEMP=DABS(B(K)) - DO 470 I=1,N - 470 TEMP=TEMP+DABS(X(I)*A(K,I)) - TEMPA=TEMP+DABS(SUM) - IF (TEMPA .LE. TEMP) GOTO 480 - TEMP=TEMP+ONHA*DABS(SUM) - IF (TEMP .LE. TEMPA) GOTO 480 - CVMAX=SUMX - RES=SUM - KNEXT=K - 480 CONTINUE - 481 DO 485 K=1,N - LOWER=.TRUE. - IA=IWA+M+K - IF (W(IA) .LE. ZERO) GOTO 485 - SUM=XL(K)-X(K) - IF (SUM) 482,485,483 - 482 SUM=X(K)-XU(K) - LOWER=.FALSE. - 483 IF (SUM .LE. CVMAX) GOTO 485 - CVMAX=SUM - RES=-SUM - KNEXT=K+M - IF (LOWER) GOTO 485 - KNEXT=K+MN - 485 CONTINUE -C -C TEST FOR CONVERGENCE -C - INFO=0 - IF (CVMAX .LE. VSMALL) GOTO 700 -C -C RETURN IF, DUE TO ROUNDING ERRORS, THE ACTUAL CHANGE IN -C X MAY NOT INCREASE THE OBJECTIVE FUNCTION -C - JFINC=JFINC+1 - IF (JFINC .EQ. 0) GOTO 510 - IF (JFINC .NE. IFINC) GOTO 530 - FDIFF=ZERO - FDIFFA=ZERO - DO 500 I=1,N - SUM=TWO*GRAD(I) - SUMX=DABS(SUM) - IF (LQL) GOTO 489 - ID=IWD+I - W(ID)=ZERO - DO 486 J=I,N - IX=IWX+J - 486 W(ID)=W(ID)+G(I,J)*(W(IX)+X(J)) - DO 487 J=1,I - ID=IWD+J - TEMP=G(J,I)*W(ID) - SUM=SUM+TEMP - 487 SUMX=SUMX+DABS(TEMP) - GOTO 495 - 489 DO 490 J=1,N - IX=IWX+J - TEMP=G(I,J)*(W(IX)+X(J)) - SUM=SUM+TEMP - 490 SUMX=SUMX+DABS(TEMP) - 495 IX=IWX+I - FDIFF=FDIFF+SUM*(X(I)-W(IX)) - 500 FDIFFA=FDIFFA+SUMX*DABS(X(I)-W(IX)) - INFO=2 - SUM=FDIFFA+FDIFF - IF (SUM .LE. FDIFFA) GOTO 700 - TEMP=FDIFFA+ONHA*FDIFF - IF (TEMP .LE. SUM) GOTO 700 - JFINC=0 - INFO=0 - 510 DO 520 I=1,N - IX=IWX+I - 520 W(IX)=X(I) -C -C FORM THE SCALAR PRODUCT OF THE NEW CONSTRAINT NORMAL WITH EACH -C COLUMN OF Z. PARNEW WILL BECOME THE LAGRANGE MULTIPLIER OF -C THE NEW CONSTRAINT. -C - 530 ITERC=ITERC+1 - IF (ITERC.LE.MAXIT) GOTO 531 - INFO=1 - GOTO 710 - 531 CONTINUE - IWS=IWR+(NACT+NACT*NACT)/2 - IF (KNEXT .GT. M) GOTO 541 - DO 540 I=1,N - IW=IWW+I - 540 W(IW)=A(KNEXT,I) - GOTO 549 - 541 DO 542 I=1,N - IW=IWW+I - 542 W(IW)=ZERO - K1=KNEXT-M - IF (K1 .GT. N) GOTO 545 - IW=IWW+K1 - W(IW)=ONE - IZ=IWZ+K1 - DO 543 I=1,N - IS=IWS+I - W(IS)=W(IZ) - 543 IZ=IZ+N - GOTO 550 - 545 K1=KNEXT-MN - IW=IWW+K1 - W(IW)=-ONE - IZ=IWZ+K1 - DO 546 I=1,N - IS=IWS+I - W(IS)=-W(IZ) - 546 IZ=IZ+N - GOTO 550 - 549 KFLAG=2 - GOTO 930 - 550 PARNEW=ZERO -C -C APPLY GIVENS ROTATIONS TO MAKE THE LAST (N-NACT-2) SCALAR -C PRODUCTS EQUAL TO ZERO. -C - IF (NACT .EQ. N) GOTO 570 - NU=N - NFLAG=1 - GOTO 860 -C -C BRANCH IF THERE IS NO NEED TO DELETE A CONSTRAINT. -C - 560 IS=IWS+NACT - IF (NACT .EQ. 0) GOTO 640 - SUMA=ZERO - SUMB=ZERO - SUMC=ZERO - IZ=IWZ+NACT*N - DO 563 I=1,N - IZ=IZ+1 - IW=IWW+I - SUMA=SUMA+W(IW)*W(IZ) - SUMB=SUMB+DABS(W(IW)*W(IZ)) - 563 SUMC=SUMC+W(IZ)**2 - TEMP=SUMB+.1D+0*DABS(SUMA) - TEMPA=SUMB+.2D+0*DABS(SUMA) - IF (TEMP .LE. SUMB) GOTO 570 - IF (TEMPA .LE. TEMP) GOTO 570 - IF (SUMB .GT. VSMALL) GOTO 5 - GOTO 570 - 5 SUMC=DSQRT(SUMC) - IA=IWA+KNEXT - IF (KNEXT .LE. M) SUMC=SUMC/W(IA) - TEMP=SUMC+.1D+0*DABS(SUMA) - TEMPA=SUMC+.2D+0*DABS(SUMA) - IF (TEMP .LE. SUMC) GOTO 567 - IF (TEMPA .LE. TEMP) GOTO 567 - GOTO 640 -C -C CALCULATE THE MULTIPLIERS FOR THE NEW CONSTRAINT NORMAL -C EXPRESSED IN TERMS OF THE ACTIVE CONSTRAINT NORMALS. -C THEN WORK OUT WHICH CONTRAINT TO DROP. -C - 567 LFLAG=4 - GOTO 740 - 570 LFLAG=1 - GOTO 740 -C -C COMPLETE THE TEST FOR LINEARLY DEPENDENT CONSTRAINTS. -C - 571 IF (KNEXT .GT. M) GOTO 574 - DO 573 I=1,N - SUMA=A(KNEXT,I) - SUMB=DABS(SUMA) - IF (NACT.EQ.0) GOTO 581 - DO 572 K=1,NACT - KK=IACT(K) - IF (KK.LE.M) GOTO 568 - KK=KK-M - TEMP=ZERO - IF (KK.EQ.I) TEMP=W(IWW+KK) - KK=KK-N - IF (KK.EQ.I) TEMP=-W(IWW+KK) - GOTO 569 - 568 CONTINUE - IW=IWW+K - TEMP=W(IW)*A(KK,I) - 569 CONTINUE - SUMA=SUMA-TEMP - 572 SUMB=SUMB+DABS(TEMP) - 581 IF (SUMA .LE. VSMALL) GOTO 573 - TEMP=SUMB+.1D+0*DABS(SUMA) - TEMPA=SUMB+.2D+0*DABS(SUMA) - IF (TEMP .LE. SUMB) GOTO 573 - IF (TEMPA .LE. TEMP) GOTO 573 - GOTO 630 - 573 CONTINUE - LFLAG=1 - GOTO 775 - 574 K1=KNEXT-M - IF (K1 .GT. N) K1=K1-N - DO 578 I=1,N - SUMA=ZERO - IF (I .NE. K1) GOTO 575 - SUMA=ONE - IF (KNEXT .GT. MN) SUMA=-ONE - 575 SUMB=DABS(SUMA) - IF (NACT.EQ.0) GOTO 582 - DO 577 K=1,NACT - KK=IACT(K) - IF (KK .LE. M) GOTO 579 - KK=KK-M - TEMP=ZERO - IF (KK.EQ.I) TEMP=W(IWW+KK) - KK=KK-N - IF (KK.EQ.I) TEMP=-W(IWW+KK) - GOTO 576 - 579 IW=IWW+K - TEMP=W(IW)*A(KK,I) - 576 SUMA=SUMA-TEMP - 577 SUMB=SUMB+DABS(TEMP) - 582 TEMP=SUMB+.1D+0*DABS(SUMA) - TEMPA=SUMB+.2D+0*DABS(SUMA) - IF (TEMP .LE. SUMB) GOTO 578 - IF (TEMPA .LE. TEMP) GOTO 578 - GOTO 630 - 578 CONTINUE - LFLAG=1 - GOTO 775 -C -C BRANCH IF THE CONTRAINTS ARE INCONSISTENT. -C - 580 INFO=-KNEXT - IF (KDROP .EQ. 0) GOTO 700 - PARINC=RATIO - PARNEW=PARINC -C -C REVISE THE LAGRANGE MULTIPLIERS OF THE ACTIVE CONSTRAINTS. -C - 590 IF (NACT.EQ.0) GOTO 601 - DO 600 K=1,NACT - IW=IWW+K - W(K)=W(K)-PARINC*W(IW) - IF (IACT(K) .GT. MEQ) W(K)=DMAX1(ZERO,W(K)) - 600 CONTINUE - 601 IF (KDROP .EQ. 0) GOTO 680 -C -C DELETE THE CONSTRAINT TO BE DROPPED. -C SHIFT THE VECTOR OF SCALAR PRODUCTS. -C THEN, IF APPROPRIATE, MAKE ONE MORE SCALAR PRODUCT ZERO. -C - NU=NACT+1 - MFLAG=2 - GOTO 800 - 610 IWS=IWS-NACT-1 - NU=MIN0(N,NU) - DO 620 I=1,NU - IS=IWS+I - J=IS+NACT - 620 W(IS)=W(J+1) - NFLAG=2 - GOTO 860 -C -C CALCULATE THE STEP TO THE VIOLATED CONSTRAINT. -C - 630 IS=IWS+NACT - 640 SUMY=W(IS+1) - STEP=-RES/SUMY - PARINC=STEP/SUMY - IF (NACT .EQ. 0) GOTO 660 -C -C CALCULATE THE CHANGES TO THE LAGRANGE MULTIPLIERS, AND REDUCE -C THE STEP ALONG THE NEW SEARCH DIRECTION IF NECESSARY. -C - LFLAG=2 - GOTO 740 - 650 IF (KDROP .EQ. 0) GOTO 660 - TEMP=ONE-RATIO/PARINC - IF (TEMP .LE. ZERO) KDROP=0 - IF (KDROP .EQ. 0) GOTO 660 - STEP=RATIO*SUMY - PARINC=RATIO - RES=TEMP*RES -C -C UPDATE X AND THE LAGRANGE MULTIPIERS. -C DROP A CONSTRAINT IF THE FULL STEP IS NOT TAKEN. -C - 660 IWY=IWZ+NACT*N - DO 670 I=1,N - IY=IWY+I - 670 X(I)=X(I)+STEP*W(IY) - PARNEW=PARNEW+PARINC - IF (NACT .GE. 1) GOTO 590 -C -C ADD THE NEW CONSTRAINT TO THE ACTIVE SET. -C - 680 NACT=NACT+1 - W(NACT)=PARNEW - IACT(NACT)=KNEXT - IA=IWA+KNEXT - IF (KNEXT .GT. MN) IA=IA-N - W(IA)=-W(IA) -C -C ESTIMATE THE MAGNITUDE OF X. THEN BEGIN A NEW ITERATION, -C RE-INITILISING X IF THIS MAGNITUDE IS SMALL. -C - JFLAG=2 - GOTO 910 - 690 IF (SUM .LT. (XMAGR*XMAG)) GOTO 230 - IF (ITREF) 450,450,250 -C -C INITIATE ITERATIVE REFINEMENT IF IT HAS NOT YET BEEN USED, -C OR RETURN AFTER RESTORING THE DIAGONAL ELEMENTS OF G. -C - 700 IF (ITERC .EQ. 0) GOTO 710 - ITREF=ITREF+1 - JFINC=-1 - IF (ITREF .EQ. 1) GOTO 250 - 710 IF (.NOT. LQL) RETURN - DO 720 I=1,N - ID=IWD+I - 720 G(I,I)=W(ID) - 730 RETURN -C -C -C THE REMAINIG INSTRUCTIONS ARE USED AS SUBROUTINES. -C -C -C******************************************************************** -C -C -C CALCULATE THE LAGRANGE MULTIPLIERS BY PRE-MULTIPLYING THE -C VECTOR IN THE S-PARTITION OF W BY THE INVERSE OF R. -C - 740 IR=IWR+(NACT+NACT*NACT)/2 - I=NACT - SUM=ZERO - GOTO 770 - 750 IRA=IR-1 - SUM=ZERO - IF (NACT.EQ.0) GOTO 761 - DO 760 J=I,NACT - IW=IWW+J - SUM=SUM+W(IRA)*W(IW) - 760 IRA=IRA+J - 761 IR=IR-I - I=I-1 - 770 IW=IWW+I - IS=IWS+I - W(IW)=(W(IS)-SUM)/W(IR) - IF (I .GT. 1) GOTO 750 - IF (LFLAG .EQ. 3) GOTO 390 - IF (LFLAG .EQ. 4) GOTO 571 -C -C CALCULATE THE NEXT CONSTRAINT TO DROP. -C - 775 IP=IWW+1 - IPP=IWW+NACT - KDROP=0 - IF (NACT.EQ.0) GOTO 791 - DO 790 K=1,NACT - IF (IACT(K) .LE. MEQ) GOTO 790 - IW=IWW+K - IF ((RES*W(IW)) .GE. ZERO) GOTO 790 - TEMP=W(K)/W(IW) - IF (KDROP .EQ. 0) GOTO 780 - IF (DABS(TEMP) .GE. DABS(RATIO)) GOTO 790 - 780 KDROP=K - RATIO=TEMP - 790 CONTINUE - 791 GOTO (580,650), LFLAG -C -C -C******************************************************************** -C -C -C DROP THE CONSTRAINT IN POSITION KDROP IN THE ACTIVE SET. -C - 800 IA=IWA+IACT(KDROP) - IF (IACT(KDROP) .GT. MN) IA=IA-N - W(IA)=-W(IA) - IF (KDROP .EQ. NACT) GOTO 850 -C -C SET SOME INDICES AND CALCULATE THE ELEMENTS OF THE NEXT -C GIVENS ROTATION. -C - IZ=IWZ+KDROP*N - IR=IWR+(KDROP+KDROP*KDROP)/2 - 810 IRA=IR - IR=IR+KDROP+1 - TEMP=DMAX1(DABS(W(IR-1)),DABS(W(IR))) - SUM=TEMP*DSQRT((W(IR-1)/TEMP)**2+(W(IR)/TEMP)**2) - GA=W(IR-1)/SUM - GB=W(IR)/SUM -C -C EXCHANGE THE COLUMNS OF R. -C - DO 820 I=1,KDROP - IRA=IRA+1 - J=IRA-KDROP - TEMP=W(IRA) - W(IRA)=W(J) - 820 W(J)=TEMP - W(IR)=ZERO -C -C APPLY THE ROTATION TO THE ROWS OF R. -C - W(J)=SUM - KDROP=KDROP+1 - DO 830 I=KDROP,NU - TEMP=GA*W(IRA)+GB*W(IRA+1) - W(IRA+1)=GA*W(IRA+1)-GB*W(IRA) - W(IRA)=TEMP - 830 IRA=IRA+I -C -C APPLY THE ROTATION TO THE COLUMNS OF Z. -C - DO 840 I=1,N - IZ=IZ+1 - J=IZ-N - TEMP=GA*W(J)+GB*W(IZ) - W(IZ)=GA*W(IZ)-GB*W(J) - 840 W(J)=TEMP -C -C REVISE IACT AND THE LAGRANGE MULTIPLIERS. -C - IACT(KDROP-1)=IACT(KDROP) - W(KDROP-1)=W(KDROP) - IF (KDROP .LT. NACT) GOTO 810 - 850 NACT=NACT-1 - GOTO (250,610), MFLAG -C -C -C******************************************************************** -C -C -C APPLY GIVENS ROTATION TO REDUCE SOME OF THE SCALAR -C PRODUCTS IN THE S-PARTITION OF W TO ZERO. -C - 860 IZ=IWZ+NU*N - 870 IZ=IZ-N - 880 IS=IWS+NU - NU=NU-1 - IF (NU .EQ. NACT) GOTO 900 - IF (W(IS) .EQ. ZERO) GOTO 870 - TEMP=DMAX1(DABS(W(IS-1)),DABS(W(IS))) - SUM=TEMP*DSQRT((W(IS-1)/TEMP)**2+(W(IS)/TEMP)**2) - GA=W(IS-1)/SUM - GB=W(IS)/SUM - W(IS-1)=SUM - DO 890 I=1,N - K=IZ+N - TEMP=GA*W(IZ)+GB*W(K) - W(K)=GA*W(K)-GB*W(IZ) - W(IZ)=TEMP - 890 IZ=IZ-1 - GOTO 880 - 900 GOTO (560,630), NFLAG -C -C -C******************************************************************** -C -C -C CALCULATE THE MAGNITUDE OF X AN REVISE XMAG. -C - 910 SUM=ZERO - DO 920 I=1,N - SUM=SUM+DABS(X(I))*VFACT*(DABS(GRAD(I))+DABS(G(I,I)*X(I))) - IF (LQL) GOTO 920 - IF (SUM .LT. 1.D-30) GOTO 920 - VFACT=1.D-10*VFACT - SUM=1.D-10*SUM - XMAG=1.D-10*XMAG - 920 CONTINUE - 925 XMAG=DMAX1(XMAG,SUM) - GOTO (420,690), JFLAG -C -C -C******************************************************************** -C -C -C PRE-MULTIPLY THE VECTOR IN THE W-PARTITION OF W BY Z TRANSPOSE. -C - 930 JL=IWW+1 - IZ=IWZ - DO 940 I=1,N - IS=IWS+I - W(IS)=ZERO - IWWN=IWW+N - DO 940 J=JL,IWWN - IZ=IZ+1 - 940 W(IS)=W(IS)+W(IZ)*W(J) - GOTO (350,550), KFLAG - RETURN - END
deleted file mode 100644 --- a/libcruft/fsqp/resign.f +++ /dev/null @@ -1,31 +0,0 @@ -c - subroutine resign(n,neqn,psf,grdpsf,penp,g,gradg,signeq,job1,job2) - integer i,j,job1,job2,n,neqn - double precision psf,grdpsf(1),penp(1),g(1),gradg(n,1), - * signeq(1) -c double precision psf,grdpsf(n),penp(neqn),g(neqn),gradg(n,neqn), -c * signeq(neqn) -c -c job1=10: g*signeq, job1=11: gradg*signeq, job1=12: job1=10&11 -c job1=20: do not change sign -c job2=10: psf, job2=11: grdpsf, job2=12: job2=10&11 -c job2=20: do not compute psf or grdpsf -c - if(job2.eq.10.or.job2.eq.12) psf=0.d0 - do 100 i=1,neqn - if(job1.eq.10.or.job1.eq.12) g(i)=signeq(i)*g(i) - if(job2.eq.10.or.job2.eq.12) psf=psf+g(i)*penp(i) - if(job1.eq.10.or.job1.eq.20) goto 100 - do 50 j=1,n - gradg(j,i)=gradg(j,i)*signeq(i) - 50 continue - 100 continue - if(job2.eq.10.or.job2.eq.20) goto 9000 - call nullvc(n,grdpsf) - do 120 i=1,n - do 110 j=1,neqn - 110 grdpsf(i)=grdpsf(i)+gradg(i,j)*penp(j) - 120 continue -c - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/sampl1.for +++ /dev/null @@ -1,98 +0,0 @@ -c -c problem description -c - program sampl1 -c - integer iwsize,nwsize,nparam,nf,nineq,neq - parameter (iwsize=29, nwsize=219) - parameter (nparam=3, nf=1) - parameter (nineq=1, neq=1) - integer iw(iwsize) - double precision x(nparam),bl(nparam),bu(nparam),f(nf+1), - * g(nineq+neq+1),w(nwsize) - external obj32,cntr32,grob32,grcn32 -c - integer mode,iprint,miter,neqn,nineqn,inform - double precision bigbnd,eps,epsneq,udelta -c - mode=100 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.d-08 - epsneq=0.d0 - udelta=0.d0 -c -c nparam=3 -c nf=1 - neqn=0 - nineqn=1 -c nineq=1 -c neq=1 -c - bl(1)=0.d0 - bl(2)=0.d0 - bl(3)=0.d0 - bu(1)=bigbnd - bu(2)=bigbnd - bu(3)=bigbnd -c -c give the initial value of x -c - x(1)=0.1d0 - x(2)=0.7d0 - x(3)=0.2d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epsneq,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj32,cntr32,grob32,grcn32) - end -c - subroutine obj32(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj -c - fj=(x(1)+3.d0*x(2)+x(3))**2+4.d0*(x(1)-x(2))**2 - return - end -c - subroutine grob32(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision dummy,x(nparam),gradfj(nparam), - * fa,fb - external dummy -c - fa=2.d0*(x(1)+3.d0*x(2)+x(3)) - fb=8.d0*(x(1)-x(2)) - gradfj(1)=fa+fb - gradfj(2)=fa*3.d0-fb - gradfj(3)=fa - return - end -c - subroutine cntr32(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj -c - go to (10,20),j - 10 gj=x(1)**3-6.0d0*x(2)-4.0d0*x(3)+3.d0 - return - 20 gj=1.0d0-x(1)-x(2)-x(3) - return - end -c - subroutine grcn32(nparam,j,x,gradgj,dummy) - integer nparam,j - double precision dummy,x(nparam),gradgj(nparam) - external dummy -c - go to (10,20),j - 10 gradgj(1)=3.d0*x(1)**2 - gradgj(2)=-6.d0 - gradgj(3)=-4.d0 - return - 20 gradgj(1)=-1.d0 - gradgj(2)=-1.d0 - gradgj(3)=-1.d0 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/sampl2.for +++ /dev/null @@ -1,91 +0,0 @@ -c -c problem description -c - program sampl2 -c - integer nwsize,iwsize,nparam,nf,nineq,neq - parameter (iwsize=1029, nwsize=7693) - parameter (nparam=6, nf=163, nineq=7, neq=0) - integer nineqn,neqn,mode,iprint,miter,inform, - * iw(iwsize) - double precision bigbnd,eps,epsneq,delta - double precision x(nparam),bl(nparam),bu(nparam),w(nwsize), - * f(nf+1),g(nineq+neq+1) - external objmad,cnmad,grobfd,grcnfd -c - mode=111 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.d-08 - epsneq=0.d0 - delta=0.d0 -c -c nparam=6 -c nf=163 - nineqn=0 - neqn=0 -c nineq=7 -c neq=0 -c - bl(1)=-bigbnd - bl(2)=-bigbnd - bl(3)=-bigbnd - bl(4)=-bigbnd - bl(5)=-bigbnd - bl(6)=-bigbnd - bu(1)=bigbnd - bu(2)=bigbnd - bu(3)=bigbnd - bu(4)=bigbnd - bu(5)=bigbnd - bu(6)=bigbnd -c -c give the initial value of x -c - x(1) = 0.5d0 - x(2) = 1.d0 - x(3) = 1.5d0 - x(4) = 2.d0 - x(5) = 2.5d0 - x(6) = 3.d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epsneq,delta,bl,bu,x,f, - * g,iw,iwsize,w,nwsize,objmad,cnmad,grobfd,grcnfd) - end -c - subroutine objmad(nparam,j,x,fj) - integer nparam,j,i - double precision x(nparam),theta,pi,fj -c - pi=3.14159265358979d0 - theta=pi*(8.5d0+dble(j)*0.5d0)/180.d0 - fj=0.d0 - do 10 i=1,6 - 10 fj=fj+dcos(2.d0*pi*x(i)*dsin(theta)) - fj=2.d0*(fj+dcos(2.d0*pi*3.5d0*dsin(theta)))/15.d0+1.d0/15.d0 - return - end -c - subroutine cnmad(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),ss,gj -c - ss=0.425d0 - goto(10,20,30,40,50,60,70),j - 10 gj=ss-x(1) - return - 20 gj=ss+x(1)-x(2) - return - 30 gj=ss+x(2)-x(3) - return - 40 gj=ss+x(3)-x(4) - return - 50 gj=ss+x(4)-x(5) - return - 60 gj=ss+x(5)-x(6) - return - 70 gj=ss+x(6)-3.5d0 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/sampl3.for +++ /dev/null @@ -1,94 +0,0 @@ -c -c problem description -c - integer iwsize,nwsize,nparam,nf,nineq,neq - parameter (iwsize=33, nwsize=284) - parameter (nparam=4, nf=1) - parameter (nineq=1, neq=1) - integer iw(iwsize) - double precision x(nparam),bl(nparam),bu(nparam),f(nf+1), - * g(nineq+neq+1),w(nwsize) - external obj,cntr,gradob,gradcn -c - integer mode,iprint,miter,neqn,nineqn,inform - double precision bigbnd,eps,epsneq,udelta -c - mode=100 - iprint=1 - miter=500 - bigbnd=1.d+10 - eps=1.d-07 - epsneq=7.d-6 - udelta=0.d0 -c - neqn=1 - nineqn=1 - bl(1)=1.d0 - bl(2)=1.d0 - bl(3)=1.d0 - bl(4)=1.d0 - bu(1)=5.d0 - bu(2)=5.d0 - bu(3)=5.d0 - bu(4)=5.d0 -c -c give the initial value of x -c - x(1)=1.d0 - x(2)=5.d0 - x(3)=5.d0 - x(4)=1.d0 -c - call FSQPD(nparam,nf,nineqn,nineq,neqn,neq,mode,iprint, - * miter,inform,bigbnd,eps,epsneq,udelta,bl,bu,x,f,g, - * iw,iwsize,w,nwsize,obj,cntr,gradob,gradcn) - end -c - subroutine obj(nparam,j,x,fj) - integer nparam,j - double precision x(nparam),fj -c - fj=x(1)*x(4)*(x(1)+x(2)+x(3))+x(3) - return - end -c - subroutine gradob(nparam,j,x,gradfj,dummy) - integer nparam,j - double precision dummy,x(nparam),gradfj(nparam) - external dummy -c - gradfj(1)=x(4)*(x(1)+x(2)+x(3))+x(1)*x(4) - gradfj(2)=x(1)*x(4) - gradfj(3)=x(1)*x(4)+1.d0 - gradfj(4)=x(1)*(x(1)+x(2)+x(3)) - return - end -c - subroutine cntr(nparam,j,x,gj) - integer nparam,j - double precision x(nparam),gj -c - goto (10,20),j - 10 gj=25.d0-x(1)*x(2)*x(3)*x(4) - return - 20 gj=x(1)**2+x(2)**2+x(3)**2+x(4)**2-40.d0 - return - end -c - subroutine gradcn(nparam,j,x,gradgj,dummy) - integer nparam,j - double precision dummy,x(nparam),gradgj(nparam) - external dummy -c - goto (10,20),j - 10 gradgj(1)=-x(2)*x(3)*x(4) - gradgj(2)=-x(1)*x(3)*x(4) - gradgj(3)=-x(1)*x(2)*x(4) - gradgj(4)=-x(1)*x(2)*x(3) - return - 20 gradgj(1)=2.d0*x(1) - gradgj(2)=2.d0*x(2) - gradgj(3)=2.d0*x(3) - gradgj(4)=2.d0*x(4) - return - end
deleted file mode 100644 --- a/libcruft/fsqp/sbout1.f +++ /dev/null @@ -1,23 +0,0 @@ -c - subroutine sbout1(io,n,s1,z,z1,job,level) -c implicit real*8(a-h,o-z) - integer io,n,job,level,j - double precision z,z1(1) - character*20 s1 -c - if (job.eq.2) goto 10 - if (level.eq.1)write(io,9900) s1,z - if (level.eq.2)write(io,9901) s1,z - return - 10 if (level.eq.1)write(io,9900) s1,z1(1) - if (level.eq.2)write(io,9901) s1,z1(1) - do 100 j=2,n - if (level.eq.1) write(io,9902) z1(j) - if (level.eq.2) write(io,9903) z1(j) - 100 continue - return - 9900 format(1x,a20,e22.14) - 9901 format(1x,t17,a20,t45,e22.14) - 9902 format(1x,t22,e22.14) - 9903 format(1x,t45,e22.14) - end
deleted file mode 100644 --- a/libcruft/fsqp/sbout2.f +++ /dev/null @@ -1,15 +0,0 @@ -c - subroutine sbout2(io,n,i,s1,s2,z) -c implicit real*8(a-h,o-z) - integer io,n,i,j - double precision z(n) - character*8 s1 - character*1 s2 -c - write(io,9900) s1,i,s2,z(1) - do 100 j=2,n - 100 write(io,9901) z(j) - return - 9900 format(1x,t17,a8,i5,a1,t45,e22.14) - 9901 format(1x,t45,e22.14) - end
deleted file mode 100644 --- a/libcruft/fsqp/scaprd.f +++ /dev/null @@ -1,16 +0,0 @@ -c - double precision function scaprd(n,x,y) -c implicit real*8(a-h,o-z) - integer n,i - double precision x(1),y(1),z -c double precision x(n),y(n),z -c -c compute z=x'y -c - z=0.d0 - do 100 i=1,n - z=x(i)*y(i)+z - 100 continue - scaprd=z - return - end
deleted file mode 100644 --- a/libcruft/fsqp/shift.f +++ /dev/null @@ -1,14 +0,0 @@ -c - subroutine shift(n,ii,iact) - integer n,ii,iact(1),j,k -c - if(ii.eq.iact(1)) return - do 200 j=1,n - if(ii.ne.iact(j)) goto 200 - do 100 k=j,2,-1 - 100 iact(k)=iact(k-1) - goto 210 - 200 continue - 210 iact(1)=ii - return - end
deleted file mode 100644 --- a/libcruft/fsqp/slope.f +++ /dev/null @@ -1,47 +0,0 @@ -c - double precision function slope(nob,nobL,neqn,nparam,feasb, - * f,gradf,grdpsf,x,y,fM,theta,job) -c implicit real*8(a-h,o-z) - integer nob,nobL,neqn,nparam,job,i - double precision fM,theta,slope1,dmax1,dmin1,rhs,rhog, - * grdftx,grdfty,diff,scaprd,grpstx,grpsty - double precision f(nob),gradf(nparam,nob),grdpsf(nparam), - * x(nparam),y(nparam) -c double precision f(1),gradf(nparam,1),grdpsf(nparam), -c * x(nparam),y(nparam) - logical feasb -c - double precision bigbnd,dummy - common /fsqpq1/bigbnd,dummy -c -c job=0 : compute the generalized gradient of the minimax -c job=1 : compute rhog in mode = 1 -c - slope=-bigbnd - if(neqn.eq.0.or..not.feasb) then - grpstx=0.d0 - grpsty=0.d0 - else - grpstx=scaprd(nparam,grdpsf,x) - grpsty=scaprd(nparam,grdpsf,y) - endif - do 100 i=1,nob - slope1=f(i)+scaprd(nparam,gradf(1,i),x) - slope=dmax1(slope,slope1) - if(nobL.ne.nob) slope=dmax1(slope,-slope1) - 100 continue - slope=slope-fM-grpstx - if (job.eq.0) goto 9000 - rhs=theta*slope+fM - rhog=1.d0 - do 200 i=1,nob - grdftx=scaprd(nparam,gradf(1,i),x)-grpstx - grdfty=scaprd(nparam,gradf(1,i),y)-grpsty - diff=grdfty-grdftx - if (diff.le.0.d0) goto 200 - rhog=dmin1(rhog,(rhs-f(i)-grdftx)/diff) - if(nobL.ne.nob) rhog=dmin1(rhog,-(rhs+f(i)+grdftx)/diff) - 200 continue - slope=rhog - 9000 return - end
deleted file mode 100644 --- a/libcruft/fsqp/small.f +++ /dev/null @@ -1,25 +0,0 @@ -c - double precision function small() -c implicit real*8(a-h,o-z) - double precision one, two, z -c - one=1.d0 - two=2.d0 - small=one -10 small=small/two - call fool(small,one,z) - if(z.gt.one) goto 10 - small=small*two*two -c -c The simpler sequence commented out below fails on some machines that use -c extra-length registers for internal computation. This was pointed out -c to us by Roque Donizete de Oliveira (Michigan) who suggested to sequence -c used now. -c -c small=1.d0 -c100 if ((small+1.d0).eq.1.d0) goto 110 -c small=small/2.d0 -c goto 100 -c110 small=small*4.d0 - return - end
deleted file mode 100644 --- a/libcruft/fsqp/step.f +++ /dev/null @@ -1,217 +0,0 @@ - subroutine step(nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg, - * ncf,indxob,indxcn,iact,iskp,iskip,istore,feasb, - * grdftd,f,fM,fMp,psf,penp,steps,scvneq,xnew, - * x,di,d,g,w,backup,signeq,obj,constr) -c -c FSQP Version 3.3 : Armijo or nonmonotone line search, with -c some ad hoc strategies to decrease the number -c of function evaluation as much as possible -c -c implicit real*8(a-h,o-z) - integer nparam,nob,nobL,nineqn,neq,neqn,nn,ncnstr,ncg,ncf,iskp - integer indxob(1),indxcn(1),iact(1),iskip(1), - * istore(1) -c integer indxob(nob),indxcn(ncnstr),iact(nn+nob),iskip(4), -c * istore(nineqn+nob) - double precision grdftd,fM,fMp,steps,scvneq,psf - double precision xnew(nparam),x(nparam),di(nparam),d(nparam), - * f(1),penp(1),g(1),w(1),backup(1), - * signeq(1) -c double precision xnew(nparam),x(nparam),di(nparam),d(nparam), -c * f(nob),penp(neqn),g(ncnstr),w(1),backup(nob+ncnstr), -c * signeq(neqn) - external obj,constr - logical feasb -c - integer nnineq,M,ncallg,ncallf,mode,io,iprint,ipspan,ipyes,info, - * idum1,idum2,idum3,nstop,lstype - double precision epsmac,bigbnd,tolfea,dum1,dum2,dum3 - logical lqpsl,ldummy,dlfeas,local,update,ldumm2 - common /fsqpp1/nnineq,M,ncallg,ncallf,mode,lstype,nstop, - * /fsqpp2/io,iprint,ipspan,ipyes,info,idum1,idum2,idum3, - * /fsqpp3/epsmac,dum1,dum2,dum3, - * /fsqpq1/bigbnd,tolfea, - * /fsqplo/dlfeas,local,update,ldumm2, - * /fsqpqp/lqpsl,ldummy -c - integer i,ii,ij,itry,ikeep,j,job,nlin,mnm - double precision prod1,prod,dummy,fmaxl,tolfe,dmax1,ostep, - * adummy(1),temp - logical ltem1,ltem2,reform,fbind,cdone,fdone,eqdone -c - nlin=nnineq-nineqn - ii=1 - itry=1 - steps=1.d0 - ostep=steps - fbind=.false. - cdone=.false. - fdone=.false. - reform=.true. - eqdone=.false. - if(local) dlfeas=.false. - ikeep=nlin-iskp - prod1=0.1d0*grdftd - tolfe=0.d0 - if(lqpsl) tolfe=tolfea - if(iprint.ge.3.and.ipyes.eq.0) - * call sbout1(io,0,'directional deriv ',grdftd,adummy,1,2) -c - w(1)=fM - 100 continue - if(iprint.ge.3.and.ipyes.eq.0) - * write(io,9901) itry - prod=prod1*steps - if(.not.feasb.or.nobL.gt.1) prod=prod+tolfe - do 200 i=1,nparam - if(local) xnew(i)=x(i)+steps*di(i) - if(.not.local) xnew(i)=x(i)+steps*di(i)+d(i)*steps**2 - 200 continue - if(iprint.lt.3.or.ipyes.gt.0) goto 205 - call sbout1(io,0,'trial step ',steps,adummy,1,2) - call sbout1(io,nparam,'trial point ', - * dummy,xnew,2,2) - 205 if(iskp.eq.0) goto 209 - ostep=steps - do 207 i=ii,iskp - ij=iskip(i) - call constr(nparam,ij,xnew,g(ij)) - if(iprint.lt.3.or.ipyes.gt.0) goto 206 - if(i.eq.1) write(io,9900) ij,g(ij) - if(i.ne.1) write(io,9902) ij,g(ij) - 206 if(g(ij).le.tolfe) goto 207 - ii=i - goto 1120 - 207 continue - iskp=0 - 209 if(nn.eq.0) goto 310 - if(.not.local.and.fbind) goto 315 - 210 continue - do 300 i=1,nn - ncg=i - ii=iact(i) - ij=nnineq+neqn - if(ii.le.nnineq.and.istore(ii).eq.1) goto 215 - if(ii.gt.nnineq.and.ii.le.ij.and.eqdone) goto 215 - temp=1.d0 - if(ii.gt.nnineq.and.ii.le.ij) temp=signeq(ii-nnineq) - call constr(nparam,ii,xnew,g(ii)) - g(ii)=g(ii)*temp - ncallg=ncallg+1 - 215 if(iprint.lt.3.or.ipyes.gt.0) goto 220 - if(i.eq.1.and.ikeep.eq.nlin) - * write(io,9900) ii,g(ii) - if(i.ne.1.or.ikeep.ne.nlin) write(io,9902) ii,g(ii) - 220 if(local.or.g(ii).le.tolfe) goto 230 - call shift(nn,ii,iact) - goto 1110 - 230 if(local.and.g(ii).gt.tolfe) goto 1500 - 300 continue - 310 cdone=.true. - eqdone=.true. - if(local) dlfeas=.true. - 315 if(fdone) goto 410 - fmaxl=-bigbnd - do 400 i=1,nob - ncf=i - ii=iact(nn+i) - if(feasb) then - if(eqdone.or.neqn.eq.0) goto 317 - do 316 j=1,neqn - 316 call constr(nparam,nnineq+j,xnew,g(nnineq+j)) - ncallg=ncallg+neqn - 317 if(neqn.eq.0) goto 318 - if(eqdone) job=20 - if(.not.eqdone) job=10 - call resign(nparam,neqn,psf,w(2),penp, - * g(nnineq+1),w(2),signeq,job,10) - 318 if(istore(nineqn+ii).eq.1) goto 320 - call obj(nparam,ii,xnew,f(ii)) - ncallf=ncallf+1 - 320 if(i.eq.1.and.iprint.ge.3.and.ipyes.eq.0) - * write(io,9903) ii,f(ii)-psf - if(i.ne.1.and.iprint.ge.3.and.ipyes.eq.0) - * write(io,9902) ii,f(ii)-psf - else - if(istore(ii).eq.1) goto 325 - call constr(nparam,indxob(ii),xnew,f(ii)) - ncallg=ncallg+1 - 325 if(f(ii).gt.tolfe) reform=.false. - if(i.eq.1.and.iprint.ge.3.and.ipyes.eq.0) - * write(io,9903) indxob(ii),f(ii) - if(i.ne.1.and.iprint.ge.3.and.ipyes.eq.0) - * write(io,9902) indxob(ii),f(ii) - endif - fmaxl=dmax1(fmaxl,f(ii)) - if(nobL.ne.nob) fmaxl=dmax1(fmaxl,-f(ii)) - if(.not.feasb.and.reform) goto 400 - if(local) goto 340 - if((f(ii)-psf).le.(fMp+prod)) goto 330 - fbind=.true. - call shift(nob,ii,iact(nn+1)) - goto 1110 - 330 if(nobL.eq.nob.or.(-f(ii)-psf).le.(fMp+prod)) goto 400 - fbind=.true. - call shift(nob,ii,iact(nn+1)) - goto 1110 - 340 ltem1=(f(ii)-psf).gt.(fMp+prod) - ltem2=nobL.ne.nob.and.(-f(ii)-psf).gt.(fMp+prod) - if(ltem1.or.ltem2) goto 1500 - 400 continue - fbind=.false. - fdone=.true. - eqdone=.true. - if(.not.cdone) goto 210 - 410 if(ostep.eq.steps) mnm=ikeep+neq-neqn - if(ostep.ne.steps) mnm=ncnstr-nn - do 500 i=1,mnm - ii=indxcn(i+nn) - if(ikeep.ne.nlin.and.ostep.eq.steps.and.i.le.nlin) - * ii=iskip(nlin+2-i) - call constr(nparam,ii,xnew,g(ii)) - 500 continue - scvneq=0.d0 - do 600 i=1,ncnstr - if(i.gt.nnineq.and.i.le.(nnineq+neqn)) scvneq=scvneq-g(i) - 600 backup(i)=g(i) - do 700 i=1,nob - 700 backup(i+ncnstr)=f(i) - if(feasb.or..not.reform) goto 810 - do 800 i=1,nparam - 800 x(i)=xnew(i) - nstop=0 - goto 1500 - 810 if(local) ncg=ncnstr - if(local) update=.true. - fM=fmaxl - fMp=fmaxl-psf - do 1000 i=1,nn - 1000 iact(i)=indxcn(i) - do 1100 i=1,nob - 1100 iact(nn+i)=i - goto 1500 -c - 1110 cdone=.false. - fdone=.false. - eqdone=.false. - reform=.false. - if(lstype.eq.2) fbind=.false. - 1120 itry=itry+1 - if(steps.lt.1.d0) goto 1140 - do 1130 i=1,nob+nineqn - 1130 istore(i)=0 - 1140 steps=steps*.5d0 - if(steps.lt.epsmac) goto 1150 - goto 100 -c - 1150 info=4 - nstop=0 - 1500 if(steps.lt.1.d0) goto 9000 - do 1600 i=1,nob+nineqn - 1600 istore(i)=0 - 9000 return - 9900 format(1x,t17,17htrial constraints,t37,i7,t45,e22.14) - 9901 format(1x,t17,12htrial number,t45,i22) - 9902 format(1x,t37,i7,t45,e22.14) - 9903 format(1x,t17,16htrial objectives,t37,i7,t45,e22.14) - end
deleted file mode 100644 --- a/libcruft/npsol/Makefile.in +++ /dev/null @@ -1,19 +0,0 @@ -# -# Makefile for octave's libcruft/npsol directory -# -# John W. Eaton -# jwe@bevo.che.wisc.edu -# University of Wisconsin-Madison -# Department of Chemical Engineering - -TOPDIR = ../.. - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ - -EXTERNAL_DISTFILES = Makefile.in README.MISSING - -include $(TOPDIR)/Makeconf - -include ../Makerules
deleted file mode 100644 --- a/libcruft/npsol/README.MISSING +++ /dev/null @@ -1,18 +0,0 @@ -If it were freely redistributable, the source for Gill and Murray's -nonlinear programming solver NPSOL would be in this directory. - -Unfortunately, if you want octave to use NPSOL to solve constrained -nonlinear optimization problems, you must get the source from the -Stanford Office of Technology Licensing: - - Stanford University - Office of Technology Licensing - 857 Serra Street - Stanford CA 94305-7295 - USA - - Tel: (415) 723-0651 - Fax: (415) 725-7295 - -As of April, 1992, the license fee for NPSOL was $3600 for commercial -sites and $400 for academic and US Government sites.
deleted file mode 100644 --- a/libcruft/npsol/chcore.f +++ /dev/null @@ -1,294 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File CHSUBS FORTRAN -* -* CHCORE CHFD CHKGRD CHKJAC -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CHCORE( DEBUG, DONE, FIRST, EPSA, EPSR, FX, X, - $ INFORM, ITER, ITMAX, - $ CDEST, FDEST, SDEST, ERRBND, F1, - $ F2, H, HOPT, HPHI ) - - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - LOGICAL DEBUG, DONE, FIRST - -************************************************************************ -* CHCORE implements algorithm FD, the method described in -* Gill, P.E., Murray, W., Saunders, M.A., and Wright, M. H., -* Computing Forward-Difference Intervals for Numerical Optimization, -* Siam Journal on Scientific and Statistical Computing, vol. 4, -* pp. 310-321, June 1983. -* -* The procedure is based on finding an interval (HPHI) that -* produces an acceptable estimate of the second derivative, and -* then using that estimate to compute an interval that should -* produce a reasonable forward-difference approximation. -* -* One-sided difference estimates are used to ensure feasibility with -* respect to an upper or lower bound on X. If X is close to an upper -* bound, the trial intervals will be negative. The final interval is -* always positive. -* -* CHCORE has been designed to use a reverse communication -* control structure, i.e., all evaluations of the function occur -* outside this routine. The calling routine repeatedly calls CHCORE -* after computing the indicated function values. -* -* CHCORE is similar to subroutine FDCORE described in Report -* SOL 83-6, Documentation of FDCORE and FDCALC, by P.E. Gill, -* W. Murray, M.A. Saunders, and M.H. Wright, Department of -* Operations Research, Stanford University, Stanford, California -* 94305, June 1983. -* -* Systems Optimization Laboratory, Stanford University. -* Based on Fortran 66 Version 2.1 of FDCORE written June 1983. -* Fortran 77 Version written 25-May-1985. -* This version of CHCORE dated 11-February-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL CE1BIG, CE2BIG, TE2BIG, OVERFL - SAVE CDSAVE, FDSAVE, HSAVE, OLDH, RHO, SDSAVE - SAVE CE1BIG, CE2BIG, TE2BIG - EXTERNAL DDIV - INTRINSIC ABS , MAX , MIN , SQRT - - PARAMETER (BNDLO =1.0D-3, BNDUP =1.0D-1 ) - - PARAMETER (ZERO =0.0D+0, SIXTH =1.6D-1, FOURTH =2.5D-1) - PARAMETER (HALF =5.0D-1, ONE =1.0D+0, TWO =2.0D+0) - PARAMETER (THREE =3.0D+0, FOUR =4.0D+0, TEN =1.0D+1) - -* ------------------------------------------------------------------ -* Explanation of local variables... -* -* BNDLO, BNDUP, and RHO control the logic of the routine. -* BNDLO and BNDUP are the lower and upper bounds that define an -* acceptable value of the bound on the relative condition error in -* the second derivative estimate. -* -* The scalar RHO is the factor by which the interval is multiplied -* or divided, and also the multiple of the well-scaled interval -* that is used as the initial trial interval. -* -* All these values are discussed in the documentation. -* ------------------------------------------------------------------ - - ITER = ITER + 1 - -* Compute the forward-, backward-, central- and second-order -* difference estimates. - - FDEST = DDIV ( F1 - FX, H, OVERFL ) - FDEST2 = DDIV ( F2 - FX, TWO*H, OVERFL ) - - OLDCD = CDEST - CDEST = DDIV ( FOUR*F1 - THREE*FX - F2, TWO*H, OVERFL ) - - OLDSD = SDEST - SDEST = DDIV ( FX - TWO*F1 + F2, H*H , OVERFL ) - -* Compute FDCERR and SDCERR, bounds on the relative condition -* errors in the first and second derivative estimates. - - AFDMIN = MIN( ABS( FDEST ), ABS( FDEST2 ) ) - FDCERR = DDIV ( EPSA, HALF*ABS( H )*AFDMIN, OVERFL ) - SDCERR = DDIV ( EPSA, FOURTH*ABS( SDEST )*H*H, OVERFL ) - - IF (DEBUG) - $ WRITE (NOUT, 9000) ITER , FX , H, - $ F1 , FDEST, - $ F2 , FDEST2, - $ CDEST , SDEST, - $ FDCERR, SDCERR - -* ================================================================== -* Select the correct case. -* ================================================================== - IF (FIRST) THEN -* --------------------------------------------------------------- -* First time through. -* Check whether SDCERR lies in the acceptable range. -* ------------------------------------------------------------ - FIRST = .FALSE. - DONE = SDCERR .GE. BNDLO .AND. SDCERR .LE. BNDUP - TE2BIG = SDCERR .LT. BNDLO - CE2BIG = SDCERR .GT. BNDUP - CE1BIG = FDCERR .GT. BNDUP - - IF (.NOT. CE1BIG) THEN - HSAVE = H - FDSAVE = FDEST - CDSAVE = CDEST - SDSAVE = SDEST - END IF - - RHO = EPSR**(-SIXTH)/FOUR - IF (TE2BIG) THEN - -* The truncation error may be too big (same as saying -* SDCERR is too small). Decrease the trial interval. - - RHO = TEN*RHO - OLDH = H - H = H / RHO - ELSE IF (CE2BIG) THEN - -* SDCERR is too large. Increase the trial interval. - - OLDH = H - H = H*RHO - END IF - ELSE IF (CE2BIG) THEN -* --------------------------------------------------------------- -* During the last iteration, the trial interval was -* increased in order to decrease SDCERR. -* --------------------------------------------------------------- - IF (CE1BIG .AND. FDCERR .LE. BNDUP) THEN - CE1BIG = .FALSE. - HSAVE = H - FDSAVE = FDEST - CDSAVE = CDEST - SDSAVE = SDEST - END IF - -* If SDCERR is small enough, accept H. Otherwise, -* increase H again. - - DONE = SDCERR .LE. BNDUP - IF (.NOT. DONE) THEN - OLDH = H - H = H*RHO - END IF - ELSE IF (TE2BIG) THEN -* --------------------------------------------------------------- -* During the last iteration, the interval was decreased in order -* to reduce the truncation error. -* --------------------------------------------------------------- - DONE = SDCERR .GT. BNDUP - IF (DONE) THEN - -* SDCERR has jumped from being too small to being too -* large. Accept the previous value of H. - - H = OLDH - SDEST = OLDSD - CDEST = OLDCD - ELSE - -* Test whether FDCERR is sufficiently small. - - IF (FDCERR .LE. BNDUP) THEN - CE1BIG = .FALSE. - HSAVE = H - FDSAVE = FDEST - CDSAVE = CDEST - SDSAVE = SDEST - END IF - -* Check whether SDCERR is in range. - - DONE = SDCERR .GE. BNDLO - - IF (.NOT. DONE) THEN - -* SDCERR is still too small, decrease H again. - - OLDH = H - H = H / RHO - END IF - END IF - - END IF - -* ================================================================== -* We have either finished or have a new estimate of H. -* ================================================================== - IF (DONE) THEN - -* Sufficiently good second-derivative estimate found. -* Compute the optimal interval. - - HPHI = ABS( H ) - HOPT = TWO * SQRT( EPSA ) / SQRT( ABS( SDEST ) ) - -* ERR1 is the error bound on the forward-difference estimate -* with the final value of H. ERR2 is the difference of FDEST -* and the central-difference estimate with HPHI. - - ERR1 = HOPT*ABS( SDEST ) - ERR2 = ABS( FDEST - CDEST ) - ERRBND = MAX( ERR1, ERR2 ) - -* Set INFORM = 4 if the forward- and central-difference -* estimates are not close. - - INFORM = 0 - IF (ERRBND .GT. HALF*ABS( FDEST )) INFORM = 4 - ELSE -* --------------------------------------------------------------- -* Check whether the maximum number of iterations has been -* exceeded. If not, exit. -* --------------------------------------------------------------- - DONE = ITER .GE. ITMAX - IF (DONE) THEN - IF (CE1BIG) THEN - -* FDCERR was never small. Probably a constant function. - - INFORM = 1 - HPHI = HOPT - FDEST = ZERO - CDEST = ZERO - SDEST = ZERO - ERRBND = ZERO - ELSE IF (CE2BIG) THEN - -* FDCERR was small, but SDCERR was never small. -* Probably a linear or odd function. - - INFORM = 2 - HPHI = ABS( HSAVE ) - HOPT = HPHI - FDEST = FDSAVE - CDEST = CDSAVE - SDEST = ZERO - ERRBND = TWO*EPSA / HOPT - ELSE - -* The only remaining case occurs when the second -* derivative is changing too rapidly for an adequate -* interval to be found (SDCERR remained small even -* though H was decreased ITMAX times). - - INFORM = 3 - HPHI = ABS( HSAVE ) - HOPT = HPHI - FDEST = FDSAVE - CDEST = CDSAVE - SDEST = SDSAVE - ERRBND = HOPT*ABS( SDEST )/TWO + TWO*EPSA/HOPT - END IF - END IF - END IF - - IF (DEBUG) THEN - WRITE (NOUT, 9001) CE1BIG, CE2BIG, TE2BIG - IF (DONE) - $ WRITE (NOUT, 9002) INFORM, HOPT, ERRBND - END IF - - RETURN - - 9000 FORMAT(/ ' //CHCORE// ITN ', I3, - $ ' FX H ', 5X, 1P2D16.6 - $ / ' //CHCORE// F1 FDEST ', 5X, 1P2D16.6 - $ / ' //CHCORE// F2 FDEST2 ', 5X, 1P2D16.6 - $ / ' //CHCORE// CDEST SDEST ', 5X, 1P2D16.6 - $ / ' //CHCORE// FDCERR SDCERR ', 5X, 1P2D16.6) - 9001 FORMAT( ' //CHCORE// CE1BIG CE2BIG TE2BIG', 5X, 3L2 ) - 9002 FORMAT( ' //CHCORE// INFORM HOPT ERRBND', I5, 1P2D16.6) - -* End of CHCORE. - - END
deleted file mode 100644 --- a/libcruft/npsol/chfd.f +++ /dev/null @@ -1,399 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CHFD ( INFORM, MSGLVL, LVLDER, - $ N, NCNLN, NROWJ, NROWUJ, - $ BIGBND, EPSRF, FDNORM, OBJF, - $ OBJFUN, CONFUN, NEEDC, - $ BL, BU, C, C1, C2, CJAC, UJAC, - $ GRAD, UGRAD, HFORWD, HCNTRL, - $ X, Y, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER NEEDC(*) - DOUBLE PRECISION BL(N), BU(N) - DOUBLE PRECISION C(*), C1(*), C2(*), - $ CJAC(NROWJ,*), UJAC(NROWUJ,*) - DOUBLE PRECISION GRAD(N), UGRAD(N) - DOUBLE PRECISION HFORWD(*), HCNTRL(*) - DOUBLE PRECISION X(N), Y(N), W(LENW) - EXTERNAL OBJFUN, CONFUN - -************************************************************************ -* CHFD computes difference intervals for the missing gradients of -* F(x) and c(x). Intervals are computed using a procedure that usually -* requires about two function evaluations if the function is well -* scaled. Central-difference gradients are obtained as a by-product -* of the algorithm. -* -* On entry... -* OBJF and C contain the problem functions at the point X. -* An element of CJAC or GRAD not equal to RDUMMY signifies a known -* gradient value. Such values are not estimated by differencing. -* UJAC and UGRAD have dummy elements in the same positions as -* CJAC and UGRAD. -* -* On exit... -* CJAC and GRAD contain central-difference derivative estimates. -* Elements of UJAC and UGRAD are unaltered except for those -* corresponding to constant derivatives, which are given the same -* values as CJAC or GRAD. -* -* Systems Optimization Laboratory, Department of Operations Research, -* Stanford University, Stanford, California 94305 -* Original version written 28-July-1985. -* This version of CHFD dated 14-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL DEBUG , DONE , FIRST , HEADNG, NEEDED - INTRINSIC ABS , MAX , MIN , SQRT - EXTERNAL DNRM2 - PARAMETER (RDUMMY =-11111.0 ) - PARAMETER (FACTOR =0.97D+0 ) - PARAMETER (ZERO =0.0D+0, HALF =0.5D+0, ONE =1.0D+0) - PARAMETER (TWO =2.0D+0, FOUR =4.0D+0, TEN =1.0D+1) - - INFORM = 0 - NEEDED = LVLDER .EQ. 0 .OR. LVLDER .EQ. 2 - $ .OR. LVLDER .EQ. 1 .AND. NCNLN .GT. 0 - IF (.NOT. NEEDED) RETURN - - DEBUG = NPDBG .AND. INPDBG(5) .GT. 0 - IF (LFDSET .EQ. 0) THEN - IF (MSGLVL .GT. 0) WRITE (NOUT, 1000) - - NSTATE = 0 - ITMAX = 3 - MODE = 0 - - NCCNST = 0 - NFCNST = 0 - HEADNG = .TRUE. - - FDNORM = ZERO - -* =============================================================== -* For each column of the Jacobian augmented by the transpose of -* the objective gradient, rows IROW1 thru IROW2 are searched for -* missing elements. -* =============================================================== - IROW1 = 1 - IROW2 = NCNLN + 1 - IF (LVLDER .EQ. 1) IROW2 = NCNLN - IF (LVLDER .EQ. 2) IROW1 = NCNLN + 1 - - BIGLOW = - BIGBND - BIGUPP = BIGBND - - IF (NCNLN .GT. 0) - $ CALL ILOAD ( NCNLN, (0), NEEDC, 1 ) - - DO 600 J = 1, N - XJ = X(J) - NFOUND = 0 - SUMSD = ZERO - SUMEPS = ZERO - HFD = ZERO - HCD = ZERO - HMAX = ZERO - HMIN = ONE / EPSPT3 - ERRMAX = ZERO - ERRMIN = ZERO - - STEPBL = BIGLOW - STEPBU = BIGUPP - IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ - IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ - - SIGNH = ONE - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) SIGNH = - ONE - - DO 500 I = IROW1, IROW2 - - IF (I .LE. NCNLN) THEN - TEST = UJAC(I,J) - ELSE - TEST = UGRAD(J) - END IF - - IF (TEST .EQ. RDUMMY) THEN -* ====================================================== -* Get the difference interval for this component. -* ====================================================== - NFOUND = NFOUND + 1 - - IF (I .LE. NCNLN) THEN - NEEDC(I) = 1 - FX = C(I) - EPSA = EPSRF*(ONE + ABS( C(I) )) - ELSE - FX = OBJF - EPSA = EPSRF*(ONE + ABS( FX )) - END IF - -* ------------------------------------------------------ -* Find a finite-difference interval by iteration. -* ------------------------------------------------------ - ITER = 0 - HOPT = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF ) - H = SIGNH*TEN*HOPT - CDEST = ZERO - SDEST = ZERO - FIRST = .TRUE. - -*+ REPEAT - 400 X(J) = XJ + H - IF (I .LE. NCNLN) THEN - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - F1 = C1(I) - ELSE - CALL OBJFUN( MODE, N, X, F1, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - END IF - - X(J) = XJ + H + H - IF (I .LE. NCNLN) THEN - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - F2 = C1(I) - ELSE - CALL OBJFUN( MODE, N, X, F2, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - END IF - - CALL CHCORE( DEBUG, DONE, FIRST, EPSA, EPSRF,FX,XJ, - $ INFO, ITER, ITMAX, - $ CDEST, FDEST, SDEST, ERRBND, F1, - $ F2, H, HOPT, HPHI ) - -*+ UNTIL DONE - IF (.NOT. DONE) GO TO 400 - - IF (I .LE. NCNLN) THEN - CJAC(I,J) = CDEST - IF (INFO .EQ. 1 .OR. INFO .EQ. 2) THEN - NCCNST = NCCNST + 1 - NCDIFF = NCDIFF - 1 - UJAC(I,J) = - RDUMMY - END IF - ELSE - GRAD(J) = CDEST - IF (INFO .EQ. 1 .OR. INFO .EQ. 2) THEN - NFCNST = NFCNST + 1 - NFDIFF = NFDIFF - 1 - UGRAD(J) = - RDUMMY - END IF - END IF - - SUMSD = SUMSD + ABS( SDEST ) - SUMEPS = SUMEPS + EPSA - IF (HOPT .GT. HMAX) THEN - HMAX = HOPT - ERRMAX = ERRBND - END IF - IF (HOPT .LT. HMIN) THEN - HMIN = HOPT - ERRMIN = ERRBND - END IF - - IF (INFO .EQ. 0) HCD = MAX ( HCD, HPHI ) - END IF - 500 CONTINUE - - IF (NFOUND .GT. 0) THEN - IF (HMIN .GT. HMAX) THEN - HMIN = HMAX - ERRMIN = ERRMAX - END IF - - IF (FOUR*SUMEPS .LT. HMIN*HMIN*SUMSD) THEN - HFD = HMIN - ERRMAX = ERRMIN - ELSE IF (FOUR*SUMEPS .GT. HMAX*HMAX*SUMSD) THEN - HFD = HMAX - ELSE - HFD = TWO*SQRT( SUMEPS / SUMSD ) - ERRMAX = TWO*SQRT( SUMEPS * SUMSD ) - END IF - - IF (HCD .EQ. ZERO) HCD = TEN*HFD - - IF (MSGLVL .GT. 0) THEN - IF (HEADNG) WRITE (NOUT, 1100) - WRITE (NOUT, 1200) J, XJ, HFD, HCD, ERRMAX - HEADNG = .FALSE. - END IF - END IF - - FDNORM = MAX (FDNORM, HFD) - HFORWD(J) = HFD / (ONE + ABS(XJ)) - HCNTRL(J) = HCD / (ONE + ABS(XJ)) - X(J) = XJ - 600 CONTINUE - - IF (NCCNST + NFCNST .GT. 0) THEN - -* Check that the constants have been set properly by -* evaluating the gradients at a strange (but feasible) point. - - D = ONE / N - - DO 710 J = 1, N - XJ = X(J) - STEPBL = - ONE - STEPBU = ONE - IF (BL(J) .GT. BIGLOW) - $ STEPBL = MAX( STEPBL, BL(J) - XJ ) - IF (BU(J) .LT. BIGUPP .AND. BU(J) .GT. BL(J)) - $ STEPBU = MIN( STEPBU, BU(J) - XJ ) - - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN - Y(J) = XJ + D*STEPBL - ELSE - Y(J) = XJ + D*STEPBU - END IF - - D = FACTOR*D - 710 CONTINUE - - IF (NCNLN .GT. 0) THEN - CALL ILOAD ( NCNLN, (1), NEEDC, 1 ) - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, Y, C2, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - END IF - - CALL OBJFUN( MODE, N, Y, OBJF2, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - -* ------------------------------------------------------------ -* Loop over each of the components of x. -* ------------------------------------------------------------ - DO 800 J = 1, N - YJ = Y(J) - DX = HALF*(X(J) - YJ) - Y(J) = YJ + DX - - IF (NCNLN .GT. 0) THEN - NFOUND = 0 - DO 720 I = 1, NCNLN - IF (UJAC(I,J) .EQ. - RDUMMY) THEN - NEEDC(I) = 1 - NFOUND = NFOUND + 1 - ELSE - NEEDC(I) = 0 - END IF - 720 CONTINUE - - IF (NFOUND .GT. 0) THEN - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, Y, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - - DO 730 I = 1, NCNLN - IF (NEEDC(I) .EQ. 1) THEN - CJDIFF = ( C1(I) - C2(I) ) / DX - IF (CJDIFF .EQ. CJAC(I,J)) THEN - UJAC(I,J) = CJDIFF - ELSE - UJAC(I,J) = RDUMMY - NCCNST = NCCNST - 1 - NCDIFF = NCDIFF + 1 - END IF - END IF - 730 CONTINUE - END IF - END IF - -* Now check the objective gradient component. - - IF (UGRAD(J) .EQ. - RDUMMY) THEN - - CALL OBJFUN( MODE, N, Y, F1, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 9999 - - GDIFF = (F1 - OBJF2)/DX - IF (GDIFF .EQ. GRAD(J)) THEN - UGRAD(J) = GDIFF - ELSE - UGRAD(J) = RDUMMY - NFDIFF = NFDIFF + 1 - NFCNST = NFCNST - 1 - END IF - END IF - - Y(J) = YJ - 800 CONTINUE - - IF (MSGLVL .GT. 0) THEN - IF (LVLDER .LT. 2 .AND. NCCNST .GT. 0) - $ WRITE (NOUT, 1300) NCCNST - IF (LVLDER .NE. 1 .AND. NFCNST .GT. 0) - $ WRITE (NOUT, 1400) NFCNST - END IF - - IF (NCDIFF .EQ. 0 .AND. LVLDER .LT. 2) THEN - IF (LVLDER .EQ. 0) LVLDER = 2 - IF (LVLDER .EQ. 1) LVLDER = 3 - IF (MSGLVL .GT. 0) WRITE (NOUT, 1500) LVLDER - END IF - - IF (NFDIFF .EQ. 0 .AND. LVLDER .NE. 1) THEN - IF (LVLDER .EQ. 0) LVLDER = 1 - IF (LVLDER .EQ. 2) LVLDER = 3 - IF (MSGLVL .GT. 0) WRITE (NOUT, 1600) LVLDER - END IF - END IF - ELSE IF (LFDSET .EQ. 2) THEN - -* The user has supplied HFORWD and HCNTRL. -* Check for wild values. - - DO 900 J = 1, N - IF (HFORWD(J) .LE. ZERO) THEN - WRITE (NOUT, 2000) J, HFORWD(J), EPSPT5 - HFORWD(J) = EPSPT5 - END IF - 900 CONTINUE - DO 910 J = 1, N - IF (HCNTRL(J) .LE. ZERO) THEN - WRITE (NOUT, 2100) J, HCNTRL(J), EPSPT3 - HCNTRL(J) = EPSPT3 - END IF - 910 CONTINUE - END IF - - RETURN - - 9999 INFORM = MODE - RETURN - - 1000 FORMAT(//' Computation of the finite-difference intervals' - $ / ' ----------------------------------------------' ) - 1100 FORMAT(//' J X(J) Forward DX(J) Central DX(J) ', - $ ' Error est.' /) - 1200 FORMAT( I5, 1PE10.2, 1PE16.6, 1P2E16.6 ) - 1300 FORMAT(/ I5, ' constant constraint gradient elements assigned.') - 1400 FORMAT(/ I5, ' constant objective gradient elements assigned.') - 1500 FORMAT(//' All missing Jacobian elements are constants. ', - $ ' Derivative level increased to ', I4 ) - 1600 FORMAT(//' All missing objective gradients are constants. ', - $ ' Derivative level increased to ', I4 ) - 2000 FORMAT(' XXX ', I4,'-th difference interval ', 1PE10.2, - $ ' replaced by ', 1PE10.2 ) - 2100 FORMAT(' XXX ', I4,'-th central-difference interval ', 1PE10.2, - $ ' replaced by ', 1PE10.2 ) - -* End of CHFD . - - END
deleted file mode 100644 --- a/libcruft/npsol/chkgrd.f +++ /dev/null @@ -1,293 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CHKGRD( INFORM, MSGLVL, N, - $ BIGBND, EPSRF, OKTOL, FDCHK, OBJF, XNORM, - $ OBJFUN, - $ BL, BU, GRAD, UGRAD, DX, X, Y, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - - DOUBLE PRECISION BL(N), BU(N), GRAD(N), UGRAD(N), DX(N) - DOUBLE PRECISION X(N), Y(N), W(LENW) - EXTERNAL OBJFUN - -************************************************************************ -* CHKGRD checks if the gradients of the objective function have -* been coded correctly. -* -* On input, the value of the objective function at the point X is -* stored in OBJF. The corresponding gradient is stored in UGRAD. -* If any gradient component has not been specified, it will have a -* dummy value. Missing values are not checked. -* -* A cheap test is first undertaken by calculating the directional -* derivative using two different methods. If this proves satisfactory -* and no further information is desired, CHKGRD is terminated. -* Otherwise, the routine CHCORE is called to give optimal step-sizes -* and a forward-difference approximation to each component -* of the gradient for which a test is deemed necessary, -* either by the program or the user. -* -* Other inputs: -* -* X The n-dimensional point at which the -* gradient is to be verified. -* EPSRF The positive bound on the relative error -* associated with computing the function at -* the point x. -* OKTOL The desired relative accuracy which the -* components of the gradient should satisfy. -* -* LVRFYC has the following meaning... -* -* -1 do not perform any check. -* 0 do the cheap test only. -* 1 or 3 do both cheap and full test. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 19-May-1985. -* This version of CHKGRD dated 12-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL CONST , DEBUG , DONE , FIRST , HEADNG - LOGICAL NEEDED, OK - CHARACTER*4 KEY , LBAD , LGOOD - CHARACTER*18 RESULT(0:4) - INTRINSIC ABS , MAX , MIN , SQRT - EXTERNAL DDOT - PARAMETER (RDUMMY =-11111.0 ) - PARAMETER (ZERO =0.0D+0, HALF = 0.5D+0, POINT9 =0.9D+0) - PARAMETER (ONE =1.0D+0, TWO = 2.0D+0, TEN =1.0D+1) - PARAMETER (LBAD ='BAD?', LGOOD = ' OK') - DATA RESULT - $ / ' ', 'Constant? ', - $ 'Linear or odd? ', 'Too nonlinear?', - $ 'Small derivative?' / - - INFORM = 0 - NEEDED = LVRFYC .EQ. 0 .OR. LVRFYC .EQ. 1 .OR. LVRFYC .EQ. 3 - IF (.NOT. NEEDED) RETURN - - IF (MSGLVL .GT. 0) WRITE (NOUT, 1000) - DEBUG = NPDBG .AND. INPDBG(5) .GT. 0 - NSTATE = 0 - - BIGLOW = - BIGBND - BIGUPP = BIGBND - -* ================================================================== -* Perform the cheap test. -* ================================================================== - H = (ONE + XNORM)*FDCHK - - DXJ = ONE / N - DO 110 J = 1, N - DX(J) = DXJ - DXJ = - DXJ*POINT9 - 110 CONTINUE - -* ------------------------------------------------------------------ -* Do not perturb X(J) if the J-th element is missing. -* Compute the directional derivative. -* ------------------------------------------------------------------ - NCHECK = 0 - DO 120 J = 1, N - IF (GRAD(J) .EQ. RDUMMY) THEN - DX(J) = ZERO - ELSE - NCHECK = NCHECK + 1 - - XJ = X(J) - STEPBL = - ONE - STEPBU = ONE - IF (BL(J) .GT. BIGLOW) - $ STEPBL = MAX( STEPBL, BL(J) - XJ ) - IF (BU(J) .LT. BIGUPP .AND. BU(J) .GT. BL(J)) - $ STEPBU = MIN( STEPBU, BU(J) - XJ ) - - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN - DX(J) = DX(J)*STEPBL - ELSE - DX(J) = DX(J)*STEPBU - END IF - END IF - 120 CONTINUE - - IF (NCHECK .EQ. 0) THEN - WRITE (NOUT, 3500) - RETURN - END IF - GDX = DDOT ( N, UGRAD, 1, DX, 1 ) - -* ------------------------------------------------------------------ -* Make forward-difference approximation along p. -* ------------------------------------------------------------------ - CALL DCOPY ( N, X, 1, Y, 1 ) - CALL DAXPY ( N, H, DX, 1, Y, 1 ) - - MODE = 0 - CALL OBJFUN( MODE, N, Y, OBJF1, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - GDIFF = ( OBJF1 - OBJF) / H - ERROR = ABS( GDIFF - GDX ) / (ONE + ABS( GDX )) - - OK = ERROR .LE. OKTOL - IF (OK) THEN - IF (MSGLVL .GT. 0) WRITE (NOUT, 1100) - ELSE - WRITE (NOUT, 1200) - IF (ERROR .GE. ONE) INFORM = 1 - END IF - - IF (MSGLVL .GT. 0) WRITE (NOUT, 1300) GDX, GDIFF - -* ================================================================== -* Component-wise check. -* ================================================================== - IF (LVRFYC .EQ. 1 .OR. LVRFYC .EQ. 3) THEN - HEADNG = .TRUE. - ITMAX = 3 - NWRONG = 0 - NGOOD = 0 - JMAX = 0 - EMAX = ZERO - NCHECK = 0 - J1 = JVERFY(1) - J2 = JVERFY(2) - -* --------------------------------------------------------------- -* Loop over each of the components of x. -* --------------------------------------------------------------- - DO 500 J = J1, J2 - - IF (GRAD(J) .NE. RDUMMY) THEN -* --------------------------------------------------------- -* Check this gradient component. -* --------------------------------------------------------- - NCHECK = NCHECK + 1 - GJ = GRAD(J) - GSIZE = ONE + ABS( GJ ) - XJ = X(J) -* --------------------------------------------------------- -* Find a finite-difference interval by iteration. -* --------------------------------------------------------- - ITER = 0 - EPSA = EPSRF*(ONE + ABS( OBJF )) - CDEST = ZERO - SDEST = ZERO - FIRST = .TRUE. - - STEPBL = BIGLOW - STEPBU = BIGUPP - IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ - IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ - - HOPT = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF ) - H = TEN*HOPT - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) H = - H - -*+ REPEAT - 400 X(J) = XJ + H - CALL OBJFUN( MODE, N, X, F1, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - X(J) = XJ + H + H - CALL OBJFUN( MODE, N, X, F2, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - CALL CHCORE( DEBUG, DONE, FIRST, EPSA, EPSRF, OBJF,XJ, - $ INFO, ITER, ITMAX, - $ CDEST, FDEST, SDEST, ERRBND, F1, - $ F2, H, HOPT, HPHI ) - -*+ UNTIL DONE - IF (.NOT. DONE) GO TO 400 - -* --------------------------------------------------------- -* Exit for this variable. -* --------------------------------------------------------- - GDIFF = CDEST - X(J) = XJ - - ERROR = ABS( GDIFF - GJ ) / GSIZE - IF (ERROR .GE. EMAX) THEN - EMAX = ERROR - JMAX = J - END IF - - OK = ERROR .LE. OKTOL - IF (OK) THEN - KEY = LGOOD - NGOOD = NGOOD + 1 - ELSE - KEY = LBAD - NWRONG = NWRONG + 1 - END IF - -* Zero components are not printed. - - CONST = OK .AND. INFO .EQ. 1 .AND. ABS(GJ) .LT. EPSPT8 - IF (.NOT. CONST) THEN - IF (HEADNG) WRITE (NOUT, 3000) - IF (OK) THEN - WRITE (NOUT, 3100) J, XJ, HOPT, GJ, GDIFF, - $ KEY, ITER - ELSE - WRITE (NOUT, 3110) J, XJ, HOPT, GJ, GDIFF, - $ KEY, ITER, RESULT(INFO) - END IF - HEADNG = .FALSE. - END IF - END IF - 500 CONTINUE - -* =============================================================== -* Done. -* =============================================================== - IF (NWRONG .EQ. 0) THEN - WRITE (NOUT, 3200) NGOOD , NCHECK, J1 , J2 - ELSE - WRITE (NOUT, 3300) NWRONG, NCHECK, J1 , J2 - END IF - WRITE (NOUT, 3400) EMAX, JMAX - END IF - - CALL DCOPY ( N, GRAD, 1, UGRAD, 1 ) - - RETURN - - 999 INFORM = MODE - RETURN - - 1000 FORMAT(/// ' Verification of the objective gradients.' - $ / ' ----------------------------------------' ) - 1100 FORMAT(/ ' The objective gradients seem to be ok.') - 1200 FORMAT(/ ' XXX The objective gradients seem to be incorrect.') - 1300 FORMAT(/ ' Directional derivative of the objective', 1PE18.8/ - $ ' Difference approximation ', 1PE18.8 ) - 3000 FORMAT(// 4X, 'J', 4X, 'X(J)', 5X, 'DX(J)', 11X, - $ 'G(J)', 9X, ' Difference approxn Itns' /) - 3100 FORMAT( I5, 1P2E10.2, 1P2E18.8, 2X, A4, I6 ) - 3110 FORMAT( I5, 1P2E10.2, 1P2E18.8, 2X, A4, I6, 2X, A18 ) - 3200 FORMAT(/ I7, ' Objective gradients out of the', I6, - $ ' set in cols', I6, ' through', I6, - $ ' seem to be ok.') - 3300 FORMAT(/ ' XXX There seem to be', I6, - $ ' incorrect objective gradients out of the', I6, - $ ' set in cols', I6, ' through', I6 ) - 3400 FORMAT(/ ' The largest relative error was', 1PE12.2, - $ ' in element', I6 /) - 3500 FORMAT(/ ' No gradient elements assigned.' ) - -* End of CHKGRD. - - END
deleted file mode 100644 --- a/libcruft/npsol/chkjac.f +++ /dev/null @@ -1,367 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CHKJAC( INFORM, LVLDER, MSGLVL, - $ NCSET, N, NCNLN, NROWJ, NROWUJ, - $ BIGBND, EPSRF, OKTOL, FDCHK, XNORM, - $ CONFUN, NEEDC, - $ BL, BU, C, C1, CJAC, UJAC, CJDX, - $ DX, ERR, X, Y, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER NEEDC(*) - DOUBLE PRECISION BL(N), BU(N), C(*), C1(*), CJDX(*), - $ CJAC(NROWJ,*), UJAC(NROWUJ,*), ERR(*) - DOUBLE PRECISION DX(N), X(N), Y(N), W(LENW) - EXTERNAL CONFUN - -************************************************************************ -* CHKJAC checks if the gradients of the constraints have been coded -* correctly. -* -* On input, the values of the constraints at the point X are stored -* in C. Their corresponding gradients are stored in UJAC. If any -* Jacobian component has not been specified, it will have a dummy -* value. Missing values are not checked. -* -* A cheap test is first undertaken by calculating the directional -* derivative using two different methods. If this proves satisfactory -* and no further information is desired, CHKJAC is terminated. -* Otherwise, CHCORE is called to give optimal step-sizes and a central- -* difference approximation to each component of the Jacobian for which -* a test is deemed necessary, either by the program or the user. -* -* LVRFYC has the following meaning... -* -* -1 do not perform any check. -* 0 do the cheap test only. -* 2 or 3 do both cheap and full test. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 19-May-1985. -* This version of CHKJAC dated 12-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL CONST , DEBUG , DONE , FIRST , HEADNG - LOGICAL NEEDED, OK - CHARACTER*4 KEY , LBAD , LGOOD - CHARACTER*18 RESULT(0:4) - INTRINSIC ABS , MAX , MIN , SQRT - EXTERNAL DDOT , IDAMAX - PARAMETER (RDUMMY =-11111.0 ) - PARAMETER (ZERO =0.0D+0, HALF =0.5D+0, POINT9 =0.9D+0) - PARAMETER (ONE =1.0D+0, TWO =2.0D+0, TEN =1.0D+1) - PARAMETER (LBAD ='BAD?', LGOOD =' OK') - DATA RESULT - $ / ' ', 'Constant? ', - $ 'Linear or odd? ', 'Too nonlinear?', - $ 'Small derivative?' / - - INFORM = 0 - NEEDED = NCNLN .GT. 0 .AND. - $ LVRFYC .EQ. 0 .OR. LVRFYC .EQ. 2 .OR. LVRFYC .EQ. 3 - IF (.NOT. NEEDED) RETURN - - IF (MSGLVL .GT. 0) WRITE (NOUT, 1000) - DEBUG = NPDBG .AND. INPDBG(5) .GT. 0 - NSTATE = 0 - - BIGLOW = - BIGBND - BIGUPP = BIGBND - -* ================================================================== -* Perform the cheap test. -* ================================================================== - H = (ONE + XNORM)*FDCHK - - DXJ = ONE / N - DO 110 J = 1, N - DX(J) = DXJ - DXJ = - DXJ*POINT9 - 110 CONTINUE - -* ------------------------------------------------------------------ -* Do not perturb X(J) if the J-th column contains any -* unknown elements. Compute the directional derivative for each -* constraint gradient. -* ------------------------------------------------------------------ - NCHECK = 0 - DO 140 J = 1, N - DO 130 I = 1, NCNLN - IF (CJAC(I,J) .EQ. RDUMMY) THEN - DX(J) = ZERO - GO TO 140 - END IF - 130 CONTINUE - NCHECK = NCHECK + 1 - - XJ = X(J) - STEPBL = - ONE - STEPBU = ONE - IF (BL(J) .GT. BIGLOW) - $ STEPBL = MAX( STEPBL, BL(J) - XJ ) - IF (BU(J) .LT. BIGUPP .AND. BU(J) .GT. BL(J)) - $ STEPBU = MIN( STEPBU, BU(J) - XJ ) - - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) THEN - DX(J) = DX(J)*STEPBL - ELSE - DX(J) = DX(J)*STEPBU - END IF - 140 CONTINUE - - IF (NCHECK .EQ. 0) THEN - WRITE (NOUT, 2300) - ELSE - -* Compute (Jacobian)*DX. - - CALL DLOAD ( NCNLN, ZERO, CJDX, 1 ) - DO 150 J = 1, N - IF (DX(J) .NE. ZERO) - $ CALL DAXPY ( NCNLN, DX(J), UJAC(1,J), 1, CJDX, 1 ) - 150 CONTINUE - -* --------------------------------------------------------------- -* Make forward-difference approximation along DX. -* --------------------------------------------------------------- - CALL DCOPY ( N, X, 1, Y, 1 ) - CALL DAXPY ( N, H, DX, 1, Y, 1 ) - - CALL ILOAD ( NCNLN, (1), NEEDC, 1 ) - - MODE = 0 - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, Y, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - -* Set ERR = (C1 - C)/H - Jacobian*DX. This should be small. - - DO 170 I = 1, NCNLN - ERR(I) = (C1(I) - C(I)) / H - CJDX(I) - 170 CONTINUE - IMAX = IDAMAX( NCNLN, ERR, 1 ) - EMAX = ABS( ERR(IMAX) ) / (ONE + ABS( CJDX(IMAX) )) - - IF (EMAX .LE. OKTOL) THEN - IF (MSGLVL .GT. 0) WRITE (NOUT, 2000) - ELSE - WRITE (NOUT, 2100) - IF (EMAX .GE. ONE) INFORM = 2 - END IF - IF (MSGLVL .GT. 0) WRITE (NOUT, 2200) EMAX, IMAX - END IF - -* ================================================================== -* Component-wise check. -* ================================================================== - IF (LVRFYC .GE. 2) THEN - IF (LVLDER .EQ. 3) THEN - -* Recompute the Jacobian to find the non-constant elements. - - DO 280 J = 1, N - CALL DLOAD ( NCNLN, RDUMMY, UJAC(1,J), 1 ) - 280 CONTINUE - - CALL ILOAD ( NCNLN, (1), NEEDC, 1 ) - NSTATE = 0 - MODE = 2 - - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - END IF - - CALL ILOAD ( NCNLN, (0), NEEDC, 1 ) - - ITMAX = 3 - NCHECK = 0 - NWRONG = 0 - NGOOD = 0 - COLMAX = - ONE - JCOL = 0 - IROW = 0 - MODE = 0 - J3 = JVERFY(3) - J4 = JVERFY(4) - -* --------------------------------------------------------------- -* Loop over each column. -* --------------------------------------------------------------- - DO 600 J = J3, J4 - - CALL DLOAD ( NCNLN, ZERO, ERR, 1 ) - HEADNG = .TRUE. - XJ = X(J) - - STEPBL = BIGLOW - STEPBU = BIGUPP - IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ - IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ - - SIGNH = ONE - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) SIGNH = - ONE - - DO 500 I = 1, NCNLN - EPSACI = EPSRF*(ONE + ABS( C(I) )) - - IF (UJAC(I,J) .NE. RDUMMY) THEN -* ------------------------------------------------------ -* Check this Jacobian element. -* ------------------------------------------------------ - NCHECK = NCHECK + 1 - NEEDC(I) = 1 - - CIJ = CJAC(I,J) - CJSIZE = ONE + ABS( CIJ ) -* ------------------------------------------------------ -* Find a finite-difference interval by iteration. -* ------------------------------------------------------ - ITER = 0 - HOPT = TWO*(ONE + ABS( XJ ))*SQRT( EPSRF ) - H = TEN*HOPT*SIGNH - CDEST = ZERO - SDEST = ZERO - FIRST = .TRUE. - -*+ REPEAT - 400 X(J) = XJ + H - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - F1 = C1(I) - - X(J) = XJ + H + H - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - F2 = C1(I) - - CALL CHCORE( DEBUG,DONE,FIRST,EPSACI,EPSRF,C(I),XJ, - $ INFO, ITER, ITMAX, - $ CDEST, FDEST, SDEST, ERRBND, F1, - $ F2, H, HOPT, HPHI ) - -*+ UNTIL DONE - IF (.NOT. DONE) GO TO 400 - -* ------------------------------------------------------ -* Exit for this element. -* ------------------------------------------------------ - CJDIFF = CDEST - ERR(I) = ABS( CJDIFF - CIJ ) / CJSIZE - - OK = ERR(I) .LE. OKTOL - IF (OK) THEN - KEY = LGOOD - NGOOD = NGOOD + 1 - ELSE - KEY = LBAD - NWRONG = NWRONG + 1 - END IF - - CONST = OK .AND. INFO .EQ. 1 - $ .AND. ABS( CIJ ) .LT. EPSPT8 - IF (.NOT. CONST) THEN - IF (HEADNG) THEN - WRITE (NOUT, 4000) - IF (OK) - $ WRITE (NOUT, 4100) J, XJ , HOPT, I, - $ CIJ, CJDIFF, KEY , ITER - IF (.NOT. OK) - $ WRITE (NOUT, 4110) J, XJ , HOPT, I, - $ CIJ, CJDIFF, KEY , ITER, - $ RESULT(INFO) - HEADNG = .FALSE. - ELSE - IF (OK) - $ WRITE (NOUT, 4200) HOPT, I, - $ CIJ, CJDIFF, KEY , ITER - IF (.NOT. OK) - $ WRITE (NOUT, 4210) HOPT, I, - $ CIJ, CJDIFF, KEY , ITER, - $ RESULT(INFO) - END IF - END IF - NEEDC(I) = 0 - END IF - 500 CONTINUE - -* ------------------------------------------------------------ -* Finished with this column. -* ------------------------------------------------------------ - IF (.NOT. HEADNG) THEN - IMAX = IDAMAX( NCNLN, ERR, 1 ) - EMAX = ABS( ERR(IMAX) ) - - IF (EMAX .GE. COLMAX) THEN - IROW = IMAX - JCOL = J - COLMAX = EMAX - END IF - END IF - X(J) = XJ - - 600 CONTINUE - - IF (NCHECK .EQ. 0) THEN - WRITE (NOUT, 4600) NCSET - ELSE - IF (NWRONG .EQ. 0) THEN - WRITE (NOUT, 4300) NGOOD , NCHECK, J3, J4 - ELSE - WRITE (NOUT, 4400) NWRONG, NCHECK, J3, J4 - END IF - WRITE (NOUT, 4500) COLMAX, IROW, JCOL - END IF - - END IF - -* Copy ( constants + gradients + dummy values ) back into UJAC. - - DO 700 J = 1, N - CALL DCOPY ( NCNLN, CJAC(1,J), 1, UJAC(1,J), 1 ) - 700 CONTINUE - - RETURN - - 999 INFORM = MODE - RETURN - - 1000 FORMAT(/// ' Verification of the constraint gradients.' - $ / ' -----------------------------------------' ) - 2000 FORMAT(/ ' The Jacobian seems to be ok.') - 2100 FORMAT(/ ' XXX The Jacobian seems to be incorrect.') - 2200 FORMAT(/ ' The largest relative error was', 1PE12.2, - $ ' in constraint', I5 /) - 2300 FORMAT(/ ' Every column contains a constant or', - $ ' missing element.') - 4000 FORMAT(// ' Column X(J) DX(J) Row ', - $ ' Jacobian Value Difference Approxn Itns' ) - 4100 FORMAT(/ I7, 1P2E10.2, I5, 1P2E18.8, 2X, A4, I6 ) - 4110 FORMAT(/ I7, 1P2E10.2, I5, 1P2E18.8, 2X, A4, I6, 2X, A18) - 4200 FORMAT( 7X, 10X, 1PE10.2, I5, 1P2E18.8, 2X, A4, I6 ) - 4210 FORMAT( 7X, 10X, 1PE10.2, I5, 1P2E18.8, 2X, A4, I6, 2X, A18) - 4300 FORMAT(/ I7, ' Jacobian elements out of the', I6, - $ ' set in cols', I6, ' through', I6, - $ ' seem to be ok.') - 4400 FORMAT(/ ' XXX There seem to be', I6, - $ ' incorrect Jacobian elements out of the', I6, - $ ' set in cols', I6, ' through', I6 ) - 4500 FORMAT(/ ' The largest relative error was', 1PE12.2, - $ ' in row', I5, ', column', I5 /) - 4600 FORMAT( ' All', I6, ' assigned Jacobian elements are', - $ ' constant.' ) - -* End of CHKJAC. - - END
deleted file mode 100644 --- a/libcruft/npsol/cmalf.f +++ /dev/null @@ -1,294 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMALF ( FIRSTV, HITLOW, ISTATE, INFORM, JADD, - $ N, NROWA, NCLIN, NCTOTL, NUMINF, - $ ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM, - $ ANORM, AP, AX, BL, BU, FEATOL, P, X ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION ANORM(*), AP(*), AX(*), - $ BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL), - $ P(N), X(N) - LOGICAL FIRSTV, HITLOW - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - LOGICAL CMDBG - INTEGER LCMDBG - PARAMETER (LCMDBG = 5) - COMMON /CMDEBG/ ICMDBG(LCMDBG), CMDBG - -************************************************************************ -* CMALF finds a step ALFA such that the point x + ALFA*P reaches one -* of the linear constraints (including bounds). Two possible steps are -* defined as follows... -* -* ALFA1 is the maximum step that can be taken without violating -* one of the linear constraints that is currently satisfied. -* ALFA2 reaches a linear constraint that is currently violated. -* Usually this will be the furthest such constraint along P, -* but if FIRSTV = .TRUE. it will be the first one along P. -* This is used only when the problem has been determined to be -* infeasible, and the sum of infeasibilities are being -* minimized. (ALFA2 is not defined if NUMINF = 0.) -* -* ALFA will usually be the minimum of ALFA1 and ALFA2. -* ALFA could be negative (since we allow inactive constraints -* to be violated by as much as FEATOL). In such cases, a -* third possible step is computed, to find the nearest satisfied -* constraint (perturbed by FEATOL) along the direction - P. -* ALFA will be reset to this step if it is shorter. This is the -* only case for which the final step ALFA does not move X exactly -* onto a constraint (the one denoted by JADD). -* -* Constraints in the working set are ignored (ISTATE(j) ge 1). -* -* JADD denotes which linear constraint is reached. -* -* HITLOW indicates whether it is the lower or upper bound that -* has restricted ALFA. -* -* Values of ISTATE(j).... -* -* - 2 - 1 0 1 2 3 -* a'x lt bl a'x gt bu a'x free a'x = bl a'x = bu bl = bu -* -* The values -2 and -1 do not occur once a feasible point has been -* found. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 66 version written May 1980. -* This version of CMALF dated 10-June-1986. -************************************************************************ - LOGICAL HLOW1, HLOW2, LASTV, NEGSTP, STEP2 - INTRINSIC ABS, MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - INFORM = 0 - -* ------------------------------------------------------------------ -* First pass -- find steps to perturbed constraints, so that -* PALFA1 will be slightly larger than the true step, and -* PALFA2 will be slightly smaller than it should be. -* In degenerate cases, this strategy gives us some freedom in the -* second pass. The general idea follows that described by P.M.J. -* Harris, p.21 of Mathematical Programming 5, 1 (1973), 1--28. -* ------------------------------------------------------------------ - - NEGSTP = .FALSE. - CALL CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - $ JADD1, JADD2, PALFA1, PALFA2, - $ ISTATE, N, NROWA, NCTOTL, - $ ANORM, AP, AX, BL, BU, FEATOL, P, X ) - - JSAVE1 = JADD1 - JSAVE2 = JADD2 - -* ------------------------------------------------------------------ -* Second pass -- recompute step-lengths without perturbation. -* Amongst constraints that are less than the perturbed steps, -* choose the one (of each type) that makes the largest angle -* with the search direction. -* ------------------------------------------------------------------ - IF (CMDBG .AND. ICMDBG(3) .GT. 0) WRITE (NOUT, 1000) - ALFA1 = BIGALF - ALFA2 = ZERO - IF (FIRSTV) ALFA2 = BIGALF - - APMAX1 = ZERO - APMAX2 = ZERO - ATP1 = ZERO - ATP2 = ZERO - HLOW1 = .FALSE. - HLOW2 = .FALSE. - LASTV = .NOT. FIRSTV - - DO 400 J = 1, NCTOTL - JS = ISTATE(J) - IF (JS .LE. 0) THEN - IF (J .LE. N) THEN - ATX = X(J) - ATP = P(J) - ROWNRM = ONE - ELSE - I = J - N - ATX = AX(I) - ATP = AP(I) - ROWNRM = ANORM(I) + ONE - END IF - - IF ( ABS( ATP ) .LE. EPSPT9*ROWNRM*PNORM) THEN - -* This constraint appears to be constant along P. It is -* not used to compute the step. Give the residual a value -* that can be spotted in the debug output. - - RES = - ONE - ELSE IF (ATP .LE. ZERO .AND. JS .NE. -2) THEN -* --------------------------------------------------------- -* a'x is decreasing. -* --------------------------------------------------------- -* The lower bound is satisfied. Test for smaller ALFA1. - - ABSATP = - ATP - IF (BL(J) .GT. (-BIGBND)) THEN - RES = ATX - BL(J) - IF (PALFA1*ABSATP .GE. RES .OR. J .EQ. JSAVE1) THEN - IF (APMAX1*ROWNRM*PNORM .LT. ABSATP) THEN - APMAX1 = ABSATP / (ROWNRM*PNORM) - ALFA1 = RES / ABSATP - JADD1 = J - ATP1 = ATP - HLOW1 = .TRUE. - END IF - END IF - END IF - - IF (JS. EQ. -1) THEN - -* The upper bound is violated. Test for either a bigger -* or smaller ALFA2, depending on the value of FIRSTV. - - RES = ATX - BU(J) - IF ( (FIRSTV .AND. PALFA2*ABSATP .GE. RES - $ .OR. LASTV .AND. PALFA2*ABSATP .LE. RES) - $ .OR. J .EQ. JSAVE2) THEN - IF (APMAX2*ROWNRM*PNORM .LT. ABSATP) THEN - APMAX2 = ABSATP / (ROWNRM*PNORM) - IF (ABSATP .GE. ONE ) THEN - ALFA2 = RES / ABSATP - ELSE IF (RES .LT. BIGALF*ABSATP) THEN - ALFA2 = RES / ABSATP - ELSE - ALFA2 = BIGALF - END IF - JADD2 = J - ATP2 = ATP - HLOW2 = .FALSE. - END IF - END IF - END IF - ELSE IF (ATP .GT. ZERO .AND. JS .NE. -1) THEN -* --------------------------------------------------------- -* a'x is increasing and the upper bound is not violated. -* --------------------------------------------------------- -* Test for smaller ALFA1. - - IF (BU(J) .LT. BIGBND) THEN - RES = BU(J) - ATX - IF (PALFA1*ATP .GE. RES .OR. J .EQ. JSAVE1) THEN - IF (APMAX1*ROWNRM*PNORM .LT. ATP) THEN - APMAX1 = ATP / (ROWNRM*PNORM) - ALFA1 = RES / ATP - JADD1 = J - ATP1 = ATP - HLOW1 = .FALSE. - END IF - END IF - END IF - - IF (JS .EQ. -2) THEN - -* The lower bound is violated. Test for a new ALFA2. - - RES = BL(J) - ATX - IF ( (FIRSTV .AND. PALFA2*ATP .GE. RES - $ .OR. LASTV .AND. PALFA2*ATP .LE. RES) - $ .OR. J .EQ. JSAVE2) THEN - IF (APMAX2*ROWNRM*PNORM .LT. ATP) THEN - APMAX2 = ATP / (ROWNRM*PNORM) - IF (ATP .GE. ONE ) THEN - ALFA2 = RES / ATP - ELSE IF (RES .LT. BIGALF*ATP) THEN - ALFA2 = RES / ATP - ELSE - ALFA2 = BIGALF - END IF - JADD2 = J - ATP2 = ATP - HLOW2 = .TRUE. - END IF - END IF - END IF - END IF - - IF (CMDBG .AND. ICMDBG(3) .GT. 0) - $ WRITE (NOUT, 1200) J, JS, FEATOL(J), RES, ATP, JADD1, - $ ALFA1, JADD2, ALFA2 - END IF - 400 CONTINUE - -* ================================================================== -* Determine ALFA, the step to be taken. -* ================================================================== -* In the infeasible case, check whether to take the step ALFA2 -* rather than ALFA1... - - STEP2 = NUMINF .GT. 0 .AND. JADD2 .GT. 0 - -* We do so if ALFA2 is less than ALFA1 or (if FIRSTV is false) -* lies in the range (ALFA1, PALFA1) and has a smaller value of -* ATP. - - STEP2 = STEP2 .AND. (ALFA2 .LT. ALFA1 .OR. LASTV .AND. - $ ALFA2 .LE. PALFA1 .AND. APMAX2 .GE. APMAX1) - - IF (STEP2) THEN - ALFA = ALFA2 - PALFA = PALFA2 - JADD = JADD2 - ATPHIT = ATP2 - HITLOW = HLOW2 - ELSE - ALFA = ALFA1 - PALFA = PALFA1 - JADD = JADD1 - ATPHIT = ATP1 - HITLOW = HLOW1 - -* If ALFA1 is negative, the constraint to be added (JADD) -* remains unchanged, but ALFA may be shortened to the step -* to the nearest perturbed satisfied constraint along - P. - - NEGSTP = ALFA .LT. ZERO - IF (NEGSTP) THEN - CALL CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - $ JADD1, JADD2, PALFA1, PALFA2, - $ ISTATE, N, NROWA, NCTOTL, - $ ANORM, AP, AX, BL, BU, FEATOL, P, X ) - - IF (CMDBG .AND. ICMDBG(1) .GT. 0) - $ WRITE (NOUT, 9000) ALFA, PALFA1 - - ALFA = - MIN( ABS( ALFA ), PALFA1 ) - END IF - END IF - -* Test for undefined or infinite step. - - IF (JADD .EQ. 0) THEN - ALFA = BIGALF - PALFA = BIGALF - END IF - - IF (ALFA .GE. BIGALF) INFORM = 3 - IF (CMDBG .AND. ICMDBG(1) .GT. 0 .AND. INFORM .GT. 0) - $ WRITE (NOUT, 9010) JADD, ALFA - RETURN - - 1000 FORMAT(/ ' CMALF entered' - $ / ' J JS FEATOL RES AP', - $ ' JADD1 ALFA1 JADD2 ALFA2 '/) - 1200 FORMAT( I5, I4, 3G15.5, 2(I6, G17.7) ) - 9000 FORMAT(/ ' //CMALF // Negative step', - $ / ' //CMALF // ALFA PALFA' - $ / ' //CMALF //', 2G15.4 ) - 9010 FORMAT(/ ' //CMALF // Unbounded step.' - $ / ' //CMALF // JADD ALFA' - $ / ' //CMALF // ', I4, G15.4 ) - -* End of CMALF . - - END
deleted file mode 100644 --- a/libcruft/npsol/cmalf1.f +++ /dev/null @@ -1,167 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File CMSUBS FORTRAN -* -* CMALF1 CMALF CMCHK CMPERM CMPRT CMQMUL CMR1MD -* CMRSWP CMTSOL -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMALF1( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - $ JADD1 , JADD2 , PALFA1, PALFA2, - $ ISTATE, N, NROWA, NCTOTL, - $ ANORM, AP, AX, BL, BU, FEATOL, P, X ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL FIRSTV, NEGSTP - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION ANORM(*), AP(*), AX(*) - DOUBLE PRECISION BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL), - $ P(N), X(N) - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - LOGICAL CMDBG - INTEGER LCMDBG - PARAMETER (LCMDBG = 5) - COMMON /CMDEBG/ ICMDBG(LCMDBG), CMDBG - -************************************************************************ -* CMALF1 finds steps PALFA1, PALFA2 such that -* X + PALFA1*P reaches a linear constraint that is currently not -* in the working set but is satisfied. -* X + PALFA2*P reaches a linear constraint that is currently not -* in the working set but is violated. -* The constraints are perturbed by an amount FEATOL, so that PALFA1 -* is slightly larger than it should be, and PALFA2 is slightly -* smaller than it should be. This gives some leeway later when the -* exact steps are computed by CMALF. -* -* Constraints in the working set are ignored (ISTATE(j) .GE. 1). -* -* If NEGSTP is true, the search direction will be taken to be - P. -* -* -* Values of ISTATE(j).... -* -* - 2 - 1 0 1 2 3 -* a'x lt bl a'x gt bu a'x free a'x = bl a'x = bu bl = bu -* -* The values -2 and -1 do not occur once a feasible point has -* been found. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 66 version written May 1980. -* This version of CMALF1 dated 26-June-1986. -************************************************************************ - LOGICAL LASTV - INTRINSIC ABS - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - IF (CMDBG .AND. ICMDBG(3) .GT. 0) WRITE (NOUT, 1100) - LASTV = .NOT. FIRSTV - JADD1 = 0 - JADD2 = 0 - PALFA1 = BIGALF - - PALFA2 = ZERO - IF (FIRSTV) PALFA2 = BIGALF - - DO 200 J = 1, NCTOTL - JS = ISTATE(J) - IF (JS .LE. 0) THEN - IF (J .LE. N) THEN - ATX = X(J) - ATP = P(J) - ROWNRM = ONE - ELSE - I = J - N - ATX = AX(I) - ATP = AP(I) - ROWNRM = ONE + ANORM(I) - END IF - IF (NEGSTP) ATP = - ATP - - IF ( ABS( ATP ) .LE. EPSPT9*ROWNRM*PNORM) THEN - -* This constraint appears to be constant along P. It is -* not used to compute the step. Give the residual a value -* that can be spotted in the debug output. - - RES = - ONE - ELSE IF (ATP .LE. ZERO .AND. JS .NE. -2) THEN -* --------------------------------------------------------- -* a'x is decreasing and the lower bound is not violated. -* --------------------------------------------------------- -* First test for smaller PALFA1. - - ABSATP = - ATP - IF (BL(J) .GT. (-BIGBND)) THEN - RES = ATX - BL(J) + FEATOL(J) - IF (BIGALF*ABSATP .GT. ABS( RES )) THEN - IF (PALFA1*ABSATP .GT. RES) THEN - PALFA1 = RES / ABSATP - JADD1 = J - END IF - END IF - END IF - - IF (JS .EQ. -1) THEN - -* The upper bound is violated. Test for either larger -* or smaller PALFA2, depending on the value of FIRSTV. - - RES = ATX - BU(J) - FEATOL(J) - IF (BIGALF*ABSATP .GT. ABS( RES )) THEN - IF (FIRSTV .AND. PALFA2*ABSATP .GT. RES .OR. - $ LASTV .AND. PALFA2*ABSATP .LT. RES) THEN - PALFA2 = RES / ABSATP - JADD2 = J - END IF - END IF - END IF - ELSE IF (ATP .GT. ZERO .AND. JS .NE. -1) THEN -* --------------------------------------------------------- -* a'x is increasing and the upper bound is not violated. -* --------------------------------------------------------- -* Test for smaller PALFA1. - - IF (BU(J) .LT. BIGBND) THEN - RES = BU(J) - ATX + FEATOL(J) - IF (BIGALF*ATP .GT. ABS( RES )) THEN - IF (PALFA1*ATP .GT. RES) THEN - PALFA1 = RES / ATP - JADD1 = J - END IF - END IF - END IF - - IF (JS .EQ. -2) THEN - -* The lower bound is violated. Test for a new PALFA2. - - RES = BL(J) - ATX - FEATOL(J) - IF (BIGALF*ATP .GT. ABS( RES )) THEN - IF (FIRSTV .AND. PALFA2*ATP .GT. RES .OR. - $ LASTV .AND. PALFA2*ATP .LT. RES) THEN - PALFA2 = RES / ATP - JADD2 = J - END IF - END IF - END IF - END IF - - IF (CMDBG .AND. ICMDBG(3) .GT. 0) - $ WRITE (NOUT, 1200) J, JS, FEATOL(J), RES, - $ ATP, JADD1, PALFA1, JADD2, PALFA2 - END IF - 200 CONTINUE - - RETURN - - 1100 FORMAT(/ ' J JS FEATOL RES AP', - $ ' JADD1 PALFA1 JADD2 PALFA2' /) - 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7)) - -* End of CMALF1. - - END
deleted file mode 100644 --- a/libcruft/npsol/cmchk.f +++ /dev/null @@ -1,115 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMCHK ( NERROR, MSGLVL, COLD, USERKX, - $ LIWORK, LWORK, LITOTL, LWTOTL, - $ N, NCLIN, NCNLN, - $ ISTATE, KX, NAMED, NAMES, LENNAM, - $ BL, BU, X ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*8 NAMES(*) - LOGICAL COLD, NAMED, USERKX - INTEGER ISTATE(N+NCLIN+NCNLN), KX(N) - DOUBLE PRECISION BL(N+NCLIN+NCNLN), BU(N+NCLIN+NCNLN), X(N) - - COMMON /SOL1CM/ NOUT - -************************************************************************ -* CMCHK checks the data input to various optimizers. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 66 version written 10-May-1980. -* Fortran 77 version written 5-October-1984. -* This version of CMCHK dated 23-January-1987. -************************************************************************ - LOGICAL OK - INTRINSIC ABS - PARAMETER ( ZERO = 0.0D+0 , ONE = 1.0D+0 ) - - CHARACTER*5 ID(3) - DATA ID(1) , ID(2) , ID(3) - $ / 'VARBL' , 'LNCON' , 'NLCON' / - - NERROR = 0 - -* ------------------------------------------------------------------ -* Check that there is enough workspace to solve the problem. -* ------------------------------------------------------------------ - OK = LITOTL .LE. LIWORK .AND. LWTOTL .LE. LWORK - IF (.NOT. OK) THEN - WRITE (NOUT, 1100) LIWORK, LWORK, LITOTL, LWTOTL - NERROR = NERROR + 1 - WRITE (NOUT, 1110) - ELSE IF (MSGLVL .GT. 0) THEN - WRITE (NOUT, 1100) LIWORK, LWORK, LITOTL, LWTOTL - END IF - - IF (USERKX) THEN -* --------------------------------------------------------------- -* Check for a valid KX. -* --------------------------------------------------------------- - IFAIL = 1 - CALL CMPERM( KX, 1, N, IFAIL ) - IF (IFAIL .NE. 0) THEN - WRITE (NOUT, 1300) - NERROR = NERROR + 1 - END IF - END IF - -* ------------------------------------------------------------------ -* Check the bounds on all variables and constraints. -* ------------------------------------------------------------------ - DO 200 J = 1, N+NCLIN+NCNLN - B1 = BL(J) - B2 = BU(J) - OK = B1 .LE. B2 - IF (.NOT. OK) THEN - NERROR = NERROR + 1 - IF (J .GT. N+NCLIN) THEN - K = J - N - NCLIN - L = 3 - ELSE IF (J .GT. N) THEN - K = J - N - L = 2 - ELSE - K = J - L = 1 - END IF - IF (.NOT. NAMED) WRITE (NOUT, 1200) ID(L), K, B1, B2 - IF ( NAMED) WRITE (NOUT, 1210) NAMES(J), B1, B2 - END IF - 200 CONTINUE - -* ------------------------------------------------------------------ -* If warm start, check ISTATE. -* ------------------------------------------------------------------ - IF (.NOT. COLD) THEN - DO 420 J = 1, N+NCLIN+NCNLN - IS = ISTATE(J) - OK = IS .GE. (- 2) .AND. IS .LE. 4 - IF (.NOT. OK) THEN - NERROR = NERROR + 1 - WRITE (NOUT, 1500) J, IS - END IF - 420 CONTINUE - END IF - - RETURN - - 1100 FORMAT(/ ' Workspace provided is IW(', I6, - $ '), W(', I6, ').' / - $ ' To solve problem we need IW(', I6, - $ '), W(', I6, ').') - 1110 FORMAT(/ ' XXX Not enough workspace to solve problem.') - 1200 FORMAT(/ ' XXX The bounds on ', A5, I3, - $ ' are inconsistent. BL =', G16.7, ' BU =', G16.7) - 1210 FORMAT(/ ' XXX The bounds on ', A8, - $ ' are inconsistent. BL =', G16.7, ' BU =', G16.7) - 1300 FORMAT(/ ' XXX KX has not been supplied as a valid', - $ ' permutation.' ) - 1500 FORMAT(/ ' XXX Component', I5, ' of ISTATE is out of', - $ ' range...', I10) - -* End of CMCHK . - - END
deleted file mode 100644 --- a/libcruft/npsol/cmperm.f +++ /dev/null @@ -1,89 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMPERM( KX, M1, M2, IFAIL ) - - INTEGER IFAIL, M1, M2 - INTEGER KX(M2) - - COMMON /SOL1CM/ NOUT - -************************************************************************ -* CMPERM checks that elements M1 to M2 of KX contain a valid -* permutation of the integers M1 to M2. The contents of KX are -* unchanged on exit. -* -* SOL version of NAG Library routine M01ZBF. -* Written by N.N.Maclaren, University of Cambridge. -* This version of CMPERM dated 18-June-1986. -************************************************************************ - - LOGICAL CMDBG - INTEGER LCMDBG - PARAMETER (LCMDBG = 5) - COMMON /CMDEBG/ ICMDBG(LCMDBG), CMDBG - - INTEGER I, IERR, J, K - INTRINSIC ABS - -* Check the parameters. - - IF (M2 .LT. 1 .OR. M1 .LT. 1 .OR. M1 .GT. M2) THEN - IERR = 1 - IF (CMDBG .AND. ICMDBG(3) .GT. 0) - $ WRITE (NOUT, FMT=1100) M1, M2 - ELSE - IERR = 0 - -* Check that KX is within range. - - DO 20 I = M1, M2 - J = KX(I) - IF ((J .LT. M1) .OR. (J .GT. M2)) GO TO 100 - IF (I .NE. J) KX(I) = -J - 20 CONTINUE - -* Check that no value is repeated. - - DO 60 I = M1, M2 - K = - KX(I) - IF (K .GE. 0) THEN - J = I - 40 KX(J) = K - J = K - K = - KX(J) - IF (K .GT. 0) GO TO 40 - IF (J .NE. I) GO TO 120 - END IF - 60 CONTINUE - END IF - -* Return - - 80 IF (IERR .NE. 0) THEN - IFAIL = IERR - ELSE - IFAIL = 0 - END IF - RETURN - 100 IERR = 2 - WRITE (NOUT, FMT=1200) I, J - GO TO 140 - 120 IERR = 3 - WRITE (NOUT, FMT=1300) J - -* Restore KX. - - 140 DO 160 I = M1, M2 - KX(I) = ABS(KX(I)) - 160 CONTINUE - GO TO 80 - - 1100 FORMAT(/ ' //CMPERM// Illegal parameter values,' - $ / ' //CMPERM// M1 M1' - $ / ' //CMPERM//', 2I6 ) - 1200 FORMAT(/ ' XXX KX(',I6,') contains an out-of-range value =', I16) - 1300 FORMAT(/ ' XXX KX contains a duplicate value =', I16) - -* End of CMPERM. - - END
deleted file mode 100644 --- a/libcruft/npsol/cmprt.f +++ /dev/null @@ -1,168 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMPRT ( MSGLVL, NFREE, NROWA, - $ N, NCLIN, NCNLN, NCTOTL, BIGBND, - $ NAMED, NAMES, LENNAM, - $ NACTIV, ISTATE, KACTIV, KX, - $ A, BL, BU, C, CLAMDA, RLAMDA, X ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*8 NAMES(*) - LOGICAL NAMED - INTEGER ISTATE(NCTOTL), KACTIV(N), KX(N) - DOUBLE PRECISION A(NROWA,*), BL(NCTOTL), BU(NCTOTL), C(*), - $ CLAMDA(NCTOTL), RLAMDA(N), X(N) - - COMMON /SOL1CM/ NOUT - - LOGICAL CMDBG - INTEGER LCMDBG - PARAMETER (LCMDBG = 5) - COMMON /CMDEBG/ ICMDBG(LCMDBG), CMDBG - -*********************************************************************** -* CMPRT creates the expanded Lagrange multiplier vector CLAMDA. -* If MSGLVL .EQ 1 or MSGLVL .GE. 10, CMPRT prints x, A*x, -* c(x), their bounds, the multipliers, and the residuals (distance -* to the nearer bound). -* CMPRT is called by LSCORE and NPCORE just before exiting. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 77 version written October 1984. -* This version of CMPRT dated 10-June-1986. -*********************************************************************** - CHARACTER*2 LS, LSTATE(7) - CHARACTER*5 ID(3), ID3 - CHARACTER*8 ID4 - EXTERNAL DDOT - INTRINSIC ABS - - PARAMETER ( ZERO = 0.0D+0 ) - DATA ID(1) / 'VARBL' / - DATA ID(2) / 'LNCON' / - DATA ID(3) / 'NLCON' / - DATA LSTATE(1) / '--' /, LSTATE(2) / '++' / - DATA LSTATE(3) / 'FR' /, LSTATE(4) / 'LL' / - DATA LSTATE(5) / 'UL' /, LSTATE(6) / 'EQ' / - DATA LSTATE(7) / 'TB' / - - - NPLIN = N + NCLIN - NZ = NFREE - NACTIV - -* Expand multipliers for bounds, linear and nonlinear constraints -* into the CLAMDA array. - - CALL DLOAD ( NCTOTL, ZERO, CLAMDA, 1 ) - NFIXED = N - NFREE - DO 150 K = 1, NACTIV+NFIXED - IF (K .LE. NACTIV) J = KACTIV(K) + N - IF (K .GT. NACTIV) J = KX(NZ+K) - CLAMDA(J) = RLAMDA(K) - 150 CONTINUE - - IF (MSGLVL .LT. 10 .AND. MSGLVL .NE. 1) RETURN - - WRITE (NOUT, 1100) - ID3 = ID(1) - - DO 500 J = 1, NCTOTL - B1 = BL(J) - B2 = BU(J) - WLAM = CLAMDA(J) - IS = ISTATE(J) - LS = LSTATE(IS + 3) - IF (J .LE. N) THEN - -* Section 1 -- the variables x. -* ------------------------------ - K = J - V = X(J) - - ELSE IF (J .LE. NPLIN) THEN - -* Section 2 -- the linear constraints A*x. -* ----------------------------------------- - IF (J .EQ. N + 1) THEN - WRITE (NOUT, 1200) - ID3 = ID(2) - END IF - - K = J - N - V = DDOT ( N, A(K,1), NROWA, X, 1 ) - ELSE - -* Section 3 -- the nonlinear constraints c(x). -* --------------------------------------------- - - IF (J .EQ. NPLIN + 1) THEN - WRITE (NOUT, 1300) - ID3 = ID(3) - END IF - - K = J - NPLIN - V = C(K) - END IF - -* Print a line for the j-th variable or constraint. -* ------------------------------------------------- - RES = V - B1 - RES2 = B2 - V - IF (ABS(RES) .GT. ABS(RES2)) RES = RES2 - IP = 1 - IF (B1 .LE. ( - BIGBND )) IP = 2 - IF (B2 .GE. BIGBND ) IP = IP + 2 - IF (NAMED) THEN - - ID4 = NAMES(J) - IF (IP .EQ. 1) THEN - WRITE (NOUT, 2100) ID4, LS, V, B1, B2, WLAM, RES - ELSE IF (IP .EQ. 2) THEN - WRITE (NOUT, 2200) ID4, LS, V, B2, WLAM, RES - ELSE IF (IP .EQ. 3) THEN - WRITE (NOUT, 2300) ID4, LS, V, B1, WLAM, RES - ELSE - WRITE (NOUT, 2400) ID4, LS, V, WLAM, RES - END IF - - ELSE - - IF (IP .EQ. 1) THEN - WRITE (NOUT, 3100) ID3, K, LS, V, B1, B2, WLAM, RES - ELSE IF (IP .EQ. 2) THEN - WRITE (NOUT, 3200) ID3, K, LS, V, B2, WLAM, RES - ELSE IF (IP .EQ. 3) THEN - WRITE (NOUT, 3300) ID3, K, LS, V, B1, WLAM, RES - ELSE - WRITE (NOUT, 3400) ID3, K, LS, V, WLAM, RES - END IF - END IF - 500 CONTINUE - RETURN - - 1100 FORMAT(// ' Variable State', 5X, ' Value', - $ 6X, ' Lower bound', 4X, ' Upper bound', - $ ' Lagr multiplier', ' Residual' /) - 1200 FORMAT(// ' Linear constr State', 5X, ' Value', - $ 6X, ' Lower bound', 4X, ' Upper bound', - $ ' Lagr multiplier', ' Residual' /) - 1300 FORMAT(// ' Nonlnr constr State', 5X, ' Value', - $ 6X, ' Lower bound', 4X, ' Upper bound', - $ ' Lagr multiplier', ' Residual' /) - 2100 FORMAT(1X, A8, 10X, A2, 3G16.7, G16.7, G16.4) - 2200 FORMAT(1X, A8, 10X, A2, G16.7, 5X, ' None', 6X, G16.7, - $ G16.7, G16.4) - 2300 FORMAT(1X, A8, 10X, A2, 2G16.7, 5X, ' None', 6X, G16.7, G16.4) - 2400 FORMAT(1X, A8, 10X, A2, G16.7, 5X, ' None', 11X, ' None', - $ 6X, G16.7, G16.4) - 3100 FORMAT(1X, A5, I3, 10X, A2, 3G16.7, G16.7, G16.4) - 3200 FORMAT(1X, A5, I3, 10X, A2, G16.7, - $ 5X, ' None', 6X, G16.7, G16.7, G16.4) - 3300 FORMAT(1X, A5, I3, 10X, A2, 2G16.7, 5X, ' None', 6X, - $ G16.7, G16.4) - 3400 FORMAT(1X, A5, I3, 10X, A2, G16.7, - $ 5X, ' None', 11X, ' None', 6X, G16.7, G16.4) - -* End of CMPRT - - END
deleted file mode 100644 --- a/libcruft/npsol/cmqmul.f +++ /dev/null @@ -1,138 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMQMUL( MODE, N, NZ, NFREE, NQ, UNITQ, - $ KX, V, ZY, WRK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER KX(N) - DOUBLE PRECISION V(N), ZY(NQ,*), WRK(N) - -************************************************************************ -* CMQMUL transforms the vector v in various ways using the -* matrix Q = ( Z Y ) defined by the input parameters. -* -* MODE result -* ---- ------ -* -* 1 v = Z v -* 2 v = Y v -* 3 v = Q v -* -* On input, v is assumed to be ordered as ( v(free) v(fixed) ). -* on output, v is a full n-vector. -* -* -* 4 v = Z'v -* 5 v = Y'v -* 6 v = Q'v -* -* On input, v is a full n-vector. -* On output, v is ordered as ( v(free) v(fixed) ). -* -* 7 v = Y'v -* 8 v = Q'v -* -* On input, v is a full n-vector. -* On output, v is as in modes 5 and 6 except that v(fixed) is not -* set. -* -* Modes 1, 4, 7 and 8 do not involve v(fixed). -* Original F66 version April 1983. -* Fortran 77 version written 9-February-1985. -* Level 2 BLAS added 10-June-1986. -* This version of CMQMUL dated 10-June-1986. -************************************************************************ - EXTERNAL DDOT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - NFIXED = N - NFREE - J1 = 1 - J2 = NFREE - IF (MODE .EQ. 1 .OR. MODE .EQ. 4) J2 = NZ - IF (MODE .EQ. 2 .OR. MODE .EQ. 5 .OR. MODE .EQ. 7) J1 = NZ + 1 - LENV = J2 - J1 + 1 - IF (MODE .LE. 3) THEN -* =============================================================== -* Mode = 1, 2 or 3. -* =============================================================== - - IF (NFREE .GT. 0) CALL DLOAD ( NFREE, ZERO, WRK, 1 ) - -* Copy v(fixed) into the end of wrk. - - IF (MODE .GE. 2 .AND. NFIXED .GT. 0) - $ CALL DCOPY ( NFIXED, V(NFREE+1), 1, WRK(NFREE+1), 1 ) - -* Set WRK = relevant part of ZY * V. - - IF (LENV .GT. 0) THEN - IF (UNITQ) THEN - CALL DCOPY ( LENV, V(J1), 1, WRK(J1), 1 ) - ELSE - CALL DGEMV ( 'N', NFREE, J2-J1+1, ONE, ZY(1,J1), NQ, - $ V(J1), 1, ONE, WRK, 1 ) - END IF - END IF - -* Expand WRK into V as a full n-vector. - - CALL DLOAD ( N, ZERO, V, 1 ) - DO 220 K = 1, NFREE - J = KX(K) - V(J) = WRK(K) - 220 CONTINUE - -* Copy WRK(fixed) into the appropriate parts of V. - - IF (MODE .GT. 1) THEN - DO 320 L = 1, NFIXED - J = KX(NFREE+L) - V(J) = WRK(NFREE+L) - 320 CONTINUE - END IF - - ELSE -* =============================================================== -* Mode = 4, 5, 6, 7 or 8. -* =============================================================== -* Put the fixed components of V into the end of WRK. - - IF (MODE .EQ. 5 .OR. MODE .EQ. 6) THEN - DO 420 L = 1, NFIXED - J = KX(NFREE+L) - WRK(NFREE+L) = V(J) - 420 CONTINUE - END IF - -* Put the free components of V into the beginning of WRK. - - IF (NFREE .GT. 0) THEN - DO 520 K = 1, NFREE - J = KX(K) - WRK(K) = V(J) - 520 CONTINUE - -* Set V = relevant part of ZY' * WRK. - - IF (LENV .GT. 0) THEN - IF (UNITQ) THEN - CALL DCOPY ( LENV, WRK(J1), 1, V(J1), 1 ) - ELSE - CALL DGEMV ( 'T', NFREE, J2-J1+1, ONE, ZY(1,J1), NQ, - $ WRK, 1, ZERO, V(J1), 1 ) - END IF - END IF - END IF - -* Copy the fixed components of WRK into the end of V. - - IF (NFIXED .GT. 0 .AND. (MODE .EQ. 5 .OR. MODE .EQ. 6)) - $ CALL DCOPY ( NFIXED, WRK(NFREE+1), 1, V(NFREE+1), 1 ) - END IF - - RETURN - -* End of CMQMUL. - - END
deleted file mode 100644 --- a/libcruft/npsol/cmr1md.f +++ /dev/null @@ -1,74 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMR1MD( N, NU, NRANK, NROWR, LENV, LENW, - $ R, U, V, W ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER N, NU, NRANK, NROWR, LENV, LENW - DOUBLE PRECISION R(NROWR,*), U(N,*), V(N), W(N) -************************************************************************ -* CMR1MD modifies the nrank*n upper-triangular matrix R so that -* Q*(R + v*w') is upper triangular, where Q is orthogonal, -* v and w are vectors, and the modified R overwrites the old. -* Q is the product of two sweeps of plane rotations (not stored). -* If required, the rotations are applied to the NU columns of -* the matrix U. -* -* The matrix V*W' is an (LENV) by (LENW) matrix. -* The vector V is overwritten. -* -* Systems Optimization Laboratory, Stanford University. -* Original version October 1984. -* This version of CMR1MD dated 18-September-1985. -************************************************************************ - INTRINSIC MIN - - J = MIN( LENV, NRANK ) - IF (NRANK .GT. 0) THEN - -* =============================================================== -* Reduce components 1 thru (J-1) of V to zero, using a -* backward sweep of rotations. The rotations create a horizontal -* spike in the j-th row of R. This row is stored in V. -* (Note that DROT3G sets V(K) = 0 below as required.) -* =============================================================== - LROWJ = N - J + 1 - VJ = V(J) - CALL DCOPY ( LROWJ, R(J,J), NROWR, V(J), 1 ) - LROWK = LROWJ - DO 400 K = J-1, 1, -1 - LROWK = LROWK + 1 - CALL DROT3G( VJ, V(K), CS, SN ) - CALL DROT3 ( LROWK, V(K) , 1, R(K,K), NROWR, CS, SN ) - - IF (NU .GT. 0) - $ CALL DROT3 ( NU , U(J,1), N, U(K,1), N , CS, SN ) - 400 CONTINUE - -* =============================================================== -* Add a multiple of elements 1 thru LENW of W to the row -* spike of R (stored in elements 1 thru N of V). -* =============================================================== - CALL DAXPY ( LENW, VJ, W, 1, V, 1 ) - -* =============================================================== -* Eliminate the row spike (held in V) using a forward sweep -* of rotations. -* =============================================================== - DO 600 K = 1, J-1 - LROWK = LROWK - 1 - L = K + 1 - CALL DROT3G( R(K,K), V(K), CS, SN ) - CALL DROT3 ( LROWK, R(K,L), NROWR, V(L) , 1, CS, SN ) - - IF (NU .GT. 0) - $ CALL DROT3 ( NU , U(K,1), N , U(J,1), N, CS, SN ) - 600 CONTINUE - CALL DCOPY ( LROWJ, V(J), 1, R(J,J), NROWR ) - END IF - - RETURN - -* End of CMR1MD - - END
deleted file mode 100644 --- a/libcruft/npsol/cmrswp.f +++ /dev/null @@ -1,89 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMRSWP( N, NU, NRANK, NROWR, I, J, R, U, V ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER N, NU, NRANK, NROWR, I, J - DOUBLE PRECISION R(NROWR,*), U(N,*), V(N) - -************************************************************************ -* CMRSWP interchanges the I-th and J-th (I .LT. J) columns of -* an NRANK*N upper-triangular matrix R and restores the -* resulting matrix to upper-triangular form. The final matrix R -* is equal to Q(R + VW') where V and W are defined as -* V = Rj - Ri and W = Ei - Ej -* with Ri and Rj the Ith and Jth columns of R, Ei and Ej -* unit vectors. -* -* The vector V is used as workspace. R is overwritten. Q is the -* product of two sweeps of plane rotations (not stored). -* If required, the rotations are applied to the nu columns of -* the matrix U. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version of CMRSWP dated 18-September-1985. -************************************************************************ - INTRINSIC MIN - INTEGER K, L, LENI1, LENJ, LROWJ, LROWK - DOUBLE PRECISION CS, SN, VJ - - LENJ = MIN( J, NRANK ) - IF (LENJ .GT. 0) THEN - CALL DCOPY ( LENJ, R(1,J), 1, V, 1 ) - IF (I .LE. NRANK) V(I) = V(I) - R(I,I) - LENI1 = MIN( I-1, NRANK ) - IF (LENI1 .GT. 0) THEN - CALL DCOPY ( LENI1, R(1,I), 1, R(1,J), 1 ) - CALL DCOPY ( LENI1, V , 1, R(1,I), 1 ) - END IF - END IF - IF (I .LE. NRANK) THEN - -* =============================================================== -* Reduce components I thru (LENJ-1) of V to zero, using a -* backward sweep of rotations. The rotations create a horizontal -* spike in the LENJ-th row of R. This row is stored in V. -* (Note that DROT3G sets V(K) = 0 below as required.) -* =============================================================== - LROWJ = N - LENJ + 1 - VJ = V(LENJ) - CALL DCOPY ( LROWJ, R(LENJ,LENJ), NROWR, V(LENJ), 1 ) - LROWK = LROWJ - DO 400 K = LENJ-1, I, -1 - LROWK = LROWK + 1 - CALL DROT3G( VJ, V(K), CS, SN ) - CALL DROT3 ( LROWK, V(K) , 1, R(K,K), NROWR, CS, SN ) - - IF (NU .GT. 0) - $ CALL DROT3 ( NU , U(LENJ,1), N, U(K,1), N , CS, SN ) - 400 CONTINUE - -* =============================================================== -* Add a multiple of elements I thru J of W to the -* horizontal spike of R (held in elements I thru J of V). -* =============================================================== - V(I) = V(I) + VJ - V(J) = V(J) - VJ - -* =============================================================== -* Eliminate the row spike (held in V) using a forward sweep -* of rotations. -* =============================================================== - DO 600 K = I, LENJ-1 - LROWK = LROWK - 1 - L = K + 1 - CALL DROT3G( R(K,K), V(K), CS, SN ) - CALL DROT3 ( LROWK, R(K,L), NROWR, V(L) , 1, CS, SN ) - - IF (NU .GT. 0) - $ CALL DROT3 ( NU , U(K,1), N , U(LENJ,1), N, CS, SN ) - 600 CONTINUE - CALL DCOPY ( LROWJ, V(LENJ), 1, R(LENJ,LENJ), NROWR ) - END IF - - RETURN - -* End of CMRSWP - - END
deleted file mode 100644 --- a/libcruft/npsol/cmtsol.f +++ /dev/null @@ -1,61 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE CMTSOL( MODE, NROWT, N, T, Y ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER MODE, NROWT, N - DOUBLE PRECISION T(NROWT,*), Y(N) - -************************************************************************ -* CMTSOL solves equations involving a reverse-triangular matrix T -* and a right-hand-side vector y, returning the solution in y. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 77 version written February-1985. -************************************************************************ - PARAMETER ( ZERO = 0.0D+0 ) - - N1 = N + 1 - IF (MODE .EQ. 1) THEN - -* Mode = 1 --- Solve T * y(new) = y(old). - - DO 100 J = 1, N - JJ = N1 - J - YJ = Y(J)/T(J,JJ) - Y(J) = YJ - L = JJ - 1 - IF (L .GT. 0 .AND. YJ .NE. ZERO) - $ CALL DAXPY( L, (-YJ), T(J+1,JJ), 1, Y(J+1), 1 ) - 100 CONTINUE - ELSE - -* Mode = 2 --- Solve T' y(new) = y(old). - - DO 500 J = 1, N - JJ = N1 - J - YJ = Y(J)/T(JJ,J) - Y(J) = YJ - L = JJ - 1 - IF (L .GT. 0 .AND. YJ .NE. ZERO) - $ CALL DAXPY( L, (-YJ), T(JJ,J+1), NROWT, Y(J+1), 1 ) - 500 CONTINUE - END IF - -* Reverse the solution vector. - - IF (N .GT. 1) THEN - L = N/2 - DO 800 J = 1, L - JJ = N1 - J - YJ = Y(J) - Y(J) = Y(JJ) - Y(JJ) = YJ - 800 CONTINUE - END IF - - RETURN - -* End of CMTSOL. - - END
deleted file mode 100644 --- a/libcruft/npsol/dcond.f +++ /dev/null @@ -1,50 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File BLAS FORTRAN -* -* Others -* ------ -* DCOND* DDDIV* DDIV DDSCL DGRFG DLOAD DNORM -* DROT3* DROT3G* DSSQ ICOPY* ILOAD IDRANK+ -* -* *Not in the Nag Blas. -* +Differs from the Nag Blas. -* -* QR Routines -* -- -------- -* DGEQR DGEQRP DGEAP DGEAPQ -* -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DCOND ( N, X, INCX, AXMAX, AXMIN ) - - INTEGER N, INCX - DOUBLE PRECISION AXMAX, AXMIN - DOUBLE PRECISION X( (N-1)*INCX+1 ) -C -C DCOND finds the elements in x that are largest and smallest -C in magnitude. -C - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - INTEGER I, IX - INTRINSIC ABS, MAX, MIN - - IF (N .EQ. 0) THEN - AXMAX = ZERO - AXMIN = ZERO - ELSE - AXMAX = ABS( X(1) ) - AXMIN = AXMAX - IX = 1 - DO 100 I = 2, N - IX = IX + INCX - AXMAX = MAX( AXMAX, ABS( X(IX) ) ) - AXMIN = MIN( AXMIN, ABS( X(IX) ) ) - 100 CONTINUE - END IF - - RETURN - -* End of DCOND - - END
deleted file mode 100644 --- a/libcruft/npsol/dddiv.f +++ /dev/null @@ -1,50 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DDDIV ( N, D, INCD, X, INCX ) - INTEGER N, INCD, INCX - DOUBLE PRECISION D( * ), X( * ) -C -C DDDIV performs the operation -C -C x := diag( d )(inverse)*x -C - PARAMETER ( ONE = 1.0 ) - EXTERNAL DSCAL - INTEGER I , ID , IX - - IF( N.GE.1 )THEN - IF( INCD.EQ.0 )THEN - - CALL DSCAL ( N, (ONE/D( 1 )), X, INCX ) - - ELSE IF( ( INCD.EQ.INCX ).AND.( INCD.GT.0 ) )THEN - DO 10, ID = 1, 1 + ( N - 1 )*INCD, INCD - X( ID ) = X( ID )/D( ID ) - 10 CONTINUE - ELSE - IF( INCX.GE.0 )THEN - IX = 1 - ELSE - IX = 1 - ( N - 1 )*INCX - END IF - IF( INCD.GT.0 )THEN - DO 20, ID = 1, 1 + ( N - 1 )*INCD, INCD - X( IX ) = X( IX )/D( ID ) - IX = IX + INCX - 20 CONTINUE - ELSE - ID = 1 - ( N - 1 )*INCD - DO 30, I = 1, N - X( IX ) = X( IX )/D( ID ) - ID = ID + INCD - IX = IX + INCX - 30 CONTINUE - END IF - END IF - END IF - - RETURN - -* End of DDDIV . - - END
deleted file mode 100644 --- a/libcruft/npsol/ddiv.f +++ /dev/null @@ -1,88 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DOUBLE PRECISION FUNCTION DDIV ( A, B, FAIL ) - DOUBLE PRECISION A, B - LOGICAL FAIL -C -C DDIV returns the value div given by -C -C div = ( a/b if a/b does not overflow, -C ( -C ( 0.0 if a .eq. 0.0, -C ( -C ( sign( a/b )*flmax if a .ne. 0.0 and a/b would overflow, -C -C where flmax is a large value, via the function name. In addition if -C a/b would overflow then fail is returned as true, otherwise fail is -C returned as false. -C -C Note that when a and b are both zero, fail is returned as true, -C but div is returned as 0.0. in all other cases of overflow div is -C such that abs( div ) = flmax. -C -C -C Nag Fortran 77 O( 1 ) basic linear algebra routine. -C -C -- Written on 26-October-1982. -C Sven Hammarling, Nag Central Office. -C - INTRINSIC ABS , SIGN - LOGICAL FIRST - DOUBLE PRECISION ABSB , FLMAX , FLMIN - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - SAVE FIRST , FLMIN , FLMAX - DATA FIRST / .TRUE. / - - IF( A.EQ.ZERO )THEN - DDIV = ZERO - IF( B.EQ.ZERO )THEN - FAIL = .TRUE. - ELSE - FAIL = .FALSE. - END IF - RETURN - END IF - - IF( FIRST )THEN - FIRST = .FALSE. - FLMIN = WMACH( 5 ) - FLMAX = WMACH( 7 ) - END IF - - IF( B.EQ.ZERO )THEN - DDIV = SIGN( FLMAX, A ) - FAIL = .TRUE. - ELSE - ABSB = ABS( B ) - IF( ABSB.GE.ONE )THEN - FAIL = .FALSE. - IF( ABS( A ).GE.ABSB*FLMIN )THEN - DDIV = A/B - ELSE - DDIV = ZERO - END IF - ELSE - IF( ABS( A ).LE.ABSB*FLMAX )THEN - FAIL = .FALSE. - DDIV = A/B - ELSE - FAIL = .TRUE. - DDIV = FLMAX - IF( ( ( A.LT.ZERO ).AND.( B.GT.ZERO ) ).OR. - $ ( ( A.GT.ZERO ).AND.( B.LT.ZERO ) ) ) - $ DDIV = -DDIV - END IF - END IF - END IF - - RETURN - -* End of DDIV . - - END
deleted file mode 100644 --- a/libcruft/npsol/ddscl.f +++ /dev/null @@ -1,55 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DDSCL ( N, D, INCD, X, INCX ) - INTEGER N, INCD, INCX - DOUBLE PRECISION D( * ), X( * ) -C -C DDSCL performs the operation -C -C x := diag( d )*x -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-September-1983. -C Sven Hammarling, Nag Central Office. -C - EXTERNAL DSCAL - INTEGER I , ID , IX - - IF( N.GE.1 )THEN - IF( INCD.EQ.0 )THEN - - CALL DSCAL ( N, D( 1 ), X, INCX ) - - ELSE IF( ( INCD.EQ.INCX ).AND.( INCD.GT.0 ) )THEN - DO 10, ID = 1, 1 + ( N - 1 )*INCD, INCD - X( ID ) = D( ID )*X( ID ) - 10 CONTINUE - ELSE - IF( INCX.GE.0 )THEN - IX = 1 - ELSE - IX = 1 - ( N - 1 )*INCX - END IF - IF( INCD.GT.0 )THEN - DO 20, ID = 1, 1 + ( N - 1 )*INCD, INCD - X( IX ) = D( ID )*X( IX ) - IX = IX + INCX - 20 CONTINUE - ELSE - ID = 1 - ( N - 1 )*INCD - DO 30, I = 1, N - X( IX ) = D( ID )*X( IX ) - ID = ID + INCD - IX = IX + INCX - 30 CONTINUE - END IF - END IF - END IF - - RETURN - -* End of DDSCL . - - END
deleted file mode 100644 --- a/libcruft/npsol/dgeap.f +++ /dev/null @@ -1,192 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DGEAP ( SIDE, TRANS, M, N, PERM, K, B, LDB ) -* .. Scalar Arguments .. - INTEGER K, LDB, M, N - CHARACTER*1 SIDE, TRANS -* .. Array Arguments .. - DOUBLE PRECISION B( LDB, * ) - INTEGER PERM( * ) -* .. -* -* Purpose -* ======= -* -* DGEAP performs one of the transformations -* -* B := P'*B or B := P*B, where B is an m by k matrix, -* -* or -* -* B := B*P' or B := B*P, where B is a k by m matrix, -* -* P being an m by m permutation matrix of the form -* -* P = P( 1, index( 1 ) )*P( 2, index( 2 ) )*...*P( n, index( n ) ), -* -* where P( i, index( i ) ) is the permutation matrix that interchanges -* items i and index( i ). That is P( i, index( i ) ) is the unit matrix -* with rows and columns i and index( i ) interchanged. Of course, if -* index( i ) = i then P( i, index( i ) ) = I. -* -* This routine is intended for use in conjunction with Nag auxiliary -* routines that perform interchange operations, such as pivoting. -* -* Parameters -* ========== -* -* SIDE - CHARACTER*1. -* TRANS -* On entry, SIDE ( Left-hand side, or Right-hand side ) and -* TRANS ( Transpose, or No transpose ) specify the operation -* to be performed as follows. -* -* SIDE = 'L' or 'l' and TRANS = 'T' or 't' -* -* Perform the operation B := P'*B. -* -* SIDE = 'L' or 'l' and TRANS = 'N' or 'n' -* -* Perform the operation B := P*B. -* -* SIDE = 'R' or 'r' and TRANS = 'T' or 't' -* -* Perform the operation B := B*P'. -* -* SIDE = 'R' or 'r' and TRANS = 'N' or 'n' -* -* Perform the operation B := B*P. -* -* Unchanged on exit. -* -* M - INTEGER. -* -* On entry, M must specify the order of the permutation matrix -* P. M must be at least zero. When M = 0 then an immediate -* return is effected. -* -* Unchanged on exit. -* -* N - INTEGER. -* -* On entry, N must specify the value of n. N must be at least -* zero. When N = 0 then an immediate return is effected. -* -* Unchanged on exit. -* -* PERM - INTEGER array of DIMENSION at least ( n ). -* -* Before entry, PERM must contain the n indices for the -* permutation matrices. index( i ) must satisfy -* -* 1 .le. index( i ) .le. m. -* -* It is usual for index( i ) to be at least i, but this is not -* necessary for this routine. -* -* Unchanged on exit. -* -* K - INTEGER. -* -* On entry with SIDE = 'L' or 'l', K must specify the number -* of columns of B and on entry with SIDE = 'R' or 'r', K must -* specify the number of rows of B. K must be at least zero. -* When K = 0 then an immediate return is effected. -* -* Unchanged on exit. -* -* B - DOUBLE PRECISION array of DIMENSION ( LDB, ncolb ), where -* ncolb = k when SIDE = 'L' or 'l' and ncolb = m when -* SIDE = 'R' or 'r'. -* -* Before entry with SIDE = 'L' or 'l', the leading M by K -* part of the array B must contain the matrix to be -* transformed and before entry with SIDE = 'R' or 'r', the -* leading K by M part of the array B must contain the matrix -* to be transformed. On exit, B is overwritten by the -* transformed matrix. -* -* LDB - INTEGER. -* -* On entry, LDB must specify the leading dimension of the -* array B as declared in the calling (sub) program. When -* SIDE = 'L' or 'l' then LDB must be at least m, when -* SIDE = 'R' or 'r' then LDB must be at least k. -* Unchanged on exit. -* -* -* Nag Fortran 77 O( n**2 ) basic linear algebra routine. -* -* -- Written on 13-January-1986. -* Sven Hammarling, Nag Central Office. -* -* -* .. Local Scalars .. - DOUBLE PRECISION TEMP - INTEGER I, J, L - LOGICAL LEFT, NULL, RIGHT, TRNSP -* .. Intrinsic Functions .. - INTRINSIC MIN -* .. -* .. Executable Statements .. - IF( MIN( M, N, K ).EQ.0 ) - $ RETURN - LEFT = ( SIDE .EQ.'L' ).OR.( SIDE .EQ.'l' ) - RIGHT = ( SIDE .EQ.'R' ).OR.( SIDE .EQ.'r' ) - NULL = ( TRANS.EQ.'N' ).OR.( TRANS.EQ.'n' ) - TRNSP = ( TRANS.EQ.'T' ).OR.( TRANS.EQ.'t' ) - IF( LEFT )THEN - IF( TRNSP )THEN - DO 20, I = 1, N - IF( PERM( I ).NE.I )THEN - L = PERM( I ) - DO 10, J = 1, K - TEMP = B( I, J ) - B( I, J ) = B( L, J ) - B( L, J ) = TEMP - 10 CONTINUE - END IF - 20 CONTINUE - ELSE IF( NULL )THEN - DO 40, I = N, 1, -1 - IF( PERM( I ).NE.I )THEN - L = PERM( I ) - DO 30, J = 1, K - TEMP = B( L, J ) - B( L, J ) = B( I, J ) - B( I, J ) = TEMP - 30 CONTINUE - END IF - 40 CONTINUE - END IF - ELSE IF( RIGHT )THEN - IF( TRNSP )THEN - DO 60, J = 1, N - IF( PERM( J ).NE.J )THEN - L = PERM( J ) - DO 50, I = 1, K - TEMP = B( I, J ) - B( I, J ) = B( L, J ) - B( L, J ) = TEMP - 50 CONTINUE - END IF - 60 CONTINUE - ELSE IF( NULL )THEN - DO 80, J = N, 1, -1 - IF( PERM( J ).NE.J )THEN - L = PERM( J ) - DO 70, I = 1, K - TEMP = B( L, J ) - B( L, J ) = B( I, J ) - B( I, J ) = TEMP - 70 CONTINUE - END IF - 80 CONTINUE - END IF - END IF -* - RETURN -* -* End of DGEAP . ( F06QJF ) -* - END
deleted file mode 100644 --- a/libcruft/npsol/dgeapq.f +++ /dev/null @@ -1,262 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DGEAPQ( TRANS, WHEREZ, M, N, A, LDA, ZETA, - $ NCOLB, B, LDB, WORK, INFORM ) - CHARACTER*1 TRANS, WHEREZ - INTEGER M, N, LDA, NCOLB, LDB, INFORM - DOUBLE PRECISION A( LDA, * ), ZETA( * ), B( LDB, * ), WORK( * ) -C -C 1. Purpose -C ======= -C -C DGEAPQ performs one of the transformations -C -C B := Q'*B or B := Q*B, -C -C where B is an m by ncolb matrix and Q is an m by m orthogonal matrix, -C given as the product of Householder transformation matrices, details -C of which are stored in the m by n ( m.ge.n ) array A and, if the -C parameter WHEREZ = 'S' or 's', in the array ZETA. -C -C This routine is intended for use following auxiliary linear algebra -C routines such as DGEQR , DGEHES and DSLTRI. ( See those routines for -C example calls. ) -C -C 2. Description -C =========== -C -C Q is assumed to be given by -C -C Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )', -C -C Q( k ) being given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )', u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C -C z( k ) must be supplied in the kth column of A in elements -C a( k + 1, k ), ..., a( m, k ) and zeta( k ) must be supplied either -C in a( k, k ) or in zeta( k ), depending upon the parameter WHEREZ. -C -C To obtain Q explicitly B may be set to I and premultiplied by Q. This -C is more efficient than obtaining Q'. -C -C 3. Parameters -C ========== -C -C TRANS - CHARACTER*1. -C -C On entry, TRANS specifies the operation to be performed as -C follows. -C -C TRANS = ' ' or 'N' or 'n' -C -C Perform the operation B := Q*B. -C -C TRANS = 'T' or 't' or 'C' or 'c' -C -C Perform the operation B := Q'*B. -C -C Unchanged on exit. -C -C WHEREZ - CHARACTER*1. -C -C On entry, WHEREZ specifies where the elements of zeta are to -C be found as follows. -C -C WHEREZ = 'I' or 'i' -C -C The elements of zeta are in A. -C -C WHEREZ = 'S' or 's' -C -C The elements of zeta are separate from A, in ZETA. -C -C Unchanged on exit. -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - 'real' array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N stricly lower triangular -C part of the array A must contain details of the matrix Q. -C In addition, when WHEREZ = 'I' or 'i' then the diagonal -C elements of A must contain the elements of zeta. -C -C Unchanged on exit. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - 'real' array of DIMENSION at least min( m - 1, n ). -C -C Before entry with WHEREZ = 'S' or 's', the array ZETA must -C contain the elements of the vector zeta. -C -C When WHEREZ = 'I' or 'i', the array ZETA is not referenced. -C -C Unchanged on exit. -C -C NCOLB - INTEGER. -C -C On entry, NCOLB must specify the number of columns of B. -C NCOLB must be at least zero. When NCOLB = 0 then an -C immediate return is effected. -C -C Unchanged on exit. -C -C B - 'real' array of DIMENSION ( LDB, ncolb ). -C -C Before entry, the leading M by NCOLB part of the array B -C must contain the matrix to be transformed. -C -C On exit, B is overwritten by the transformed matrix. -C -C LDB - INTEGER. -C -C On entry, LDB must specify the leading dimension of the -C array B as declared in the calling (sub) program. LDB must -C be at least m. -C -C Unchanged on exit. -C -C WORK - 'real' array of DIMENSION at least ( ncolb ). -C -C Used as internal workspace. -C -C INFORM - INTEGER. -C -C On successful exit INFORM will be zero, otherwise INFORM -C will be set to unity indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C INFORM = 1 -C -C One or more of the following conditions holds: -C -C TRANS .ne. ' ' or 'N' or 'n' or 'T' or 't' or 'C' or 'c' -C WHEREZ .ne. 'I' or 'i' or 'S' or 's' -C M .lt. N -C N .lt. 0 -C LDA .lt. M -C NCOLB .lt. 0 -C LDB .lt. M -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 15-November-1984. -C Sven Hammarling, Nag Central Office. -C - EXTERNAL DGEMV , DGER - INTRINSIC MIN - INTEGER J , K , KK , LB - DOUBLE PRECISION TEMP - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - -* Check the input parameters. - - IF( MIN( N, NCOLB ).EQ.0 )THEN - INFORM = 0 - RETURN - END IF - IF( ( ( TRANS .NE.' ' ).AND. - $ ( TRANS .NE.'N' ).AND.( TRANS .NE.'n' ).AND. - $ ( TRANS .NE.'T' ).AND.( TRANS .NE.'t' ).AND. - $ ( TRANS .NE.'C' ).AND.( TRANS .NE.'c' ) ).OR. - $ ( ( WHEREZ.NE.'I' ).AND.( WHEREZ.NE.'i' ).AND. - $ ( WHEREZ.NE.'S' ).AND.( WHEREZ.NE.'s' ) ).OR. - $ ( M.LT.N ).OR.( N.LT.0 ).OR.( LDA.LT.M ).OR. - $ ( NCOLB.LT.0 ).OR.( LDB.LT.M ) )THEN - INFORM = 1 - RETURN - END IF - -* Perform the transformation. - - LB = LDB - DO 20, KK = 1, MIN( M - 1, N ) - IF( ( TRANS.EQ.'T' ).OR.( TRANS.EQ.'t' ).OR. - $ ( TRANS.EQ.'C' ).OR.( TRANS.EQ.'c' ) )THEN - -* Q'*B = Q( p )*...*Q( 2 )*Q( 1 )*B, p = min( m - 1, n ). - - K = KK - ELSE - -* Q*B = Q( 1 )'*Q( 2 )'*...*Q( p )'*B, p = min( m - 1, n ). -* Note that Q( k )' = Q( k ). - - K = MIN( N, M - 1 ) + 1 - KK - END IF - IF( ( WHEREZ.EQ.'S' ).OR.( WHEREZ.EQ.'s' ) )THEN - TEMP = A( K, K ) - A( K, K ) = ZETA( K ) - END IF - -* If ZETA( k ) is zero then Q( k ) = I and we can skip the kth -* transformation. - - IF( A( K, K ).GT.ZERO )THEN - IF( NCOLB.EQ.1 ) - $ LB = M - K + 1 - -* Let C denote the bottom ( m - k + 1 ) by ncolb part of B. - -* First form work = C'*u. - - DO 10, J = 1, NCOLB - WORK( J ) = ZERO - 10 CONTINUE - CALL DGEMV ( 'Transpose', M - K + 1, NCOLB, - $ ONE, B( K, 1 ), LB, A( K, K ), 1, - $ ZERO, WORK, 1 ) - -* Now form C := C - u*work'. - - CALL DGER ( M - K + 1, NCOLB, -ONE, A( K, K ), 1, - $ WORK, 1, B( K, 1 ), LB ) - END IF - -* Restore the diagonal element of A. - - IF( ( WHEREZ.EQ.'S' ).OR.( WHEREZ.EQ.'s' ) ) - $ A( K, K ) = TEMP - 20 CONTINUE - - INFORM = 0 - RETURN - -* End of DGEAPQ. - - END
deleted file mode 100644 --- a/libcruft/npsol/dgeqr.f +++ /dev/null @@ -1,222 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DGEQR ( M, N, A, LDA, ZETA, INFORM ) - INTEGER M, N, LDA, INFORM - DOUBLE PRECISION A( LDA, * ), ZETA( * ) -C -C 1. Purpose -C ======= -C -C DGEQR reduces the m by n, m.ge.n, matrix A to upper triangular form -C by means of orthogonal transformations. -C -C 2. Description -C =========== -C -C The m by n matrix A is factorized as -C -C A = Q*( R ) when m.gt.n, -C ( 0 ) -C -C A = Q*R when m = n, -C -C where Q is an m by m orthogonal matrix and R is an n by n upper -C triangular matrix. -C -C The factorization is obtained by Householder's method. The kth -C transformation matrix, Q( k ), which is used to introduce zeros into -C the kth column of A is given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )', u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C zeta( k ) and z( k ) are chosen to annhilate the elements below the -C triangular part of A. -C -C The vector u( k ) is returned in the kth element of ZETA and in the -C kth column of A, such that zeta( k ) is in ZETA( k ) and the elements -C of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R are -C returned in the upper triangular part of A. -C -C Q is given by -C -C Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )', -C -C where p = min( n, m - 1 ). -C -C 3. Parameters -C ========== -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least n. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - 'real' array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N part of the array A must -C contain the matrix to be factorized. -C -C On exit, the N by N upper triangular part of A will contain -C the upper triangular matrix R and the M by N strictly -C lower triangular part of A will contain details of the -C factorization as described above. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - 'real' array of DIMENSION at least ( n ). -C -C On exit, ZETA( k ) contains the scalar zeta( k ) for the -C kth transformation. If T( k ) = I then ZETA( k ) = 0.0 -C otherwise ZETA( k ) contains zeta( k ) as described above -C and is always in the range ( 1.0, sqrt( 2.0 ) ). -C -C INFORM - INTEGER. -C -C On successful exit INFORM will be zero, otherwise INFORM -C will be set to unity indicating that an input parameter has -C been incorrectly set. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C INFORM = 1 -C -C One or more of the following conditions holds: -C -C M .lt. N -C N .lt. 0 -C LDA .lt. M -C -C 5. Further information -C =================== -C -C Following the use of this routine the operations -C -C B := Q'*B and B := Q*B, -C -C where B is an m by k matrix, can be performed by calls to the -C auxiliary linear algebra routine DGEAPQ. The operation B := Q'*B -C can be obtained by the call: -C -C INFORM = 0 -C CALL DGEAPQ( 'Transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, INFORM ) -C -C and B := Q*B can be obtained by the call: -C -C INFORM = 0 -C CALL DGEAPQ( 'No transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, INFORM ) -C -C In both cases WORK must be a k element array that is used as -C workspace. If B is a one-dimensional array (single column) then the -C parameter LDB can be replaced by M. See routine DGEAPQ for further -C details. -C -C Operations involving the matrix R are performed by the -C Level 2 BLAS routines DTRMV and DTRSV . Note that no test for near -C singularity of R is incorporated in this routine or in routine DTRSV -C and so it is strongly recommended that the auxiliary linear algebra -C routine DUTCO be called, prior to solving equations involving R, in -C order to determine whether or not R is nearly singular. If R is -C nearly singular then the auxiliary linear algebra routine DUTSV -C can be used to determine the singular value decomposition of R. -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 13-December-1984. -C Sven Hammarling, Nag Central Office. -C - EXTERNAL DGEMV , DGER , DGRFG - INTRINSIC MIN - INTEGER J , K , LA - DOUBLE PRECISION TEMP - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - -* Check the input parameters. - - IF( N.EQ.0 )THEN - INFORM = 0 - RETURN - END IF - IF( ( M.LT.N ).OR.( N.LT.0 ).OR.( LDA.LT.M ) )THEN - INFORM = 1 - RETURN - END IF - -* Perform the factorization. - - LA = LDA - DO 20, K = 1, MIN( M - 1, N ) - -* Use a Householder reflection to zero the kth column of A. -* First set up the reflection. - - CALL DGRFG ( M - K, A( K, K ), A( K + 1, K ), 1, ZERO, - $ ZETA( K ) ) - IF( ( ZETA( K ).GT.ZERO ).AND.( K.LT.N ) )THEN - IF( ( K + 1 ).EQ.N ) - $ LA = M - K + 1 - TEMP = A( K, K ) - A( K, K ) = ZETA( K ) - -* We now perform the operation A := Q( k )*A. - -* Let B denote the bottom ( m - k + 1 ) by ( n - k ) part -* of A. - -* First form work = B'*u. ( work is stored in the elements -* ZETA( k + 1 ), ..., ZETA( n ). ) - - CALL DGEMV ( 'Transpose', M - K + 1, N - K, - $ ONE, A( K, K + 1 ), LA, A( K, K ), 1, - $ ZERO, ZETA( K + 1 ), 1 ) - -* Now form B := B - u*work'. - - CALL DGER ( M - K + 1, N - K, -ONE, A( K, K ), 1, - $ ZETA( K + 1 ), 1, A( K, K + 1 ), LA ) - -* Restore beta. - - A( K, K ) = TEMP - END IF - 20 CONTINUE - -* Store the final zeta when m.eq.n. - - IF( M.EQ.N ) - $ ZETA( N ) = ZERO - - INFORM = 0 - RETURN - -* End of DGEQR . - - END
deleted file mode 100644 --- a/libcruft/npsol/dgeqrp.f +++ /dev/null @@ -1,394 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DGEQRP( PIVOT, M, N, A, LDA, ZETA, PERM, WORK, INFORM ) - CHARACTER*1 PIVOT - INTEGER M, N, LDA, INFORM - INTEGER PERM( * ) - DOUBLE PRECISION A( LDA, * ), ZETA( * ), WORK( * ) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - -C 1. Purpose -C ======= -C -C DGEQRP reduces the m by n matrix A to upper triangular form by means -C of orthogonal transformations and column permutations. -C -C 2. Description -C =========== -C -C The m by n matrix A is factorized as -C -C A = Q*( R )*P' when m.gt.n, -C ( 0 ) -C -C A = Q*R*P' when m = n, -C -C A = Q*( R X )*P' when m.lt.n, -C -C where Q is an m by m orthogonal matrix, R is a min( m, n ) by -C min( m, n ) upper triangular matrix and P is an n by n permutation -C matrix. -C -C The factorization is obtained by Householder's method. The kth -C transformation matrix, Q( k ), which is used to introduce zeros into -C the kth column of A is given in the form -C -C Q( k ) = ( I 0 ), -C ( 0 T( k ) ) -C -C where -C -C T( k ) = I - u( k )*u( k )', u( k ) = ( zeta( k ) ), -C ( z( k ) ) -C -C zeta( k ) is a scalar and z( k ) is an ( m - k ) element vector. -C zeta( k ) and z( k ) are chosen to annhilate the elements below the -C triangular part of A. -C -C The vector u( k ) is returned in the kth element of ZETA and in the -C kth column of A, such that zeta( k ) is in ZETA( k ) and the elements -C of z( k ) are in a( k + 1, k ), ..., a( m, k ). The elements of R are -C returned in the upper triangular part of A. -C -C Q is given by -C -C Q = ( Q( p )*Q( p - 1 )*...*Q( 1 ) )', -C -C where p = min( m - 1, n ). -C -C Two options are available for the column permutations. In either case -C the column for which the sub-diagonal elements are to be annihilated -C at the kth step is chosen from the remaining ( n - k + 1 ) columns. -C The particular column chosen as the pivot column is either that for -C which the unreduced part ( elements k onwards ) has the largest -C Euclidean length, or is that for which the ratio of the Euclidean -C length of the unreduced part to the Euclidean length of the whole -C column is a maximum. -C -C 3. Parameters -C ========== -C -C PIVOT - CHARACTER*1. -C -C On entry, PIVOT specifies the pivoting strategy to be -C performed as follows. -C -C PIVOT = 'C' or 'c' -C -C Column interchanges are to be incorporated into the -C factorization, such that the column whose unreduced part -C has maximum Euclidean length is chosen as the pivot -C column at each step. -C -C PIVOT = 'S' or 's' -C -C Scaled column interchanges are to be incorporated into -C the factorization, such that the column for which the -C ratio of the Euclidean length of the unreduced part of -C the column to the original Euclidean length of the column -C is a maximum is chosen as the pivot column at each step. -C -C Unchanged on exit. -C -C M - INTEGER. -C -C On entry, M must specify the number of rows of A. M must be -C at least zero. When M = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C N - INTEGER. -C -C On entry, N must specify the number of columns of A. N must -C be at least zero. When N = 0 then an immediate return is -C effected. -C -C Unchanged on exit. -C -C A - 'real' array of DIMENSION ( LDA, n ). -C -C Before entry, the leading M by N part of the array A must -C contain the matrix to be factorized. -C -C On exit, the min( M, N ) by min( M, N ) upper triangular -C part of A will contain the upper triangular matrix R and the -C M by min( M, N ) strictly lower triangular part of A will -C contain details of the factorization as described above. -C When m.lt.n then the remaining M by ( N - M ) part of A will -C contain the matrix X. -C -C LDA - INTEGER. -C -C On entry, LDA must specify the leading dimension of the -C array A as declared in the calling (sub) program. LDA must -C be at least m. -C -C Unchanged on exit. -C -C ZETA - 'real' array of DIMENSION at least ( n ). -C -C On exit, ZETA( k ) contains the scalar zeta for the kth -C transformation. If T( k ) = I then ZETA( k) = 0.0, otherwise -C ZETA( k ) contains the scalar zeta( k ) as described above -C and is always in the range ( 1.0, sqrt( 2.0 ) ). When -C n .gt. m the elements ZETA( m + 1 ), ZETA( m + 2 ), ..., -C ZETA( n ) are used as internal workspace. -C -C PERM - INTEGER array of DIMENSION at least min( m, n ). -C -C On exit, PERM contains details of the permutation matrix P, -C such that PERM( k ) = k if no column interchange occured -C at the kth step and PERM( k ) = j, ( k .lt. j .le. n ), -C if columns k and j were interchanged at the kth step. -C Note that, although there are min( m - 1, n ) orthogonal -C transformations, there are min( m, n ) permutations. -C -C WORK - 'real' array of DIMENSION at least ( 2*n ). -C -C Used as internal workspace. -C -C On exit, WORK( j ), j = 1, 2, ..., n, contains the Euclidean -C length of the jth column of the permuted matrix A*P'. -C -C INFORM - INTEGER. -C -C On successful exit, INFORM will be zero, otherwise INFORM -C will be set to unity indicating that an input parameter has -C been incorrectly supplied. See the next section for further -C details. -C -C 4. Diagnostic Information -C ====================== -C -C INFORM = 1 -C -C One or more of the following conditions holds: -C -C PIVOT .ne. 'C' or 'c' or 'S' or 's' -C M .lt. 0 -C N .lt. 0 -C LDA .lt. M -C -C 5. Further information -C =================== -C -C Following the use of this routine the operations -C -C B := Q'*B and B := Q*B, -C -C where B is an m by k matrix, can be performed by calls to the -C auxiliary linear algebra routine DGEAPQ. The operation B := Q'*B -C can be obtained by the call: -C -C INFORM = 0 -C CALL DGEAPQ( 'Transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, INFORM ) -C -C and B := Q*B can be obtained by the call: -C -C INFORM = 0 -C CALL DGEAPQ( 'No transpose', 'Separate', M, N, A, LDA, ZETA, -C $ K, B, LDB, WORK, INFORM ) -C -C In both cases WORK must be a k element array that is used as -C workspace. If B is a one-dimensional array ( single column ) then the -C parameter LDB can be replaced by M. See routine DGEAPQ for further -C details. -C -C Also following the use of this routine the operations -C -C B := P'*B and B := P*B, -C -C where B is an n by k matrix, and the operations -C -C B := B*P and B := B*P', -C -C where B is a k by n matrix, can be performed by calls to the basic -C linear algebra routine DGEAP . The operation B := P'*B can be -C obtained by the call: -C -C CALL DGEAP ( 'Left', 'Transpose', N, MIN( M, N ), PERM, -C $ K, B, LDB ) -C -C the operation B := P*B can be obtained by the call: -C -C CALL DGEAP ( 'Left', 'No transpose', N, MIN( M, N ), PERM, -C $ K, B, LDB ) -C -C If B is a one-dimensional array ( single column ) then the parameter -C LDB can be replaced by N in the above two calls. -C The operation B := B*P can be obtained by the call: -C -C CALL DGEAP ( 'Right', 'No transpose', K, MIN( M, N ), PERM, -C $ M, B, LDB ) -C -C and B := B*P' can be obtained by the call: -C -C CALL DGEAP ( 'Right', 'Transpose', K, MIN( M, N ), PERM, -C $ M, B, LDB ) -C -C If B is a one-dimensional array ( single column ) then the parameter -C LDB can be replaced by K in the above two calls. -C See routine DGEAP for further details. -C -C Operations involving the matrix R are performed by the -C Level 2 BLAS routines DTRSV and DTRMV. Note that no test for near -C singularity of R is incorporated in this routine or in routine DTRSV -C and so it is strongly recommended that the auxiliary linear algebra -C routine DUTCO be called, prior to solving equations involving R, in -C order to determine whether or not R is nearly singular. If R is -C nearly singular then the auxiliary linear algebra routine DUTSV -C can be used to determine the singular value decomposition of R. -C Operations involving the matrix X can also be performed by the -C Level 2 BLAS routines. Matrices of the form ( R X ) can be -C factorized as -C -C ( R X ) = ( T 0 )*S', -C -C where T is upper triangular and S is orthogonal, using the auxiliary -C linear algebra routine DUTRQ . -C -C -C Nag Fortran 77 Auxiliary linear algebra routine. -C -C -- Written on 13-December-1984. -C Sven Hammarling, Nag Central Office. -C - EXTERNAL MCHPAR, DGEMV , DGER , DGRFG , DNRM2 , DSWAP - INTRINSIC ABS , MAX , MIN , SQRT - INTEGER J , JMAX , K , LA - DOUBLE PRECISION EPS , MAXNRM, NORM , DNRM2 , TEMP , TOL - DOUBLE PRECISION LAMDA - PARAMETER ( LAMDA = 1.0D-2 ) - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - -* Check the input parameters. - - IF( MIN( M, N ).EQ.0 )THEN - INFORM = 0 - RETURN - END IF - IF( ( ( PIVOT.NE.'C' ).AND.( PIVOT.NE.'c' ).AND. - $ ( PIVOT.NE.'S' ).AND.( PIVOT.NE.'s' ) ).OR. - $ ( M.LT.0 ).OR.( N.LT.0 ).OR.( LDA.LT.M ) )THEN - INFORM = 1 - RETURN - END IF - -* Compute eps and the initial column norms. - - CALL MCHPAR() - EPS = WMACH( 3 ) - DO 10, J = 1, N - WORK( J ) = DNRM2 ( M, A( 1, J ), 1 ) - WORK( J + N ) = WORK( J ) - 10 CONTINUE - -* Perform the factorization. TOL is the tolerance for DGRFG . - - LA = LDA - DO 50, K = 1, MIN( M, N ) - -* Find the pivot column. - - MAXNRM = ZERO - JMAX = K - DO 20, J = K, N - IF( ( PIVOT.EQ.'C' ).OR.( PIVOT.EQ.'c' ) )THEN - IF( WORK( J + N ).GT.MAXNRM )THEN - MAXNRM = WORK( J + N ) - JMAX = J - END IF - ELSE IF( WORK( J ).GT.ZERO )THEN - IF( ( WORK( J + N )/WORK( J ) ).GT.MAXNRM )THEN - MAXNRM = WORK( J + N )/WORK( J ) - JMAX = J - END IF - END IF - 20 CONTINUE - PERM( K ) = JMAX - IF( JMAX.GT.K )THEN - CALL DSWAP ( M, A( 1, K ), 1, A( 1, JMAX ), 1 ) - TEMP = WORK( K ) - WORK( K ) = WORK( JMAX ) - WORK( JMAX ) = TEMP - WORK( JMAX + N ) = WORK( K + N ) - PERM( K ) = JMAX - END IF - TOL = EPS*WORK( K ) - IF( K.LT.M )THEN - -* Use a Householder reflection to zero the kth column of A. -* First set up the reflection. - - CALL DGRFG ( M - K, A( K, K ), A( K + 1, K ), 1, TOL, - $ ZETA( K ) ) - IF( K.LT.N )THEN - IF( ZETA( K ).GT.ZERO )THEN - IF( ( K + 1 ).EQ.N ) - $ LA = M - K + 1 - TEMP = A( K, K ) - A( K, K ) = ZETA( K ) - -* We now perform the operation A := Q( k )*A. - -* Let B denote the bottom ( m - k + 1 ) by ( n - k ) -* part of A. - -* First form work = B'*u. ( work is stored in the -* elements ZETA( k + 1 ), ..., ZETA( n ). ) - - CALL DGEMV ( 'Transpose', M - K + 1, N - K, - $ ONE, A( K, K + 1 ), LA, A( K, K ), 1, - $ ZERO, ZETA( K + 1 ), 1 ) - -* Now form B := B - u*work'. - - CALL DGER ( M - K + 1, N - K, -ONE, A( K, K ), 1, - $ ZETA( K + 1 ), 1, A( K, K + 1 ), LA ) - -* Restore beta. - - A( K, K ) = TEMP - END IF - -* Update the unreduced column norms. Use the Linpack -* criterion for when to recompute the norms, except that -* we retain the original column lengths throughout and use -* a smaller lamda. - - DO 40, J = K + 1, N - IF( WORK( J + N ).GT.ZERO )THEN - TEMP = ABS( A( K, J ) )/WORK( J + N ) - TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO ) - NORM = TEMP - TEMP = ONE + - $ LAMDA*TEMP*( WORK( J + N )/WORK( J ) )**2 - IF( TEMP.GT.ONE )THEN - WORK( J + N ) = WORK( J + N )*SQRT( NORM ) - ELSE - WORK( J + N ) = DNRM2 ( M - K, - $ A( K + 1, J ), 1 ) - END IF - END IF - 40 CONTINUE - END IF - END IF - 50 CONTINUE - -* Store the final zeta when m.le.n. - - IF( M.LE.N ) - $ ZETA( M ) = ZERO - - INFORM = 0 - RETURN - -* End of DGEQRP. - - END
deleted file mode 100644 --- a/libcruft/npsol/dgrfg.f +++ /dev/null @@ -1,131 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DGRFG ( N, ALPHA, X, INCX, TOL, ZETA ) - INTEGER N, INCX - DOUBLE PRECISION ALPHA, X( * ), TOL, ZETA -C -C DGRFG generates details of a generalized Householder reflection such -C that -C -C P*( alpha ) = ( beta ), P'*P = I. -C ( x ) ( 0 ) -C -C P is given in the form -C -C P = I - ( zeta )*( zeta z' ), -C ( z ) -C -C where z is an n element vector and zeta is a scalar that satisfies -C -C 1.0 .le. zeta .le. sqrt( 2.0 ). -C -C zeta is returned in ZETA unless x is such that -C -C max( abs( x( i ) ) ) .le. max( eps*abs( alpha ), tol ) -C -C where eps is the relative machine precision and tol is the user -C supplied value TOL, in which case ZETA is returned as 0.0 and P can -C be taken to be the unit matrix. -C -C beta is overwritten on alpha and z is overwritten on x. -C the routine may be called with n = 0 and advantage is taken of the -C case where n = 1. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 30-August-1984. -C Sven Hammarling, Nag Central Office. -C This version dated 28-September-1984. -C - EXTERNAL DSSQ , DSCAL - INTRINSIC ABS , MAX , SIGN , SQRT - LOGICAL FIRST - DOUBLE PRECISION BETA , EPS , SCALE , SSQ - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - IF( N.LT.1 )THEN - ZETA = ZERO - ELSE IF( ( N.EQ.1 ).AND.( X( 1 ).EQ.ZERO ) )THEN - ZETA = ZERO - ELSE - - EPS = WMACH( 3 ) - -* Treat case where P is a 2 by 2 matrix specially. - - IF( N.EQ.1 )THEN - -* Deal with cases where ALPHA = zero and -* abs( X( 1 ) ) .le. max( EPS*abs( ALPHA ), TOL ) first. - - IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = ABS( X( 1 ) ) - X( 1 ) = -SIGN( ONE, X( 1 ) ) - ELSE IF( ABS( X( 1 ) ).LE.MAX( EPS*ABS( ALPHA ), - $ TOL ) )THEN - ZETA = ZERO - ELSE - IF( ABS( ALPHA ).GE.ABS( X( 1 ) ) )THEN - BETA = ABS ( ALPHA )* - $ SQRT( ONE + ( X( 1 )/ALPHA )**2 ) - ELSE - BETA = ABS ( X( 1 ) )* - $ SQRT( ONE + ( ALPHA/X( 1 ) )**2 ) - END IF - ZETA = SQRT( ( ABS( ALPHA ) + BETA )/BETA ) - IF( ALPHA.GE.ZERO )BETA = -BETA - X( 1 ) = -X( 1 )/( ZETA*BETA ) - ALPHA = BETA - END IF - ELSE - -* Now P is larger than 2 by 2. - - SSQ = ONE - SCALE = ZERO - - CALL DSSQ ( N, X, INCX, SCALE, SSQ ) - -* Treat cases where SCALE = zero, -* SCALE .le. max( EPS*abs( ALPHA ), TOL ) and -* ALPHA = zero specially. -* Note that SCALE = max( abs( X( i ) ) ). - - IF( ( SCALE.EQ.ZERO ).OR. - $ ( SCALE.LE.MAX( EPS*ABS( ALPHA ), TOL ) ) )THEN - ZETA = ZERO - ELSE IF( ALPHA.EQ.ZERO )THEN - ZETA = ONE - ALPHA = SCALE*SQRT( SSQ ) - - CALL DSCAL ( N, -ONE/ALPHA, X, INCX ) - - ELSE - IF( SCALE.LT.ABS( ALPHA ) )THEN - BETA = ABS ( ALPHA )* - $ SQRT( ONE + SSQ*( SCALE/ALPHA )**2 ) - ELSE - BETA = SCALE* - $ SQRT( SSQ + ( ALPHA/SCALE )**2 ) - END IF - ZETA = SQRT( ( BETA + ABS( ALPHA ) )/BETA ) - IF( ALPHA.GT.ZERO )BETA = -BETA - - CALL DSCAL( N, -ONE/( ZETA*BETA ), X, INCX ) - - ALPHA = BETA - END IF - END IF - END IF - RETURN - -* End of DGRFG . - - END
deleted file mode 100644 --- a/libcruft/npsol/dload.f +++ /dev/null @@ -1,38 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DLOAD ( N, CONST, X, INCX ) - INTEGER N, INCX - DOUBLE PRECISION CONST - DOUBLE PRECISION X( * ) -C -C DLOAD performs the operation -C -C x = const*e, e' = ( 1 1 ... 1 ). -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-September-1983. -C Sven Hammarling, Nag Central Office. -C - INTEGER IX - DOUBLE PRECISION ZERO - PARAMETER ( ZERO = 0.0D+0 ) - - IF( N.LT.1 )RETURN - - IF( CONST.NE.ZERO )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = CONST - 10 CONTINUE - ELSE - DO 20, IX = 1, 1 + ( N - 1 )*INCX, INCX - X( IX ) = ZERO - 20 CONTINUE - END IF - - RETURN - -* End of DLOAD . - - END
deleted file mode 100644 --- a/libcruft/npsol/dnorm.f +++ /dev/null @@ -1,49 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DOUBLE PRECISION FUNCTION DNORM ( SCALE, SSQ ) - DOUBLE PRECISION SCALE, SSQ -C -C DNORM returns the value norm given by -C -C norm = ( scale*sqrt( ssq ), scale*sqrt( ssq ) .lt. flmax -C ( -C ( flmax, scale*sqrt( ssq ) .ge. flmax -C -C via the function name. -C -C -C Nag Fortran 77 O( 1 ) basic linear algebra routine. -C -C -- Written on 22-October-1982. -C Sven Hammarling, Nag Central Office. -C - INTRINSIC SQRT - LOGICAL FIRST - DOUBLE PRECISION FLMAX , SQT - DOUBLE PRECISION ONE - PARAMETER ( ONE = 1.0D+0 ) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - SAVE FIRST , FLMAX - DATA FIRST / .TRUE. / - - IF( FIRST )THEN - FIRST = .FALSE. - FLMAX = WMACH( 7 ) - END IF - - SQT = SQRT( SSQ ) - IF( SCALE.LT.FLMAX/SQT )THEN - DNORM = SCALE*SQT - ELSE - DNORM = FLMAX - END IF - - RETURN - -* End of DNORM . - - END
deleted file mode 100644 --- a/libcruft/npsol/drot3.f +++ /dev/null @@ -1,80 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DROT3 ( N, X, INCX, Y, INCY, CS, SN ) - - INTEGER N, INCX, INCY - DOUBLE PRECISION CS, SN - DOUBLE PRECISION X(*), Y(*) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - -C -C DROT3 applies the plane rotation defined by CS and SN to the -C columns of a 2 by N matrix held in X and Y. The method used requires -C 3 multiplications and 3 additions per column, as described in Gill, -C Golub, Murray and Saunders, Mathematics of Computation 28 (1974) 505- -C -535 (see page 508). -C -C DROT3 guards against underflow, and overflow is extremely unlikely. -C It is assumed that CS and SN have been generated by DROT3G, ensuring -C that CS lies in the closed interval (0, 1), and that the absolute -C value of CS and SN (if nonzero) is no less than the machine precision -C EPS. It is also assumed that RTMIN .lt. EPS. Note that the magic -C number Z is therefore no less than 0.5*EPS in absolute value, so it -C is safe to use TOL = 2*RTMIN in the underflow test involving Z*A. -C For efficiency we use the same TOL in the previous two tests. -C -C Systems Optimization Laboratory, Stanford University. -C Original version dated January 1982. -C F77 version dated 28-June-1986. -C This version of DROT3 dated 28-June-1986. -C - INTEGER I, IX, IY - DOUBLE PRECISION A, B, ONE, RTMIN, TOL, W, Z, ZERO - INTRINSIC ABS - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - IF (N .LT. 1 .OR. SN .EQ. ZERO) RETURN - IX = 1 - IY = 1 - IF (CS .EQ. ZERO) THEN - -* Just swap x and y. - - DO 10 I = 1, N - A = X(IX) - X(IX) = Y(IY) - Y(IY) = A - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - - ELSE - - RTMIN = WMACH(6) - TOL = RTMIN + RTMIN - Z = SN/(ONE + CS) - - DO 20 I = 1, N - A = X(IX) - B = Y(IY) - W = ZERO - IF (ABS(A) .GT. TOL) W = CS*A - IF (ABS(B) .GT. TOL) W = W + SN*B - X(IX) = W - A = A + W - IF (ABS(A) .GT. TOL) B = B - Z*A - Y(IY) = - B - IX = IX + INCX - IY = IY + INCY - 20 CONTINUE - - END IF - - RETURN - -* End of DROT3 - - END
deleted file mode 100644 --- a/libcruft/npsol/drot3g.f +++ /dev/null @@ -1,100 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DROT3G( X, Y, CS, SN ) - - DOUBLE PRECISION X, Y, CS, SN - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - -C -C DROT3G generates a plane rotation that reduces the vector (X, Y) to -C the vector (A, 0), where A is defined as follows... -C -C If both X and Y are negligibly small, or -C if Y is negligible relative to Y, -C then A = X, and the identity rotation is returned. -C -C If X is negligible relative to Y, -C then A = Y, and the swap rotation is returned. -C -C Otherwise, A = sign(X) * sqrt( X**2 + Y**2 ). -C -C In all cases, X and Y are overwritten by A and 0, and CS will lie -C in the closed interval (0, 1). Also, the absolute value of CS and -C SN (if nonzero) will be no less than the machine precision, EPS. -C -C DROT3G guards against overflow and underflow. -C It is assumed that FLMIN .lt. EPS**2 (i.e. RTMIN .lt. EPS). -C -C Systems Optimization Laboratory, Stanford University. -C Original version dated January 1982. -C F77 version dated 28-June-1986. -C This version of DROT3G dated 28-June-1986. -C - DOUBLE PRECISION A, B, EPS, ONE, RTMIN, ZERO - LOGICAL FIRST - INTRINSIC ABS, MAX, SQRT - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - SAVE FIRST , EPS , RTMIN - DATA FIRST / .TRUE. / - - IF( FIRST )THEN - FIRST = .FALSE. - EPS = WMACH(3) - RTMIN = WMACH(6) - END IF - - IF (Y .EQ. ZERO) THEN - - CS = ONE - SN = ZERO - - ELSE IF (X .EQ. ZERO) THEN - - CS = ZERO - SN = ONE - X = Y - - ELSE - - A = ABS(X) - B = ABS(Y) - IF (MAX(A,B) .LE. RTMIN) THEN - CS = ONE - SN = ZERO - ELSE - IF (A .GE. B) THEN - IF (B .LE. EPS*A) THEN - CS = ONE - SN = ZERO - GO TO 900 - ELSE - A = A * SQRT( ONE + (B/A)**2 ) - END IF - ELSE - IF (A .LE. EPS*B) THEN - CS = ZERO - SN = ONE - X = Y - GO TO 900 - ELSE - A = B * SQRT( ONE + (A/B)**2 ) - END IF - END IF - IF (X .LT. ZERO) A = - A - CS = X/A - SN = Y/A - X = A - END IF - END IF - - 900 Y = ZERO - - RETURN - -* End of DROT3G - - END
deleted file mode 100644 --- a/libcruft/npsol/dssq.f +++ /dev/null @@ -1,55 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE DSSQ ( N, X, INCX, SCALE, SUMSQ ) - INTEGER N, INCX - DOUBLE PRECISION X( * ) - DOUBLE PRECISION SCALE, SUMSQ -C -C DSSQ returns the values scl and smsq such that -C -C ( scl**2 )*smsq = y( 1 )**2 +...+ y( n )**2 + ( scale**2 )*sumsq, -C -C where y( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is assumed -C to be at least unity and the value of smsq will then satisfy -C -C 1.0 .le. smsq .le. ( sumsq + n ) . -C -C scale is assumed to be non-negative and scl returns the value -C -C scl = max( scale, abs( x( i ) ) ) . -C -C scale and sumsq must be supplied in SCALE and SUMSQ respectively. -C scl and smsq are overwritten on SCALE and SUMSQ respectively. -C -C The routine makes only one pass through the vector X. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-October-1982. -C Sven Hammarling, Nag Central Office. -C - INTRINSIC ABS - INTEGER IX - DOUBLE PRECISION ABSXI - DOUBLE PRECISION ONE , ZERO - PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) - - IF( N.GE.1 )THEN - DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX - IF( X( IX ).NE.ZERO )THEN - ABSXI = ABS( X( IX ) ) - IF( SCALE.LT.ABSXI )THEN - SUMSQ = ONE + SUMSQ*( SCALE/ABSXI )**2 - SCALE = ABSXI - ELSE - SUMSQ = SUMSQ + ( ABSXI/SCALE )**2 - END IF - END IF - 10 CONTINUE - END IF - RETURN - -* End of DSSQ . - - END
deleted file mode 100644 --- a/libcruft/npsol/icopy.f +++ /dev/null @@ -1,38 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE ICOPY ( N, IX, INCIX, IY, INCIY ) - - INTEGER N, INCIX, INCIY - INTEGER IX(*), IY(*) - -C -C Copy the first N elements of IX into IY. -C - - INTEGER J, JX, JY - - IF (N .GE. 1) THEN - IF (INCIX .EQ. 1 .AND. INCIY .EQ. 1) THEN - - DO 10 J = 1, N - IY(J) = IX(J) - 10 CONTINUE - - ELSE - - JX = 1 - JY = 1 - DO 20 J = 1, N - IY(JY) = IX(JX) - JX = JX + INCIX - JY = JY + INCIY - 20 CONTINUE - - END IF - END IF - - RETURN - -* End of ICOPY - - END
deleted file mode 100644 --- a/libcruft/npsol/idrank.f +++ /dev/null @@ -1,62 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - INTEGER FUNCTION IDRANK( N, X, INCX, TOL ) - INTEGER N, INCX - DOUBLE PRECISION X( * ), TOL - -C IDRANK finds the first element of the n element vector x for which -C -C abs( x( k ) ).le.( tol*max ( abs(x(1)), ..., abs(x(k-1)) ) -C -C and returns the value ( k - 1 ) in the function name IDRANK. If no -C such k exists then IDRANK is returned as n. -C -C If TOL is supplied as less than zero then the value EPSMCH, where -C EPSMCH is the relative machine precision, is used in place of TOL. -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 21-January-1985. -C Sven Hammarling, Nag Central Office. -C Modified by PEG, 19-December-1985. - - INTRINSIC ABS , MAX - INTEGER IX , K - DOUBLE PRECISION TOLRNK, XMAX , ZERO - PARAMETER ( ZERO = 0.0D+0 ) - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - K = 0 - IF (N .GE. 1) THEN - TOLRNK = TOL - IF (TOL .LT. ZERO) TOLRNK = WMACH(3) - - IF( INCX .GT. 0 )THEN - IX = 1 - ELSE - IX = 1 - ( N - 1 )*INCX - END IF - - XMAX = ABS( X(IX) ) - -*+ WHILE (K .LT. N) LOOP - 10 IF (K .LT. N) THEN - IF (ABS( X(IX) ) .LE. XMAX*TOLRNK) GO TO 20 - XMAX = MAX( XMAX, ABS( X(IX) ) ) - K = K + 1 - IX = IX + INCX - GO TO 10 - END IF -*+ END WHILE - - END IF - 20 IDRANK = K - RETURN - -* End of IDRANK. - - END
deleted file mode 100644 --- a/libcruft/npsol/iload.f +++ /dev/null @@ -1,36 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE ILOAD ( N, ICONST, IX, INCIX ) - INTEGER N, INCIX - INTEGER ICONST - INTEGER IX( * ) -C -C ILOAD performs the operation -C -C ix = iconst*e, e' = ( 1 1 ... 1 ). -C -C -C Nag Fortran 77 O( n ) basic linear algebra routine. -C -C -- Written on 22-September-1983. -C Sven Hammarling, Nag Central Office. -C - INTEGER JX - - IF( N.LT.1 )RETURN - - IF( ICONST.NE.0 )THEN - DO 10, JX = 1, 1 + ( N - 1 )*INCIX, INCIX - IX( JX ) = ICONST - 10 CONTINUE - ELSE - DO 20, JX = 1, 1 + ( N - 1 )*INCIX, INCIX - IX( JX ) = 0 - 20 CONTINUE - END IF - - RETURN - -* End of ILOAD . - - END
deleted file mode 100644 --- a/libcruft/npsol/lsadd.f +++ /dev/null @@ -1,301 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File LSSUBS FORTRAN -* -* LSADD LSADDS LSBNDS LSCHOL LSCORE LSCRSH LSDEL -* LSDFLT LSFEAS LSFILE LSGETP LSGSET LSKEY LSLOC -* LSMOVE LSMULS LSOPTN LSPRT LSSETX LSSOL -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSADD ( UNITQ, - $ INFORM, IFIX, IADD, JADD, - $ NACTIV, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NROWA, NQ, NROWR, NROWT, - $ KX, CONDMX, - $ A, R, T, RES, GQ, ZY, WRK1, WRK2 ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER KX(N) - DOUBLE PRECISION A(NROWA,*), R(NROWR,*), T(NROWT,*), - $ RES(N,*), GQ(N,*), ZY(NQ,*) - DOUBLE PRECISION WRK1(N), WRK2(N) -************************************************************************ -* LSADD updates the factorization, A(free) * (Z Y) = (0 T), when a -* constraint is added to the working set. If NRANK .gt. 0, the -* factorization ( R ) = PWQ is also updated, where W is the -* ( 0 ) -* least squares matrix, R is upper-triangular, and P is an -* orthogonal matrix. The matrices W and P are not stored. -* -* There are three separate cases to consider (although each case -* shares code with another)... -* -* (1) A free variable becomes fixed on one of its bounds when there -* are already some general constraints in the working set. -* -* (2) A free variable becomes fixed on one of its bounds when there -* are only bound constraints in the working set. -* -* (3) A general constraint (corresponding to row IADD of A) is -* added to the working set. -* -* In cases (1) and (2), we assume that KX(IFIX) = JADD. -* In all cases, JADD is the index of the constraint being added. -* -* If there are no general constraints in the working set, the -* matrix Q = (Z Y) is the identity and will not be touched. -* -* If NRES .GT. 0, the row transformations are applied to the rows of -* the (N by NRES) matrix RES. -* If NGQ .GT. 0, the column transformations are applied to the -* columns of the (NGQ by N) matrix GQ'. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October--1984. -* This version of LSADD dated 29-December-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - LOGICAL BOUND , OVERFL - EXTERNAL DDOT , DDIV , DNRM2 - INTRINSIC MAX , MIN - PARAMETER (ZERO = 0.0D+0, ONE = 1.0D+0) - -* If the condition estimator of the updated factors is greater than -* CONDBD, a warning message is printed. - - CONDBD = ONE / EPSPT9 - - OVERFL = .FALSE. - BOUND = JADD .LE. N - IF (BOUND) THEN -* =============================================================== -* A simple bound has entered the working set. IADD is not used. -* =============================================================== - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1010) NACTIV, NZ, NFREE, IFIX, JADD, UNITQ - NANEW = NACTIV - - IF (UNITQ) THEN - -* Q is not stored, but KX defines an ordering of the columns -* of the identity matrix that implicitly define Q. -* Reorder KX so that variable IFIX is moved to position -* NFREE+1 and variables IFIX+1,...,NFREE+1 are moved one -* position to the left. - - CALL DLOAD ( NFREE, (ZERO), WRK1, 1 ) - WRK1(IFIX) = ONE - - DO 100 I = IFIX, NFREE-1 - KX(I) = KX(I+1) - 100 CONTINUE - ELSE -* ------------------------------------------------------------ -* Q is stored explicitly. -* ------------------------------------------------------------ -* Set WRK1 = the (IFIX)-th row of Q. -* Move the (NFREE)-th row of Q to position IFIX. - - CALL DCOPY ( NFREE, ZY(IFIX,1), NQ, WRK1, 1 ) - IF (IFIX .LT. NFREE) THEN - CALL DCOPY ( NFREE, ZY(NFREE,1), NQ, ZY(IFIX,1), NQ ) - KX(IFIX) = KX(NFREE) - END IF - END IF - KX(NFREE) = JADD - ELSE -* =============================================================== -* A general constraint has entered the working set. -* IFIX is not used. -* =============================================================== - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1020) NACTIV, NZ, NFREE, IADD, JADD, UNITQ - - NANEW = NACTIV + 1 - -* Transform the incoming row of A by Q'. - - CALL DCOPY ( N, A(IADD,1), NROWA, WRK1, 1 ) - CALL CMQMUL( 8, N, NZ, NFREE, NQ, UNITQ, KX, WRK1, ZY, WRK2) - -* Check that the incoming row is not dependent upon those -* already in the working set. - - DTNEW = DNRM2 ( NZ, WRK1, 1 ) - IF (NACTIV .EQ. 0) THEN - -* This is the only general constraint in the working set. - - COND = DDIV ( ASIZE, DTNEW, OVERFL ) - TDTMAX = DTNEW - TDTMIN = DTNEW - ELSE - -* There are already some general constraints in the working -* set. Update the estimate of the condition number. - - TDTMAX = MAX( DTNEW, DTMAX ) - TDTMIN = MIN( DTNEW, DTMIN ) - COND = DDIV ( TDTMAX, TDTMIN, OVERFL ) - END IF - - IF (COND .GT. CONDMX .OR. OVERFL) GO TO 900 - - IF (UNITQ) THEN - -* This is the first general constraint to be added. -* Set Q = I. - - DO 200 J = 1, NFREE - CALL DLOAD ( NFREE, (ZERO), ZY(1,J), 1 ) - ZY(J,J) = ONE - 200 CONTINUE - UNITQ = .FALSE. - END IF - END IF - - NZERO = NZ - 1 - IF (BOUND) NZERO = NFREE - 1 - -* ------------------------------------------------------------------ -* Use a sequence of 2*2 column transformations to reduce the -* first NZERO elements of WRK1 to zero. This affects ZY, except -* when UNITQ is true. The transformations may also be applied -* to R, T and GQ'. -* ------------------------------------------------------------------ - LROWR = N - NELM = 1 - IROWT = NACTIV - - DO 300 K = 1, NZERO - -* Compute the transformation that reduces WRK1(K) to zero, -* then apply it to the relevant columns of Z and GQ'. - - CALL DROT3G( WRK1(K+1), WRK1(K), CS, SN ) - IF (.NOT. UNITQ) - $ CALL DROT3 ( NFREE, ZY(1,K+1), 1, ZY(1,K), 1, CS, SN ) - IF (NGQ .GT. 0) - $ CALL DROT3 ( NGQ , GQ(K+1,1), N, GQ(K,1), N, CS, SN ) - - IF (K .GE. NZ .AND. NACTIV .GT. 0) THEN - -* Apply the rotation to T. - - T(IROWT,K) = ZERO - CALL DROT3 ( NELM, T(IROWT,K+1), 1, T(IROWT,K), 1, CS, SN ) - NELM = NELM + 1 - IROWT = IROWT - 1 - END IF - - IF (NRANK .GT. 0) THEN - -* Apply the same transformation to the columns of R. -* This generates a subdiagonal element in R that must be -* eliminated by a row rotation. - - IF (K .LT. NRANK) R(K+1,K) = ZERO - LCOL = MIN( K+1, NRANK ) - - CALL DROT3 ( LCOL, R(1,K+1), 1, R(1,K), 1, CS, SN ) - IF (K .LT. NRANK) THEN - CALL DROT3G( R(K,K), R(K+1,K), CS, SN ) - LROWR = LROWR - 1 - CALL DROT3 ( LROWR, R(K,K+1) , NROWR, - $ R(K+1,K+1), NROWR, CS, SN ) - - IF (NRES .GT. 0) - $ CALL DROT3 ( NRES, RES(K,1) , N , - $ RES(K+1,1), N , CS, SN ) - END IF - END IF - 300 CONTINUE - - IF (BOUND) THEN - -* The last row and column of ZY has been transformed to plus -* or minus the unit vector E(NFREE). We can reconstitute the -* columns of GQ and R corresponding to the new fixed variable. - - IF (WRK1(NFREE) .LT. ZERO) THEN - NFMIN = MIN( NRANK, NFREE ) - IF (NFMIN .GT. 0) CALL DSCAL ( NFMIN, -ONE, R(1,NFREE) , 1 ) - IF (NGQ .GT. 0) CALL DSCAL ( NGQ , -ONE, GQ(NFREE,1), N ) - END IF - -* --------------------------------------------------------------- -* The diagonals of T have been altered. Recompute the -* largest and smallest values. -* --------------------------------------------------------------- - IF (NACTIV .GT. 0) THEN - CALL DCOND( NACTIV, T(NACTIV,NZ), NROWT-1, TDTMAX, TDTMIN ) - COND = DDIV ( TDTMAX, TDTMIN, OVERFL ) - END IF - ELSE -* --------------------------------------------------------------- -* General constraint. Install the new row of T. -* --------------------------------------------------------------- - CALL DCOPY ( NANEW, WRK1(NZ), 1, T(NANEW,NZ), NROWT ) - END IF - -* ================================================================== -* Prepare to exit. Check the magnitude of the condition estimator. -* ================================================================== - 900 IF (NANEW .GT. 0) THEN - IF (COND .LT. CONDMX .AND. .NOT. OVERFL) THEN - -* The factorization has been successfully updated. - - INFORM = 0 - DTMAX = TDTMAX - DTMIN = TDTMIN - IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD - ELSE - -* The proposed working set appears to be linearly dependent. - - INFORM = 1 - IF (LSDBG .AND. ILSDBG(1) .GT. 0) THEN - WRITE( NOUT, 3000 ) - IF (BOUND) THEN - WRITE (NOUT, 3010) ASIZE, DTMAX, DTMIN - ELSE - IF (NACTIV .GT. 0) THEN - WRITE (NOUT, 3020) ASIZE, DTMAX, DTMIN, DTNEW - ELSE - WRITE (NOUT, 3030) ASIZE, DTNEW - END IF - END IF - END IF - END IF - END IF - - RETURN - - 1010 FORMAT(/ ' //LSADD // Simple bound added.' - $ / ' //LSADD // NACTIV NZ NFREE IFIX JADD UNITQ' - $ / ' //LSADD // ', 5I6, L6 ) - 1020 FORMAT(/ ' //LSADD // General constraint added. ' - $ / ' //LSADD // NACTIV NZ NFREE IADD JADD UNITQ' - $ / ' //LSADD // ', 5I6, L6 ) - 2000 FORMAT(/ ' XXX Serious ill-conditioning in the working set', - $ ' after adding constraint ', I5 - $ / ' XXX Overflow may occur in subsequent iterations.'//) - 3000 FORMAT(/ ' //LSADD // Dependent constraint rejected.' ) - 3010 FORMAT(/ ' //LSADD // ASIZE DTMAX DTMIN ' - $ / ' //LSADD //', 1P3E10.2 ) - 3020 FORMAT(/ ' //LSADD // ASIZE DTMAX DTMIN DTNEW' - $ / ' //LSADD //', 1P4E10.2 ) - 3030 FORMAT(/ ' //LSADD // ASIZE DTNEW' - $ / ' //LSADD //', 1P2E10.2 ) - -* End of LSADD . - - END
deleted file mode 100644 --- a/libcruft/npsol/lsadds.f +++ /dev/null @@ -1,137 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSADDS( UNITQ, VERTEX, - $ INFORM, K1, K2, NACTIV, NARTIF, NZ, NFREE, - $ NRANK, NREJTD, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ CONDMX, - $ A, R, T, RES, GQ, - $ ZY, WRK1, WRK2 ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ, VERTEX - INTEGER ISTATE(*), KACTIV(N), KX(N) - DOUBLE PRECISION CONDMX - DOUBLE PRECISION A(NROWA,*), R(NROWR,*), - $ T(NROWT,*), RES(N,*), GQ(N,*), ZY(NQ,*) - DOUBLE PRECISION WRK1(N), WRK2(N) - -************************************************************************ -* LSADDS includes general constraints K1 thru K2 as new rows of -* the TQ factorization stored in T, ZY. If NRANK is nonzero, the -* changes in Q are reflected in NRANK by N triangular factor R such -* that -* W = P ( R ) Q, -* ( 0 ) -* where P is orthogonal. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written October-31-1984. -* This version of LSADDS dated 30-December-1985. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN - - EXTERNAL DNRM2 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - RTMAX = WMACH(8) - -* Estimate the condition number of the constraints that are not -* to be refactorized. - - IF (NACTIV .EQ. 0) THEN - DTMAX = ZERO - DTMIN = ONE - ELSE - CALL DCOND ( NACTIV, T(NACTIV,NZ+1), NROWT-1, DTMAX, DTMIN ) - END IF - - DO 200 K = K1, K2 - IADD = KACTIV(K) - JADD = N + IADD - IF (NACTIV .LT. NFREE) THEN - - CALL LSADD ( UNITQ, - $ INFORM, IFIX, IADD, JADD, - $ NACTIV, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NROWA, NQ, NROWR, NROWT, - $ KX, CONDMX, - $ A, R, T, RES, GQ, ZY, - $ WRK1, WRK2 ) - - IF (INFORM .EQ. 0) THEN - NACTIV = NACTIV + 1 - NZ = NZ - 1 - ELSE - ISTATE(JADD) = 0 - KACTIV(K) = - KACTIV(K) - END IF - END IF - 200 CONTINUE - - IF (NACTIV .LT. K2) THEN - -* Some of the constraints were classed as dependent and not -* included in the factorization. Re-order the part of KACTIV -* that holds the indices of the general constraints in the -* working set. Move accepted indices to the front and shift -* rejected indices (with negative values) to the end. - - L = K1 - 1 - DO 300 K = K1, K2 - I = KACTIV(K) - IF (I .GE. 0) THEN - L = L + 1 - IF (L .NE. K) THEN - ISWAP = KACTIV(L) - KACTIV(L) = I - KACTIV(K) = ISWAP - END IF - END IF - 300 CONTINUE - -* If a vertex is required, add some temporary bounds. -* We must accept the resulting condition number of the working -* set. - - IF (VERTEX) THEN - CNDMAX = RTMAX - NZADD = NZ - DO 320 IARTIF = 1, NZADD - ROWMAX = ZERO - DO 310 I = 1, NFREE - RNORM = DNRM2 ( NZ, ZY(I,1), NQ ) - IF (ROWMAX .LT. RNORM) THEN - ROWMAX = RNORM - IFIX = I - END IF - 310 CONTINUE - JADD = KX(IFIX) - - CALL LSADD ( UNITQ, - $ INFORM, IFIX, IADD, JADD, - $ NACTIV, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NROWA, NQ, NROWR, NROWT, - $ KX, CNDMAX, - $ A, R, T, RES, GQ, ZY, - $ WRK1, WRK2 ) - - NFREE = NFREE - 1 - NZ = NZ - 1 - NARTIF = NARTIF + 1 - ISTATE(JADD) = 4 - 320 CONTINUE - END IF - END IF - - NREJTD = K2 - NACTIV - - RETURN - -* End of LSADDS. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsbnds.f +++ /dev/null @@ -1,103 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSBNDS( UNITQ, - $ INFORM, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, KX, - $ CONDMX, - $ A, R, T, RES, GQ, - $ ZY, WRK1, WRK2 ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER ISTATE(*), KX(N) - DOUBLE PRECISION CONDMX - DOUBLE PRECISION A(NROWA,*), R(NROWR,*), - $ T(NROWT,*), RES(N,*), GQ(N,*), ZY(NQ,*) - DOUBLE PRECISION WRK1(N), WRK2(N) - -************************************************************************ -* LSBNDS updates the factor R as KX is reordered to reflect the -* status of the bound constraints given by ISTATE. KX is reordered -* so that the fixed variables come last. One of two alternative -* are used to reorder KX. One method needs fewer accesses to KX, the -* other gives a matrix Rz with more rows and columns. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 30-December-1985. -* This version dated 30-December-1985. -************************************************************************ - - NFIXED = N - NFREE - - IF (NRANK .LT. N .AND. NRANK .GT. 0) THEN -* --------------------------------------------------------------- -* R is specified but singular. Try and keep the dimension of Rz -* as large as possible. -* --------------------------------------------------------------- - NACTV = 0 - NFREE = N - NZ = N - - J = N -*+ WHILE (J .GT. 0 .AND. N-NFREE .LT. NFIXED) DO - 100 IF (J .GT. 0 .AND. N-NFREE .LT. NFIXED) THEN - IF (ISTATE(J) .GT. 0) THEN - JADD = J - DO 110 IFIX = NFREE, 1, -1 - IF (KX(IFIX) .EQ. JADD) GO TO 120 - 110 CONTINUE - -* Add bound JADD. - - 120 CALL LSADD ( UNITQ, - $ INFORM, IFIX, IADD, JADD, - $ NACTV, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NROWA, NQ, NROWR, NROWT, - $ KX, CONDMX, - $ A, R, T, RES, GQ, ZY, - $ WRK1, WRK2 ) - - NFREE = NFREE - 1 - NZ = NZ - 1 - END IF - J = J - 1 - GO TO 100 -*+ END WHILE - END IF - ELSE -* --------------------------------------------------------------- -* R is of full rank, or is not specified. -* --------------------------------------------------------------- - IF (NFIXED .GT. 0) THEN - -* Order KX so that the free variables come first. - - LSTART = NFREE + 1 - DO 250 K = 1, NFREE - J = KX(K) - IF (ISTATE(J) .GT. 0) THEN - DO 220 L = LSTART, N - J2 = KX(L) - IF (ISTATE(J2) .EQ. 0) GO TO 230 - 220 CONTINUE - - 230 KX(K) = J2 - KX(L) = J - LSTART = L + 1 - - IF (NRANK .GT. 0) - $ CALL CMRSWP( N, NRES, NRANK, NROWR, K, L, - $ R, RES, WRK1 ) - END IF - 250 CONTINUE - - END IF - NZ = NFREE - END IF - - RETURN - -* End of LSBNDS. - - END
deleted file mode 100644 --- a/libcruft/npsol/lschol.f +++ /dev/null @@ -1,109 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSCHOL( NROWH, N, NRANK, TOLRNK, KX, H, INFORM ) - - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - INTEGER KX(*) - DOUBLE PRECISION H(NROWH,*) - -************************************************************************ -* LSCHOL forms the Cholesky factorization of the positive -* semi-definite matrix H such that -* PHP' = R'R -* where P is a permutation matrix and R is upper triangular. -* The permutation P is chosen to maximize the diagonal of R at each -* stage. Only the diagonal and super-diagonal elements of H are -* used. -* -* Output: -* -* INFORM = 0 the factorization was computed successfully, -* with the Cholesky factor written in the upper -* triangular part of H and P stored in KX. -* 1 the matrix H was indefinite. -* -* Systems Optimization Laboratory, Stanford University. -* Original version of LSCHOL dated 2-February-1981. -* Level 2 Blas added 29-June-1986. -* This version of LSCHOL dated 30-June-1986. -************************************************************************ - - COMMON /SOL1CM/ NOUT - INTRINSIC ABS , MAX , SQRT - EXTERNAL IDAMAX - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - INFORM = 0 - NRANK = 0 - -* Main loop for computing rows of R. - - DO 200 J = 1, N - -* Find maximum available diagonal. - - KMAX = J - 1 + IDAMAX( N-J+1, H(J,J), NROWH+1 ) - DMAX = H(KMAX,KMAX) - - IF (DMAX .LE. TOLRNK*ABS(H(1,1))) GO TO 300 - -* Perform a symmetric interchange if necessary. - - IF (KMAX .NE. J) THEN - K = KX(KMAX) - KX(KMAX) = KX(J) - KX(J) = K - - CALL DSWAP ( J , H(1,J) , 1, H(1,KMAX), 1 ) - CALL DSWAP ( KMAX-J+1, H(J,KMAX), 1, H(J,J) , NROWH ) - CALL DSWAP ( N-KMAX+1, H(KMAX,KMAX), NROWH, - $ H(J,KMAX) , NROWH ) - - H(KMAX,KMAX) = H(J,J) - END IF - -* Set the diagonal of R. - - D = SQRT( DMAX ) - H(J,J) = D - NRANK = NRANK + 1 - - IF (J .LT. N) THEN - -* Set the super-diagonal elements of this row of R and update -* the elements of the block that is yet to be factorized. - - CALL DSCAL ( N-J, (ONE/D), H(J ,J+1), NROWH ) - CALL DSYR ( 'U', N-J, -ONE, H(J ,J+1), NROWH, - $ H(J+1,J+1), NROWH ) - END IF - - 200 CONTINUE -* ------------------------------------------------------------------ -* Check for the semi-definite case. -* ------------------------------------------------------------------ - 300 IF (NRANK .LT. N) THEN - -* Find the largest element in the unfactorized block. - - SUPMAX = ZERO - DO 310 I = J, N-1 - K = I + IDAMAX( N-I, H(I,I+1), NROWH ) - SUPMAX = MAX( SUPMAX, ABS(H(I,K)) ) - 310 CONTINUE - - IF (SUPMAX .GT. TOLRNK*ABS(H(1,1))) THEN - WRITE (NOUT, 1000) DMAX, SUPMAX - INFORM = 1 - END IF - END IF - - RETURN - - 1000 FORMAT(' XXX Hessian appears to be indefinite.' - $ /' XXX Maximum diagonal and off-diagonal ignored', - $ ' in the Cholesky factorization:', 1P2E22.14 ) - -* End of LSCHOL. - - END
deleted file mode 100644 --- a/libcruft/npsol/lscore.f +++ /dev/null @@ -1,618 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSCORE( PRBTYP, NAMED, NAMES, LINOBJ, UNITQ, - $ INFORM, ITER, JINF, NCLIN, NCTOTL, - $ NACTIV, NFREE, NRANK, NZ, NZ1, - $ N, NROWA, NROWR, - $ ISTATE, KACTIV, KX, - $ CTX, SSQ, SSQ1, SUMINF, NUMINF, XNORM, - $ BL, BU, A, CLAMDA, AX, - $ FEATOL, R, X, IW, W ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*2 PRBTYP - CHARACTER*8 NAMES(*) - INTEGER ISTATE(NCTOTL), KACTIV(N), KX(N) - INTEGER IW(*) - DOUBLE PRECISION BL(NCTOTL), BU(NCTOTL), A(NROWA,*), - $ CLAMDA(NCTOTL), AX(*), - $ FEATOL(NCTOTL), R(NROWR,*), X(N) - DOUBLE PRECISION W(*) - LOGICAL NAMED, LINOBJ, UNITQ - -************************************************************************ -* LSCORE is a subroutine for linearly constrained linear-least -* squares. On entry, it is assumed that an initial working set of -* linear constraints and bounds is available. -* The arrays ISTATE, KACTIV and KX will have been set accordingly -* and the arrays T and ZY will contain the TQ factorization of -* the matrix whose rows are the gradients of the active linear -* constraints with the columns corresponding to the active bounds -* removed. the TQ factorization of the resulting (NACTIV by NFREE) -* matrix is A(free)*Q = (0 T), where Q is (NFREE by NFREE) and T -* is reverse-triangular. -* -* Values of ISTATE(J) for the linear constraints....... -* -* ISTATE(J) -* --------- -* 0 constraint J is not in the working set. -* 1 constraint J is in the working set at its lower bound. -* 2 constraint J is in the working set at its upper bound. -* 3 constraint J is in the working set as an equality. -* -* Constraint J may be violated by as much as FEATOL(J). -* -* Systems Optimization Laboratory, Stanford University. -* This version of LSCORE dated 1-August-1986. -* -* Copyright 1984 Stanford University. -* -* This material may be reproduced by or for the U.S. Government pursu- -* ant to the copyright license under DAR clause 7-104.9(a) (1979 Mar). -* -* This material is based upon work partially supported by the National -* Science Foundation under grants MCS-7926009 and ECS-8012974; the -* Department of Energy Contract AM03-76SF00326, PA No. DE-AT03- -* 76ER72018; and the Army Research Office Contract DAA29-79-C-0110. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT, NCOLT, NQ - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN - - INTEGER LOCLS - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - LOGICAL CMDBG, LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG) - - EXTERNAL DDIV , DDOT , DNRM2 - INTRINSIC ABS , MAX , SQRT - LOGICAL CONVRG, CYCLIN, ERROR , FIRSTV, HITCON, - $ HITLOW, NEEDFG, OVERFL, PRNT , PRNT1 , ROWERR - LOGICAL SINGLR, STALL , STATPT, UNBNDD, UNCON , UNITGZ, - $ WEAK - PARAMETER ( ZERO =0.0D+0, HALF =0.5D+0, ONE =1.0D+0 ) - PARAMETER ( MREFN =1 , MSTALL =50 ) - -* Specify the machine-dependent parameters. - - EPSMCH = WMACH(3) - FLMAX = WMACH(7) - RTMAX = WMACH(8) - - LANORM = LOCLS( 2) - LAP = LOCLS( 3) - LPX = LOCLS( 4) - LRES = LOCLS( 5) - LRES0 = LOCLS( 6) - LHZ = LOCLS( 7) - LGQ = LOCLS( 8) - LCQ = LOCLS( 9) - LRLAM = LOCLS(10) - LT = LOCLS(11) - LZY = LOCLS(12) - LWTINF = LOCLS(13) - LWRK = LOCLS(14) - -* Set up the adresses of the contiguous arrays ( RES0, RES ) -* and ( GQ, CQ ). - - NRES = 0 - IF (NRANK .GT. 0) NRES = 2 - NGQ = 1 - IF (LINOBJ) NGQ = 2 - -* Initialize. - - IREFN = 0 - ITER = 0 - ITMAX = ITMAX1 - JADD = 0 - JDEL = 0 - NCNLN = 0 - NPHASE = 1 - NSTALL = 0 - NUMINF = - 1 - NZ1 = 0 - - ALFA = ZERO - CONDMX = FLMAX - DRZMAX = ONE - DRZMIN = ONE - SSQ = ZERO - - CYCLIN = .FALSE. - ERROR = .FALSE. - FIRSTV = .FALSE. - PRNT = .TRUE. - PRNT1 = .TRUE. - NEEDFG = .TRUE. - STALL = .TRUE. - UNCON = .FALSE. - UNBNDD = .FALSE. - -* If debug output is required, print nothing until iteration IDBG. - - MSGSVD = MSGLVL - IF (IDBG .GT. 0 .AND. IDBG .LE. ITMAX) THEN - MSGLVL = 0 - END IF - -*======================== start of the main loop ======================= -* -* cyclin = false -* unbndd = false -* error = false -* k = 0 -* -* repeat -* repeat -* compute Z'g, print details of this iteration -* stat pt = (Z'g .eq. 0) -* if (not stat pt) then -* error = k .ge. itmax -* if (not error) then -* compute p, alfa -* error = unbndd or cyclin -* if (not error) then -* k = k + 1 -* x = x + alfa p -* if (feasible) update Z'g -* if necessary, add a constraint -* end if -* end if -* end if -* until stat pt or error -* -* compute lam1, lam2, smllst -* optmul = smllst .gt. 0 -* if ( not (optmul .or. error) ) then -* delete an artificial or regular constraint -* end if -* until optmul or error -* -*======================================================================= - -* REPEAT -* REPEAT - 100 IF (NEEDFG) THEN - IF (NRANK .GT. 0) THEN - RESNRM = DNRM2 ( NRANK, W(LRES), 1 ) - SSQ = HALF*(SSQ1**2 + RESNRM**2 ) - END IF - - IF (NUMINF .NE. 0) THEN - -* Compute the transformed gradient of either the sum of -* of infeasibilities or the objective. Initialize -* SINGLR and UNITGZ. - - CALL LSGSET( PRBTYP, LINOBJ, SINGLR, UNITGZ, UNITQ, - $ N, NCLIN, NFREE, - $ NROWA, NQ, NROWR, NRANK, NZ, NZ1, - $ ISTATE, KX, - $ BIGBND, TOLRNK, NUMINF, SUMINF, - $ BL, BU, A, W(LRES), FEATOL, - $ W(LGQ), W(LCQ), R, X, W(LWTINF), - $ W(LZY), W(LWRK) ) - - IF (PRBTYP .NE. 'FP' .AND. NUMINF .EQ. 0 - $ .AND. NPHASE .EQ. 1) THEN - ITMAX = ITER + ITMAX2 - NPHASE = 2 - END IF - END IF - END IF - - GZNORM = ZERO - IF (NZ .GT. 0 ) GZNORM = DNRM2 ( NZ, W(LGQ), 1 ) - - IF (NZ1 .EQ. NZ) THEN - GZ1NRM = GZNORM - ELSE - GZ1NRM = ZERO - IF (NZ1 .GT. 0) GZ1NRM = DNRM2 ( NZ1, W(LGQ), 1 ) - END IF - - GFNORM = GZNORM - IF (NFREE .GT. 0 .AND. NACTIV .GT. 0) - $ GFNORM = DNRM2 ( NFREE, W(LGQ), 1 ) - -* ------------------------------------------------------------ -* Print the details of this iteration. -* ------------------------------------------------------------ -* Define small quantities that reflect the size of X, R and -* the constraints in the working set. If feasible, estimate -* the rank and condition number of Rz1. -* Note that NZ1 .LE. NRANK + 1. - - IF (NZ1 .EQ. 0) THEN - SINGLR = .FALSE. - ELSE - IF (NUMINF .GT. 0 .OR. NZ1 .GT. NRANK) THEN - ABSRZZ = ZERO - ELSE - CALL DCOND ( NZ1, R, NROWR+1, DRZMAX, DRZMIN ) - ABSRZZ = ABS( R(NZ1,NZ1) ) - END IF - SINGLR = ABSRZZ .LE. DRZMAX*TOLRNK - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 9100) SINGLR, ABSRZZ, DRZMAX, DRZMIN - - END IF - - CONDRZ = DDIV ( DRZMAX, DRZMIN, OVERFL ) - CONDT = ONE - IF (NACTIV .GT. 0) - $ CONDT = DDIV ( DTMAX , DTMIN , OVERFL ) - - IF (PRNT) THEN - CALL LSPRT ( PRBTYP, PRNT1, ISDEL, ITER, JADD, JDEL, - $ MSGLVL, NACTIV, NFREE, N, NCLIN, - $ NRANK, NROWR, NROWT, NZ, NZ1, - $ ISTATE, - $ ALFA, CONDRZ, CONDT, GFNORM, GZNORM, GZ1NRM, - $ NUMINF, SUMINF, CTX, SSQ, - $ AX, R, W(LT), X, W(LWRK) ) - - JDEL = 0 - JADD = 0 - ALFA = ZERO - END IF - - IF (NUMINF .GT. 0) THEN - DINKY = ZERO - ELSE - OBJSIZ = ONE + ABS( SSQ + CTX ) - WSSIZE = ZERO - IF (NACTIV .GT. 0) WSSIZE = DTMAX - DINKY = EPSPT8 * MAX( WSSIZE, OBJSIZ, GFNORM ) - IF (UNCON) THEN - UNITGZ = GZ1NRM .LE. DINKY - END IF - END IF - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 9000) UNITGZ, IREFN, GZ1NRM, DINKY - -* If the projected gradient Z'g is small and Rz is of full -* rank, X is a minimum on the working set. An additional -* refinement step is allowed to take care of an inaccurate -* value of DINKY. - - STATPT = .NOT. SINGLR .AND. GZ1NRM .LE. DINKY - $ .OR. IREFN .GT. MREFN - - IF (.NOT. STATPT) THEN -* --------------------------------------------------------- -* Compute a search direction. -* --------------------------------------------------------- - PRNT = .TRUE. - - ERROR = ITER .GE. ITMAX - IF (.NOT. ERROR) THEN - - IREFN = IREFN + 1 - ITER = ITER + 1 - - IF (ITER .EQ. IDBG) THEN - LSDBG = .TRUE. - CMDBG = LSDBG - MSGLVL = MSGSVD - END IF - - CALL LSGETP( LINOBJ, SINGLR, UNITGZ, UNITQ, - $ N, NCLIN, NFREE, - $ NROWA, NQ, NROWR, NRANK, NUMINF, NZ1, - $ ISTATE, KX, CTP, PNORM, - $ A, W(LAP), W(LRES), W(LHZ), W(LPX), - $ W(LGQ), W(LCQ), R, W(LZY), W(LWRK) ) - -* ------------------------------------------------------ -* Find the constraint we bump into along P. -* Update X and AX if the step ALFA is nonzero. -* ------------------------------------------------------ -* ALFHIT is initialized to BIGALF. If it remains -* that way after the call to CMALF, it will be -* regarded as infinite. - - BIGALF = DDIV ( BIGDX, PNORM, OVERFL ) - - CALL CMALF ( FIRSTV, HITLOW, - $ ISTATE, INFORM, JADD, N, NROWA, - $ NCLIN, NCTOTL, NUMINF, - $ ALFHIT, PALFA, ATPHIT, - $ BIGALF, BIGBND, PNORM, - $ W(LANORM), W(LAP), AX, - $ BL, BU, FEATOL, W(LPX), X ) - -* If Rz1 is nonsingular, ALFA = 1.0 will be the -* step to the least-squares minimizer on the -* current subspace. If the unit step does not violate -* the nearest constraint by more than FEATOL, the -* constraint is not added to the working set. - - HITCON = SINGLR .OR. PALFA .LE. ONE - UNCON = .NOT. HITCON - - IF (HITCON) THEN - ALFA = ALFHIT - ELSE - JADD = 0 - ALFA = ONE - END IF - -* Check for an unbounded solution or negligible step. - - UNBNDD = ALFA .GE. BIGALF - STALL = ABS( ALFA*PNORM ) .LE. EPSPT9*XNORM - IF (STALL) THEN - NSTALL = NSTALL + 1 - CYCLIN = NSTALL .GT. MSTALL - ELSE - NSTALL = 0 - END IF - - ERROR = UNBNDD .OR. CYCLIN - IF (.NOT. ERROR) THEN -* --------------------------------------------------- -* Set X = X + ALFA*P. Update AX, GQ, RES and CTX. -* --------------------------------------------------- - IF (ALFA .NE. ZERO) - $ CALL LSMOVE( HITCON, HITLOW, LINOBJ, UNITGZ, - $ NCLIN, NRANK, NZ1, - $ N, NROWR, JADD, NUMINF, - $ ALFA, CTP, CTX, XNORM, - $ W(LAP), AX, BL, BU, W(LGQ), - $ W(LHZ), W(LPX), W(LRES), - $ R, X, W(LWRK) ) - - IF (HITCON) THEN -* ------------------------------------------------ -* Add a constraint to the working set. -* Update the TQ factors of the working set. -* Use P as temporary work space. -* ------------------------------------------------ -* Update ISTATE. - - IF (BL(JADD) .EQ. BU(JADD)) THEN - ISTATE(JADD) = 3 - ELSE IF (HITLOW) THEN - ISTATE(JADD) = 1 - ELSE - ISTATE(JADD) = 2 - END IF - IADD = JADD - N - IF (JADD .LE. N) THEN - - DO 510 IFIX = 1, NFREE - IF (KX(IFIX) .EQ. JADD) GO TO 520 - 510 CONTINUE - 520 END IF - - CALL LSADD ( UNITQ, - $ INFORM, IFIX, IADD, JADD, - $ NACTIV, NZ, NFREE, NRANK, NRES,NGQ, - $ N, NROWA, NQ, NROWR, NROWT, - $ KX, CONDMX, - $ A, R, W(LT), W(LRES), W(LGQ), - $ W(LZY), W(LWRK), W(LRLAM) ) - - NZ1 = NZ1 - 1 - NZ = NZ - 1 - - IF (JADD .LE. N) THEN - -* A simple bound has been added. - - NFREE = NFREE - 1 - ELSE - -* A general constraint has been added. - - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = IADD - END IF - - IREFN = 0 - - END IF - -* --------------------------------------------------- -* Check the feasibility of constraints with non- -* negative ISTATE values. If some violations have -* occurred. Refine the current X and set INFORM so -* that feasibility is checked in LSGSET. -* --------------------------------------------------- - CALL LSFEAS( N, NCLIN, ISTATE, - $ BIGBND, CNORM, ERR1, JMAX1, NVIOL, - $ AX, BL, BU, FEATOL, X, W(LWRK) ) - - IF (ERR1 .GT. FEATOL(JMAX1)) THEN - CALL LSSETX( LINOBJ, ROWERR, UNITQ, - $ NCLIN, NACTIV, NFREE, NRANK, NZ, - $ N, NCTOTL, NQ, NROWA, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ JMAX1, ERR2, CTX, XNORM, - $ A, AX, BL, BU, W(LCQ), - $ W(LRES), W(LRES0), FEATOL, R, - $ W(LT), X, W(LZY), W(LPX), W(LWRK) ) - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 2100) ERR1, ERR2 - IF (ROWERR) WRITE (NOUT, 2200) - - UNCON = .FALSE. - IREFN = 0 - NUMINF = - 1 - END IF - NEEDFG = ALFA .NE. ZERO - END IF - END IF - END IF - -* UNTIL STATPT .OR. ERROR - IF (.NOT. (STATPT .OR. ERROR) ) GO TO 100 - -* =============================================================== -* Try and find the index JDEL of a constraint to drop from -* the working set. -* =============================================================== - JDEL = 0 - - IF (NUMINF .EQ. 0 .AND. PRBTYP .EQ. 'FP') THEN - IF (N .GT. NZ) - $ CALL DLOAD ( N-NZ, (ZERO), W(LRLAM), 1 ) - JTINY = 0 - JSMLST = 0 - JBIGST = 0 - ELSE - - CALL LSMULS( PRBTYP, - $ MSGLVL, N, NACTIV, NFREE, - $ NROWA, NROWT, NUMINF, NZ, NZ1, - $ ISTATE, KACTIV, KX, DINKY, - $ JSMLST, KSMLST, JINF, JTINY, - $ JBIGST, KBIGST, TRULAM, - $ A, W(LANORM), W(LGQ), W(LRLAM), - $ W(LT), W(LWTINF) ) - - END IF - - IF (.NOT. ERROR) THEN - IF ( JSMLST .GT. 0) THEN - -* LSMULS found a regular constraint with multiplier less -* than (-DINKY). - - JDEL = JSMLST - KDEL = KSMLST - ISDEL = ISTATE(JDEL) - ISTATE(JDEL) = 0 - - ELSE IF (JSMLST .LT. 0) THEN - - JDEL = JSMLST - - ELSE IF (NUMINF .GT. 0 .AND. JBIGST .GT. 0) THEN - -* No feasible point exists for the constraints but the -* sum of the constraint violations may be reduced by -* moving off constraints with multipliers greater than 1. - - JDEL = JBIGST - KDEL = KBIGST - ISDEL = ISTATE(JDEL) - IF (TRULAM .LE. ZERO) IS = - 1 - IF (TRULAM .GT. ZERO) IS = - 2 - ISTATE(JDEL) = IS - FIRSTV = .TRUE. - NUMINF = NUMINF + 1 - END IF - - IF (JDEL .NE. 0 .AND. SINGLR) THEN - -* Cannot delete a constraint when Rz is singular. -* Probably a weak minimum. - - JDEL = 0 - ELSE IF (JDEL .NE. 0 ) THEN - -* Constraint JDEL has been deleted. -* Update the matrix factorizations. - - CALL LSDEL ( UNITQ, - $ N, NACTIV, NFREE, NRES, NGQ, NZ, NZ1, - $ NROWA, NQ, NROWR, NROWT, NRANK, - $ JDEL, KDEL, KACTIV, KX, - $ A, W(LRES), R, W(LT), W(LGQ),W(LZY),W(LWRK)) - - END IF - END IF - - IREFN = 0 - CONVRG = JDEL .EQ. 0 - PRNT = .FALSE. - UNCON = .FALSE. - NEEDFG = .FALSE. - -* until convrg .or. error - IF (.NOT. (CONVRG .OR. ERROR)) GO TO 100 - -* .........................End of main loop............................ - - WEAK = JTINY .GT. 0 .OR. SINGLR - - IF (ERROR) THEN - IF (UNBNDD) THEN - INFORM = 2 - IF (NUMINF .GT. 0) INFORM = 3 - ELSE IF (ITER .GE. ITMAX) THEN - INFORM = 4 - ELSE IF (CYCLIN) THEN - INFORM = 5 - END IF - ELSE IF (CONVRG) THEN - INFORM = 0 - IF (NUMINF .GT. 0) THEN - INFORM = 3 - ELSE IF (PRBTYP .NE. 'FP' .AND. WEAK) THEN - INFORM = 1 - END IF - END IF - -* ------------------------------------------------------------------ -* Set CLAMDA. Print the full solution. -* ------------------------------------------------------------------ - MSGLVL = MSGSVD - IF (MSGLVL .GT. 0) WRITE (NOUT, 2000) PRBTYP, ITER, INFORM - - CALL CMPRT ( MSGLVL, NFREE, NROWA, - $ N, NCLIN, NCNLN, NCTOTL, BIGBND, - $ NAMED, NAMES, LENNAM, - $ NACTIV, ISTATE, KACTIV, KX, - $ A, BL, BU, X, CLAMDA, W(LRLAM), X ) - - RETURN - - 2000 FORMAT(/ ' Exit from ', A2, ' problem after ', I4, ' iterations.', - $ ' INFORM =', I3 ) - 2100 FORMAT( ' XXX Iterative refinement. Maximum errors before and', - $ ' after refinement are ', 1P2E14.2 ) - 2200 FORMAT( ' XXX Warning. Cannot satisfy the constraints to the', - $ ' accuracy requested.') - 9000 FORMAT(/ ' //LSCORE// UNITGZ IREFN GZ1NRM DINKY' - $ / ' //LSCORE// ', L6, I6, 1P2E11.2 ) - 9100 FORMAT(/ ' //LSCORE// SINGLR ABS(RZZ1) DRZMAX DRZMIN' - $ / ' //LSCORE// ', L6, 1P3E12.4 ) - -* End of LSCORE. - - END
deleted file mode 100644 --- a/libcruft/npsol/lscrsh.f +++ /dev/null @@ -1,260 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSCRSH( COLD, VERTEX, - $ NCLIN, NCTOTL, NACTIV, NARTIF, - $ NFREE, N, NROWA, - $ ISTATE, KACTIV, - $ BIGBND, TOLACT, - $ A, AX, BL, BU, X, WX, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL COLD, VERTEX - INTEGER ISTATE(NCTOTL), KACTIV(N) - DOUBLE PRECISION A(NROWA,*), AX(*), BL(NCTOTL), BU(NCTOTL), - $ X(N), WX(N), WORK(N) - -************************************************************************ -* LSCRSH computes the quantities ISTATE (optionally), KACTIV, -* NACTIV, NZ and NFREE associated with the working set at X. -* The computation depends upon the value of the input parameter -* COLD, as follows... -* -* COLD = TRUE. An initial working set will be selected. First, -* nearly-satisfied or violated bounds are added. -* Next, general linear constraints are added that -* have small residuals. -* -* COLD = FALSE. The quantities KACTIV, NACTIV, NZ and NFREE are -* computed from ISTATE, specified by the user. -* -* Values of ISTATE(j).... -* -* - 2 - 1 0 1 2 3 -* a'x lt bl a'x gt bu a'x free a'x = bl a'x = bu bl = bu -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version of LSCRSH dated 27-December-1985. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL DDOT - INTRINSIC ABS, MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - FLMAX = WMACH(7) - CALL DCOPY ( N, X, 1, WX, 1 ) - - IF (LSDBG) THEN - IF (ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) COLD, NCLIN, NCTOTL - IF (ILSDBG(2) .GT. 0) - $ WRITE (NOUT, 1100) (WX(J), J = 1, N) - END IF - - NFIXED = 0 - NACTIV = 0 - NARTIF = 0 - -* If a cold start is being made, initialize ISTATE. -* If BL(j) = BU(j), set ISTATE(j)=3 for all variables and linear -* constraints. - - IF (COLD) THEN - DO 100 J = 1, NCTOTL - ISTATE(J) = 0 - IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3 - 100 CONTINUE - ELSE - DO 110 J = 1, NCTOTL - IF (ISTATE(J) .GT. 3 .OR. ISTATE(J) .LT. 0) ISTATE(J) = 0 - 110 CONTINUE - END IF - -* Initialize NFIXED, NFREE and KACTIV. -* Ensure that the number of bounds and general constraints in the -* working set does not exceed N. - - DO 200 J = 1, NCTOTL - IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0 - IF (ISTATE(J) .GT. 0) THEN - IF (J .LE. N) THEN - NFIXED = NFIXED + 1 - IF (ISTATE(J) .EQ. 1) WX(J) = BL(J) - IF (ISTATE(J) .GE. 2) WX(J) = BU(J) - ELSE - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = J - N - END IF - END IF - 200 CONTINUE - -* ------------------------------------------------------------------ -* If a cold start is required, attempt to add as many -* constraints as possible to the working set. -* ------------------------------------------------------------------ - IF (COLD) THEN - BIGLOW = - BIGBND - BIGUPP = BIGBND - -* See if any bounds are violated or nearly satisfied. -* If so, add these bounds to the working set and set the -* variables exactly on their bounds. - - J = N -*+ WHILE (J .GE. 1 .AND. NFIXED + NACTIV .LT. N) DO - 300 IF (J .GE. 1 .AND. NFIXED + NACTIV .LT. N) THEN - IF (ISTATE(J) .EQ. 0) THEN - B1 = BL(J) - B2 = BU(J) - IS = 0 - IF (B1 .GT. BIGLOW) THEN - IF (WX(J) - B1 .LE. (ONE + ABS( B1 ))*TOLACT) IS = 1 - END IF - IF (B2 .LT. BIGUPP) THEN - IF (B2 - WX(J) .LE. (ONE + ABS( B2 ))*TOLACT) IS = 2 - END IF - IF (IS .GT. 0) THEN - ISTATE(J) = IS - IF (IS .EQ. 1) WX(J) = B1 - IF (IS .EQ. 2) WX(J) = B2 - NFIXED = NFIXED + 1 - END IF - END IF - J = J - 1 - GO TO 300 -*+ END WHILE - END IF - -* --------------------------------------------------------------- -* The following loop finds the linear constraint (if any) with -* smallest residual less than or equal to TOLACT and adds it -* to the working set. This is repeated until the working set -* is complete or all the remaining residuals are too large. -* --------------------------------------------------------------- -* First, compute the residuals for all the constraints not in the -* working set. - - IF (NCLIN .GT. 0 .AND. NACTIV+NFIXED .LT. N) THEN - DO 410 I = 1, NCLIN - IF (ISTATE(N+I) .LE. 0) - $ AX(I) = DDOT (N, A(I,1), NROWA, WX, 1 ) - 410 CONTINUE - - IS = 1 - TOOBIG = TOLACT + TOLACT - -*+ WHILE (IS .GT. 0 .AND. NFIXED + NACTIV .LT. N) DO - 500 IF (IS .GT. 0 .AND. NFIXED + NACTIV .LT. N) THEN - IS = 0 - RESMIN = TOLACT - - DO 520 I = 1, NCLIN - J = N + I - IF (ISTATE(J) .EQ. 0) THEN - B1 = BL(J) - B2 = BU(J) - RESL = TOOBIG - RESU = TOOBIG - IF (B1 .GT. BIGLOW) - $ RESL = ABS( AX(I) - B1 ) / (ONE + ABS( B1 )) - IF (B2 .LT. BIGUPP) - $ RESU = ABS( AX(I) - B2 ) / (ONE + ABS( B2 )) - RESIDL = MIN( RESL, RESU ) - IF(RESIDL .LT. RESMIN) THEN - RESMIN = RESIDL - IMIN = I - IS = 1 - IF (RESL .GT. RESU) IS = 2 - END IF - END IF - 520 CONTINUE - - IF (IS .GT. 0) THEN - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = IMIN - J = N + IMIN - ISTATE(J) = IS - END IF - GO TO 500 -*+ END WHILE - END IF - END IF - -* --------------------------------------------------------------- -* If required, add temporary bounds to make a vertex. -* --------------------------------------------------------------- - IF (VERTEX .AND. NACTIV+NFIXED .LT. N) THEN - -* Compute lengths of columns of selected linear constraints -* (just the ones corresponding to free variables). - - DO 630 J = 1, N - IF (ISTATE(J) .EQ. 0) THEN - COLSIZ = ZERO - DO 620 K = 1, NCLIN - IF (ISTATE(N+K) .GT. 0) - $ COLSIZ = COLSIZ + ABS( A(K,J) ) - 620 CONTINUE - WORK(J) = COLSIZ - END IF - 630 CONTINUE - -* Find the NARTIF smallest such columns. -* This is an expensive loop. Later we can replace it by a -* 4-pass process (say), accepting the first col that is within -* T of COLMIN, where T = 0.0, 0.001, 0.01, 0.1 (say). -* (This comment written in 1980). - -*+ WHILE (NFIXED + NACTIV .LT. N) DO - 640 IF (NFIXED + NACTIV .LT. N) THEN - COLMIN = FLMAX - DO 650 J = 1, N - IF (ISTATE(J) .EQ. 0) THEN - IF (NCLIN .EQ. 0) GO TO 660 - COLSIZ = WORK(J) - IF (COLMIN .GT. COLSIZ) THEN - COLMIN = COLSIZ - JMIN = J - END IF - END IF - 650 CONTINUE - J = JMIN - 660 ISTATE(J) = 4 - NARTIF = NARTIF + 1 - NFIXED = NFIXED + 1 - GO TO 640 -*+ END WHILE - END IF - END IF - END IF - - NFREE = N - NFIXED - - IF (LSDBG) THEN - IF (ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1300) NFIXED, NACTIV, NARTIF - IF (ILSDBG(2) .GT. 0) - $ WRITE (NOUT, 1200) (WX(J), J = 1, N) - END IF - - RETURN - - 1000 FORMAT(/ ' //LSCRSH// COLD NCLIN NCTOTL' - $ / ' //LSCRSH// ', L4, I6, I7 ) - 1100 FORMAT(/ ' //LSCRSH// Variables before crash... '/ (5G12.3)) - 1200 FORMAT(/ ' //LSCRSH// Variables after crash... '/ (5G12.3)) - 1300 FORMAT(/ ' //LSCRSH// Working set selected ... ' - $ / ' //LSCRSH// NFIXED NACTIV NARTIF ' - $ / ' //LSCRSH// ', I6, 2I7 ) - -* End of LSCRSH. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsdel.f +++ /dev/null @@ -1,193 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSDEL ( UNITQ, - $ N, NACTIV, NFREE, NRES, NGQ, NZ, NZ1, - $ NROWA, NQ, NROWR, NROWT, NRANK, - $ JDEL, KDEL, KACTIV, KX, - $ A, RES, R, T, GQ, ZY, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER KACTIV(N), KX(N) - DOUBLE PRECISION A(NROWA,*), RES(N,*), R(NROWR,*), T(NROWT,*), - $ GQ(N,*), ZY(NQ,*) - DOUBLE PRECISION WORK(N) - -************************************************************************ -* LSDEL updates the least-squares factor R and the factorization -* A(free) (Z Y) = (0 T) when a regular, temporary or artificial -* constraint is deleted from the working set. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version of LSDEL dated 10-June-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL IDAMAX - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - IF (JDEL .GT. 0) THEN - -* Regular constraint or temporary bound deleted. - - IF (JDEL .LE. N) THEN - -* Case 1. A simple bound has been deleted. -* ======= Columns NFREE+1 and IR of R must be swapped. - - IR = NZ + KDEL - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1100) NACTIV, NZ, NFREE, IR, JDEL, UNITQ - - IBEGIN = 1 - NFREE = NFREE + 1 - IF (NFREE .LT. IR) THEN - KX(IR) = KX(NFREE) - KX(NFREE) = JDEL - IF (NRANK .GT. 0) - $ CALL CMRSWP( N, NRES, NRANK, NROWR, NFREE, IR, - $ R, RES, WORK ) - CALL DSWAP ( NGQ, GQ(NFREE,1), N, GQ(IR,1), N ) - END IF - - IF (.NOT. UNITQ) THEN - -* Copy the incoming column of A(free) into the end of T. - - DO 130 KA = 1, NACTIV - I = KACTIV(KA) - T(KA,NFREE) = A(I,JDEL) - 130 CONTINUE - -* Expand Q by adding a unit row and column. - - IF (NFREE .GT. 1) THEN - CALL DLOAD ( NFREE-1, ZERO, ZY(NFREE,1), NQ ) - CALL DLOAD ( NFREE-1, ZERO, ZY(1,NFREE), 1 ) - END IF - ZY(NFREE,NFREE) = ONE - END IF - ELSE - -* Case 2. A general constraint has been deleted. -* ======= - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1200) NACTIV, NZ, NFREE, KDEL, JDEL, UNITQ - - IBEGIN = KDEL - NACTIV = NACTIV - 1 - -* Delete a row of T and move the ones below it up. - - DO 220 I = KDEL, NACTIV - KACTIV(I) = KACTIV(I+1) - LD = NFREE - I - CALL DCOPY ( I+1, T(I+1,LD), NROWT, T(I,LD), NROWT ) - 220 CONTINUE - END IF - -* --------------------------------------------------------------- -* Eliminate the super-diagonal elements of T, -* using a backward sweep of 2*2 transformations. -* --------------------------------------------------------------- - K = NFREE - IBEGIN - L = NACTIV - IBEGIN - LROWR = N - K - - DO 420 I = IBEGIN, NACTIV - CALL DROT3G( T(I,K+1), T(I,K), CS, SN ) - - IF (L .GT. 0) - $ CALL DROT3 ( L , T(I+1,K+1), 1, T(I+1,K ), 1, CS, SN ) - CALL DROT3 ( NFREE, ZY(1,K+1) , 1, ZY(1,K ), 1, CS, SN ) - CALL DROT3 ( NGQ , GQ(K+1,1) , N, GQ(K,1) , N, CS, SN ) - -* Apply the column transformations to R. The non-zero -* sub-diagonal that is generated must be eliminated by a row -* rotation. - - IF (K .LT. NRANK) R(K+1,K) = ZERO - LCOL = MIN( K+1, NRANK ) - IF (LCOL .GT. 0) - $ CALL DROT3 ( LCOL, R(1,K+1), 1, R(1,K), 1, CS, SN ) - - IF (K .LT. NRANK) THEN - CALL DROT3G( R(K,K), R(K+1,K), CS, SN ) - - CALL DROT3 ( LROWR, R(K,K+1) , NROWR, - $ R(K+1,K+1) , NROWR, CS, SN ) - CALL DROT3 ( NRES , RES(K,1) , N , - $ RES(K+1,1) , N , CS, SN ) - END IF - K = K - 1 - L = L - 1 - LROWR = LROWR + 1 - 420 CONTINUE - - NZ = NZ + 1 - -* --------------------------------------------------------------- -* Estimate the condition number of T. -* --------------------------------------------------------------- - IF (NACTIV .EQ. 0) THEN - DTMAX = ONE - DTMIN = ONE - ELSE - CALL DCOND ( NACTIV, T(NACTIV,NZ+1), NROWT-1, DTMAX, DTMIN ) - END IF - - END IF - - NZ1 = NZ1 + 1 - - IF (NZ .GT. NZ1) THEN - IF (JDEL .GT. 0) THEN - JART = NZ1 - 1 + IDAMAX( NZ-NZ1+1, GQ(NZ1,1), 1 ) - ELSE - JART = - JDEL - END IF - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE( NOUT, 1000 ) NZ, NZ1, JART - - IF (JART .GT. NZ1) THEN - -* Swap columns NZ1 and JART of R. - - IF (UNITQ) THEN - K = KX(NZ1) - KX(NZ1) = KX(JART) - KX(JART) = K - ELSE - CALL DSWAP ( NFREE, ZY(1,NZ1), 1, ZY(1,JART), 1 ) - END IF - - CALL DSWAP ( NGQ, GQ(NZ1,1), N, GQ(JART,1), N ) - IF (NRANK .GT. 0) - $ CALL CMRSWP( N, NRES, NRANK, NROWR, NZ1, JART, - $ R, RES, WORK ) - END IF - END IF - - RETURN - - 1000 FORMAT(/ ' //LSDEL // Artificial constraint deleted. ' - $ / ' //LSDEL // NZ NZ1 JART ' - $ / ' //LSDEL // ', 3I6 ) - 1100 FORMAT(/ ' //LSDEL // Simple bound deleted. ' - $ / ' //LSDEL // NACTIV NZ NFREE IR JDEL UNITQ' - $ / ' //LSDEL // ', 5I6, L6 ) - 1200 FORMAT(/ ' //LSDEL // General constraint deleted. ' - $ / ' //LSDEL // NACTIV NZ NFREE KDEL JDEL UNITQ' - $ / ' //LSDEL // ', 5I6, L6 ) - -* End of LSDEL . - - END
deleted file mode 100644 --- a/libcruft/npsol/lsdflt.f +++ /dev/null @@ -1,160 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSDFLT( M, N, NCLIN, TITLE ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - - CHARACTER*(*) TITLE - -************************************************************************ -* LSDFLT loads the default values of parameters not set by the user. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 77 version written 17-September-1985. -* This version of LSDFLT dated 9-September-1986. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - LOGICAL CMDBG, LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG - - LOGICAL NEWOPT - COMMON /SOL3LS/ NEWOPT - SAVE /SOL3LS/ - -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG) - - LOGICAL CDEFND - CHARACTER*4 ICRSH(0:2) - CHARACTER*3 LSTYPE(1:10) - CHARACTER*16 KEY - INTRINSIC LEN , MAX , MOD - PARAMETER ( ZERO = 0.0D+0, TEN = 10.0D+0) - PARAMETER ( RDUMMY = -11111., IDUMMY = -11111 ) - PARAMETER ( GIGANT = 1.0D+10*.99999 ) - PARAMETER ( WRKTOL = 1.0D-2 ) - DATA ICRSH(0), ICRSH(1), ICRSH(2) - $ /'COLD' ,'WARM' ,'HOT ' / - DATA LSTYPE(1), LSTYPE(2) - $ /' FP' ,' LP' / - DATA LSTYPE(3), LSTYPE(4), LSTYPE(5), LSTYPE(6) - $ /'QP1' ,'QP2' ,'QP3' ,'QP4' / - DATA LSTYPE(7), LSTYPE(8), LSTYPE(9), LSTYPE(10) - $ /'LS1' ,'LS2' ,'LS3' ,'LS4' / - - EPSMCH = WMACH( 3) - -* Make a dummy call to LSKEY to ensure that the defaults are set. - - CALL LSKEY ( NOUT, '*', KEY ) - NEWOPT = .TRUE. - -* Save the optional parameters set by the user. The values in -* RPRMLS and IPRMLS may be changed to their default values. - - CALL ICOPY ( MXPARM, IPRMLS, 1, IPSVLS, 1 ) - CALL DCOPY ( MXPARM, RPRMLS, 1, RPSVLS, 1 ) - - IF ( LPROB .LT. 0 ) LPROB = 7 - CDEFND = LPROB .EQ. 2*(LPROB/2) - IF ( LCRASH .LT. 0 - $ .OR. LCRASH .GT. 2 ) LCRASH = 0 - IF ( ITMAX1 .LT. 0 ) ITMAX1 = MAX(50, 5*(N+NCLIN)) - IF ( ITMAX2 .LT. 0 ) ITMAX2 = MAX(50, 5*(N+NCLIN)) - IF ( MSGLVL .EQ. IDUMMY ) MSGLVL = 10 - IF ( IDBG .LT. 0 - $ .OR. IDBG .GT. ITMAX1 + ITMAX2 - $ ) IDBG = 0 - IF ( MSGDBG .LT. 0 ) MSGDBG = 0 - IF ( MSGDBG .EQ. 0 ) IDBG = ITMAX1 + ITMAX2 + 1 - IF ( TOLACT .LT. ZERO ) TOLACT = WRKTOL - IF ( TOLFEA .EQ. RDUMMY - $ .OR. (TOLFEA .GE. ZERO - $ .AND. TOLFEA .LT. EPSMCH)) TOLFEA = EPSPT5 - IF ( TOLRNK .LE. ZERO - $ .AND. CDEFND ) TOLRNK = EPSPT5 - IF ( TOLRNK .LE. ZERO ) TOLRNK = TEN*EPSMCH - IF ( BIGBND .LE. ZERO ) BIGBND = GIGANT - IF ( BIGDX .LE. ZERO ) BIGDX = MAX(GIGANT, BIGBND) - - LSDBG = IDBG .EQ. 0 - CMDBG = LSDBG - K = 1 - MSG = MSGDBG - DO 200 I = 1, LDBG - ILSDBG(I) = MOD( MSG/K, 10 ) - ICMDBG(I) = ILSDBG(I) - K = K*10 - 200 CONTINUE - - IF (MSGLVL .GT. 0) THEN - -* Print the title. - - LENT = LEN( TITLE ) - IF (LENT .GT. 0) THEN - NSPACE = (81 - LENT)/2 + 1 - WRITE (NOUT, '(///// (80A1) )') - $ (' ', J=1, NSPACE), (TITLE(J:J), J=1,LENT) - WRITE (NOUT, '(80A1 //)') - $ (' ', J=1, NSPACE), ('=' , J=1,LENT) - END IF - - WRITE (NOUT, 2000) - WRITE (NOUT, 2100) LSTYPE(LPROB), - $ NCLIN , TOLFEA, ICRSH(LCRASH), - $ N , BIGBND, TOLACT, - $ M , BIGDX , TOLRNK - WRITE (NOUT, 2200) EPSMCH, ITMAX1, MSGLVL, - $ ITMAX2 - END IF - - RETURN - - 2000 FORMAT( - $//' Parameters' - $/ ' ----------' ) - 2100 FORMAT( - $/ ' Problem type...........', 7X, A3 - $/ ' Linear constraints.....', I10, 6X, - $ ' Feasibility tolerance..', 1PE10.2, 6X, - $ 1X, A4, ' start.............' - $/ ' Variables..............', I10, 6X, - $ ' Infinite bound size....', 1PE10.2, 6X, - $ ' Crash tolerance........', 1PE10.2 - $/ ' Objective matrix rows..', I10, 6X, - $ ' Infinite step size.....', 1PE10.2, 6X, - $ ' Rank tolerance.........', 1PE10.2 ) - 2200 FORMAT( - $/ ' EPS (machine precision)', 1PE10.2, 6X, - $ ' Feasibility phase itns.', I10, 6X, - $ ' Print level............', I10 - $/ 40X, - $ ' Optimality phase itns.', I10 ) - -* End of LSDFLT. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsfeas.f +++ /dev/null @@ -1,97 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSFEAS( N, NCLIN, ISTATE, - $ BIGBND, CVNORM, ERRMAX, JMAX, NVIOL, - $ AX, BL, BU, FEATOL, X, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER ISTATE(N+NCLIN) - DOUBLE PRECISION AX(*), BL(N+NCLIN), BU(N+NCLIN) - DOUBLE PRECISION FEATOL(N+NCLIN), X(N) - DOUBLE PRECISION WORK(N+NCLIN) - -************************************************************************ -* LSFEAS computes the following... -* (1) The number of constraints that are violated by more -* than FEATOL and the 2-norm of the constraint violations. -* -* Systems Optimization Laboratory, Stanford University. -* Original version April 1984. -* This version of LSFEAS dated 17-October-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL IDAMAX, DNRM2 - INTRINSIC ABS - PARAMETER ( ZERO = 0.0D+0 ) - - BIGLOW = - BIGBND - BIGUPP = BIGBND - -* ================================================================== -* Compute NVIOL, the number of constraints violated by more than -* FEATOL, and CVNORM, the 2-norm of the constraint violations and -* residuals of the constraints in the working set. -* ================================================================== - NVIOL = 0 - - DO 200 J = 1, N+NCLIN - FEASJ = FEATOL(J) - IS = ISTATE(J) - RES = ZERO - - IF (IS .GE. 0 .AND. IS .LT. 4) THEN - IF (J .LE. N) THEN - CON = X(J) - ELSE - I = J - N - CON = AX(I) - END IF - - TOLJ = FEASJ - -* Check for constraint violations. - - IF (BL(J) .GT. BIGLOW) THEN - RES = BL(J) - CON - IF (RES .GT. FEASJ ) NVIOL = NVIOL + 1 - IF (RES .GT. TOLJ ) GO TO 190 - END IF - - IF (BU(J) .LT. BIGUPP) THEN - RES = BU(J) - CON - IF (RES .LT. (-FEASJ)) NVIOL = NVIOL + 1 - IF (RES .LT. (-TOLJ)) GO TO 190 - END IF - -* This constraint is satisfied, but count the residual as a -* violation if the constraint is in the working set. - - IF (IS .LE. 0) RES = ZERO - IF (IS .EQ. 1) RES = BL(J) - CON - IF (IS .GE. 2) RES = BU(J) - CON - IF (ABS( RES ) .GT. FEASJ) NVIOL = NVIOL + 1 - END IF - 190 WORK(J) = RES - 200 CONTINUE - - JMAX = IDAMAX( N+NCLIN, WORK, 1 ) - ERRMAX = ABS ( WORK(JMAX) ) - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) ERRMAX, JMAX - - CVNORM = DNRM2 ( N+NCLIN, WORK, 1 ) - - RETURN - - 1000 FORMAT(/ ' //LSFEAS// The maximum violation is ', 1PE14.2, - $ ' in constraint', I5 ) - -* End of LSFEAS. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsfile.f +++ /dev/null @@ -1,54 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSFILE( IOPTNS, INFORM ) - INTEGER IOPTNS, INFORM - -************************************************************************ -* LSFILE reads the options file from unit IOPTNS and loads the -* options into the relevant elements of IPRMLS and RPRMLS. -* -* If IOPTNS .lt. 0 or IOPTNS .gt. 99 then no file is read, -* otherwise the file associated with unit IOPTNS is read. -* -* Output: -* -* INFORM = 0 if a complete OPTIONS file was found -* (starting with BEGIN and ending with END); -* 1 if IOPTNS .lt. 0 or IOPTNS .gt. 99; -* 2 if BEGIN was found, but end-of-file -* occurred before END was found; -* 3 if end-of-file occurred before BEGIN or -* ENDRUN were found; -* 4 if ENDRUN was found before BEGIN. -************************************************************************ - LOGICAL NEWOPT - COMMON /SOL3LS/ NEWOPT - SAVE /SOL3LS/ - - DOUBLE PRECISION WMACH(15) - COMMON /SOLMCH/ WMACH - SAVE /SOLMCH/ - - EXTERNAL MCHPAR, LSKEY - LOGICAL FIRST - SAVE FIRST , NOUT - DATA FIRST /.TRUE./ - -* If first time in, set NOUT. -* NEWOPT is true first time into LSFILE or LSOPTN -* and just after a call to LSSOL. - - IF (FIRST) THEN - FIRST = .FALSE. - NEWOPT = .TRUE. - CALL MCHPAR() - NOUT = WMACH(11) - END IF - - CALL OPFILE( IOPTNS, NOUT, INFORM, LSKEY ) - - RETURN - -* End of LSFILE. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsgetp.f +++ /dev/null @@ -1,129 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSGETP( LINOBJ, SINGLR, UNITGZ, UNITQ, - $ N, NCLIN, NFREE, - $ NROWA, NQ, NROWR, NRANK, NUMINF, NZ1, - $ ISTATE, KX, CTP, PNORM, - $ A, AP, RES, HZ, P, - $ GQ, CQ, R, ZY, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL LINOBJ, SINGLR, UNITGZ, UNITQ - INTEGER ISTATE(N+NCLIN), KX(N) - DOUBLE PRECISION A(NROWA,*), AP(*), RES(*), HZ(*), P(N), - $ GQ(N), CQ(*), R(NROWR,*), ZY(NQ,*) - DOUBLE PRECISION WORK(N) - -************************************************************************ -* LSGETP computes the following quantities for LSCORE. -* (1) The vector (hz1) = (Rz1)(pz1). -* If X is not yet feasible, the product is computed directly. -* If Rz1 is singular, hz1 is zero. Otherwise hz1 satisfies -* the equations -* Rz1'hz1 = -gz1, -* where g is the total gradient. If there is no linear term -* in the objective, hz1 is set to dz1 directly. -* (2) The search direction P (and its 2-norm). The vector P is -* defined as Z*(pz1), where (pz1) depends upon whether or -* not X is feasible and the nonsingularity of (Rz1). -* If NUMINF .GT. 0, (pz1) is the steepest-descent direction. -* Otherwise, x is the solution of the NZ1*NZ1 triangular -* system (Rz1)*(pz1) = (hz1). -* (3) The vector Ap, where A is the matrix of linear constraints. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* Level 2 Blas added 11-June-1986. -* This version of LSGETP dated 11-June-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL DDOT , DNRM2 - INTRINSIC MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - IF (SINGLR) THEN -* --------------------------------------------------------------- -* The triangular factor for the current objective function is -* singular, i.e., the objective is linear along the last column -* of Z1. This can only occur when UNITGZ is TRUE. -* --------------------------------------------------------------- - IF (NZ1 .GT. 1) THEN - CALL DCOPY ( NZ1-1, R(1,NZ1), 1, P, 1 ) - CALL DTRSV ( 'U', 'N', 'N', NZ1-1, R, NROWR, P, 1 ) - END IF - P(NZ1) = - ONE - - GTP = DDOT ( NZ1, GQ, 1, P, 1 ) - IF (GTP .GT. ZERO) CALL DSCAL ( NZ1, (-ONE), P, 1 ) - - IF (NZ1 .LE. NRANK) THEN - IF (NUMINF .EQ. 0) THEN - IF (UNITGZ) THEN - HZ(NZ1) = R(NZ1,NZ1)*P(NZ1) - ELSE - CALL DLOAD ( NZ1, (ZERO), HZ, 1 ) - END IF - ELSE - HZ(1) = R(1,1)*P(1) - END IF - END IF - ELSE -* --------------------------------------------------------------- -* The objective is quadratic in the space spanned by Z1. -* --------------------------------------------------------------- - IF (LINOBJ) THEN - IF (UNITGZ) THEN - IF (NZ1 .GT. 1) - $ CALL DLOAD ( NZ1-1, (ZERO), HZ, 1 ) - HZ(NZ1) = - GQ(NZ1)/R(NZ1,NZ1) - ELSE - CALL DCOPY ( NZ1, GQ , 1, HZ, 1 ) - CALL DSCAL ( NZ1, (-ONE), HZ, 1 ) - CALL DTRSV ( 'U', 'T', 'N', NZ1, R, NROWR, HZ, 1 ) - END IF - ELSE - CALL DCOPY ( NZ1, RES, 1, HZ, 1 ) - END IF - -* Solve Rz1*pz1 = hz1. - - CALL DCOPY ( NZ1, HZ, 1, P, 1 ) - CALL DTRSV ( 'U', 'N', 'N', NZ1, R, NROWR, P, 1 ) - END IF - -* Compute p = Z1*pz1 and its norm. - - IF (LINOBJ) - $ CTP = DDOT ( NZ1, CQ, 1, P, 1 ) - PNORM = DNRM2 ( NZ1, P, 1 ) - - CALL CMQMUL( 1, N, NZ1, NFREE, NQ, UNITQ, KX, P, ZY, WORK ) - - IF (LSDBG .AND. ILSDBG(2) .GT. 0) - $ WRITE (NOUT, 1000) (P(J), J = 1, N) - -* Compute Ap. - - IF (NCLIN .GT. 0) THEN - CALL DLOAD ( NCLIN, ZERO, AP, 1 ) - DO 410 J = 1, N - IF (ISTATE(J) .LE. 0) - $ CALL DAXPY( NCLIN, P(J), A(1,J), 1, AP, 1 ) - 410 CONTINUE - IF (LSDBG .AND. ILSDBG(2) .GT. 0) - $ WRITE (NOUT, 1100) (AP(I), I = 1, NCLIN) - END IF - - RETURN - - 1000 FORMAT(/ ' //LSGETP// P ... ' / (1P5E15.5)) - 1100 FORMAT(/ ' //LSGETP// AP ... ' / (1P5E15.5)) - -* End of LSGETP. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsgset.f +++ /dev/null @@ -1,146 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSGSET( PRBTYP, LINOBJ, SINGLR, UNITGZ, UNITQ, - $ N, NCLIN, NFREE, - $ NROWA, NQ, NROWR, NRANK, NZ, NZ1, - $ ISTATE, KX, - $ BIGBND, TOLRNK, NUMINF, SUMINF, - $ BL, BU, A, RES, FEATOL, - $ GQ, CQ, R, X, WTINF, ZY, WRK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*2 PRBTYP - LOGICAL LINOBJ, SINGLR, UNITGZ, UNITQ - INTEGER ISTATE(*), KX(N) - DOUBLE PRECISION BL(*), BU(*), A(NROWA,*), - $ RES(*), FEATOL(*) - DOUBLE PRECISION GQ(N), CQ(*), R(NROWR,*), X(N), WTINF(*), - $ ZY(NQ,*) - DOUBLE PRECISION WRK(N) - -************************************************************************ -* LSGSET finds the number and weighted sum of infeasibilities for -* the bounds and linear constraints. An appropriate transformed -* gradient vector is returned in GQ. -* -* Positive values of ISTATE(j) will not be altered. These mean -* the following... -* -* 1 2 3 -* a'x = bl a'x = bu bl = bu -* -* Other values of ISTATE(j) will be reset as follows... -* a'x lt bl a'x gt bu a'x free -* - 2 - 1 0 -* -* If x is feasible, LSGSET computes the vector Q(free)'g(free), -* where g is the gradient of the the sum of squares plus the -* linear term. The matrix Q is of the form -* ( Q(free) 0 ), -* ( 0 I(fixed)) -* where Q(free) is the orthogonal factor of A(free) and A is -* the matrix of constraints in the working set. The transformed -* gradients are stored in GQ. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* Level 2 Blas added 11-June-1986. -* This version of LSGSET dated 24-June-1986. -************************************************************************ - EXTERNAL DDOT , IDRANK - INTRINSIC ABS , MAX , MIN - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) - - BIGUPP = BIGBND - BIGLOW = - BIGBND - - NUMINF = 0 - SUMINF = ZERO - CALL DLOAD ( N, ZERO, GQ, 1 ) - - DO 200 J = 1, N+NCLIN - IF (ISTATE(J) .LE. 0) THEN - FEASJ = FEATOL(J) - IF (J .LE. N) THEN - CTX = X(J) - ELSE - K = J - N - CTX = DDOT ( N, A(K,1), NROWA, X, 1 ) - END IF - ISTATE(J) = 0 - -* See if the lower bound is violated. - - IF (BL(J) .GT. BIGLOW) THEN - S = BL(J) - CTX - IF (S .GT. FEASJ ) THEN - ISTATE(J) = - 2 - WEIGHT = - WTINF(J) - GO TO 160 - END IF - END IF - -* See if the upper bound is violated. - - IF (BU(J) .GE. BIGUPP) GO TO 200 - S = CTX - BU(J) - IF (S .LE. FEASJ ) GO TO 200 - ISTATE(J) = - 1 - WEIGHT = WTINF(J) - -* Add the infeasibility. - - 160 NUMINF = NUMINF + 1 - SUMINF = SUMINF + ABS( WEIGHT ) * S - IF (J .LE. N) THEN - GQ(J) = WEIGHT - ELSE - CALL DAXPY ( N, WEIGHT, A(K,1), NROWA, GQ, 1 ) - END IF - END IF - 200 CONTINUE - -* ------------------------------------------------------------------ -* Install GQ, the transformed gradient. -* ------------------------------------------------------------------ - SINGLR = .FALSE. - UNITGZ = .TRUE. - - IF (NUMINF .GT. 0) THEN - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, GQ, ZY, WRK ) - ELSE IF (NUMINF .EQ. 0 .AND. PRBTYP .EQ. 'FP') THEN - CALL DLOAD ( N, ZERO, GQ, 1 ) - ELSE - -* Ready for the Optimality Phase. -* Set NZ1 so that Rz1 is nonsingular. - - IF (NRANK .EQ. 0) THEN - IF (LINOBJ) THEN - CALL DCOPY ( N, CQ, 1, GQ, 1 ) - ELSE - CALL DLOAD ( N, ZERO, GQ, 1 ) - END IF - NZ1 = 0 - ELSE - -* Compute GQ = - R' * (transformed residual) - - CALL DCOPY ( NRANK, RES, 1, GQ, 1 ) - CALL DSCAL ( NRANK, (-ONE), GQ, 1 ) - CALL DTRMV ( 'U', 'T', 'N', NRANK, R, NROWR, GQ, 1 ) - IF (NRANK .LT. N) - $ CALL DGEMV( 'T', NRANK, N-NRANK, -ONE,R(1,NRANK+1),NROWR, - $ RES, 1, ZERO, GQ(NRANK+1), 1 ) - - IF (LINOBJ) CALL DAXPY ( N, ONE, CQ, 1, GQ, 1 ) - UNITGZ = .FALSE. - NZ1 = IDRANK( MIN(NRANK, NZ), R, NROWR+1, TOLRNK ) - END IF - END IF - - RETURN - -* End of LSGSET. - - END
deleted file mode 100644 --- a/libcruft/npsol/lskey.f +++ /dev/null @@ -1,283 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSKEY ( NOUT, BUFFER, KEY ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*(*) BUFFER - -************************************************************************ -* LSKEY decodes the option contained in BUFFER in order to set -* a parameter value in the relevant element of IPRMLS or RPRMLS. -* -* -* Input: -* -* NOUT A unit number for printing error messages. -* NOUT must be a valid unit. -* -* Output: -* -* KEY The first keyword contained in BUFFER. -* -* -* LSKEY calls OPNUMB and the subprograms -* LOOKUP, SCANNR, TOKENS, UPCASE -* (now called OPLOOK, OPSCAN, OPTOKN, OPUPPR) -* supplied by Informatics General, Inc., Palo Alto, California. -* -* Systems Optimization Laboratory, Stanford University. -* This version dated Jan 22, 1986. -************************************************************************ -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- - - EXTERNAL OPNUMB - LOGICAL FIRST , MORE , NUMBER, OPNUMB, SORTED - SAVE FIRST - - PARAMETER ( MAXKEY = 27, MAXTIE = 10, MAXTOK = 10, - $ MAXTYP = 16) - CHARACTER*16 KEYS(MAXKEY), TIES(MAXTIE), TOKEN(MAXTOK), - $ TYPE(MAXTYP) - CHARACTER*16 KEY, KEY2, KEY3, VALUE - - PARAMETER (IDUMMY = -11111, RDUMMY = -11111.0, - $ SORTED = .TRUE., ZERO = 0.0 ) - - DATA FIRST - $ /.TRUE./ - DATA KEYS - $ / 'BEGIN ', - $ 'COLD ', 'CONSTRAINTS ', 'CRASH ', - $ 'DEBUG ', 'DEFAULTS ', 'END ', - $ 'FEASIBILITY ', 'HOT ', 'INFINITE ', - $ 'IPRMLS ', 'ITERATIONS ', 'ITERS:ITERATIONS', - $ 'ITNS :ITERATIONS', 'LINEAR ', 'LIST ', - $ 'LOWER ', 'NOLIST ', 'OPTIMALITY ', - $ 'PRINT ', 'PROBLEM ', 'RANK ', - $ 'RPRMLS ', 'START ', 'UPPER ', - $ 'VARIABLES ', 'WARM '/ - - DATA TIES - $ / 'BOUND ', 'CONSTRAINTS ', - $ 'NO ', 'NO. :NUMBER', 'NUMBER ', - $ 'PHASE ', 'STEP ', - $ 'TOLERANCE ', 'TYPE ', 'YES '/ - - DATA TYPE - $ / 'FP ', - $ 'LEAST :LS1', 'LINEAR :LP', 'LP ', - $ 'LS :LS1', 'LS1 ', 'LS2 ', - $ 'LS3 ', 'LS4 ', 'LSQ :LS1', - $ 'QP :QP2', 'QP1 ', 'QP2 ', - $ 'QP3 ', 'QP4 ', 'QUADRATIC :QP2'/ -*----------------------------------------------------------------------- - - IF (FIRST) THEN - FIRST = .FALSE. - DO 10 I = 1, MXPARM - IPRMLS(I) = IDUMMY - RPRMLS(I) = RDUMMY - 10 CONTINUE - END IF - -* Eliminate comments and empty lines. -* A '*' appearing anywhere in BUFFER terminates the string. - - I = INDEX( BUFFER, '*' ) - IF (I .EQ. 0) THEN - LENBUF = LEN( BUFFER ) - ELSE - LENBUF = I - 1 - END IF - IF (LENBUF .LE. 0) THEN - KEY = '*' - GO TO 900 - END IF - -* ------------------------------------------------------------------ -* Extract up to MAXTOK tokens from the record. -* NTOKEN returns how many were actually found. -* KEY, KEY2, KEY3 are the first tokens if any, otherwise blank. -* ------------------------------------------------------------------ - NTOKEN = MAXTOK - CALL OPTOKN( BUFFER(1:LENBUF), NTOKEN, TOKEN ) - KEY = TOKEN(1) - KEY2 = TOKEN(2) - KEY3 = TOKEN(3) - -* Certain keywords require no action. - - IF (KEY .EQ. ' ' .OR. KEY .EQ. 'BEGIN' ) GO TO 900 - IF (KEY .EQ. 'LIST' .OR. KEY .EQ. 'NOLIST') GO TO 900 - IF (KEY .EQ. 'END' ) GO TO 900 - -* Most keywords will have an associated integer or real value, -* so look for it no matter what the keyword. - - I = 1 - NUMBER = .FALSE. - - 50 IF (I .LT. NTOKEN .AND. .NOT. NUMBER) THEN - I = I + 1 - VALUE = TOKEN(I) - NUMBER = OPNUMB( VALUE ) - GO TO 50 - END IF - - IF (NUMBER) THEN - READ (VALUE, '(BN, E16.0)') RVALUE - ELSE - RVALUE = ZERO - END IF - -* Convert the keywords to their most fundamental form -* (upper case, no abbreviations). -* SORTED says whether the dictionaries are in alphabetic order. -* LOCi says where the keywords are in the dictionaries. -* LOCi = 0 signals that the keyword wasn't there. - - CALL OPLOOK( MAXKEY, KEYS, SORTED, KEY , LOC1 ) - CALL OPLOOK( MAXTIE, TIES, SORTED, KEY2, LOC2 ) - -* ------------------------------------------------------------------ -* Decide what to do about each keyword. -* The second keyword (if any) might be needed to break ties. -* Some seemingly redundant testing of MORE is used -* to avoid compiler limits on the number of consecutive ELSE IFs. -* ------------------------------------------------------------------ - MORE = .TRUE. - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'COLD ') THEN - LCRASH = 0 - ELSE IF (KEY .EQ. 'CONSTRAINTS ') THEN - NNCLIN = RVALUE - ELSE IF (KEY .EQ. 'CRASH ') THEN - TOLACT = RVALUE - ELSE IF (KEY .EQ. 'DEBUG ') THEN - LDBGLS = RVALUE - ELSE IF (KEY .EQ. 'DEFAULTS ') THEN - DO 20 I = 1, MXPARM - IPRMLS(I) = IDUMMY - RPRMLS(I) = RDUMMY - 20 CONTINUE - ELSE IF (KEY .EQ. 'FEASIBILITY ') THEN - IF (KEY2.EQ. 'PHASE ') ITMAX1 = RVALUE - IF (KEY2.EQ. 'TOLERANCE ') TOLFEA = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'HOT ') THEN - LCRASH = 2 - ELSE IF (KEY .EQ. 'INFINITE ') THEN - IF (KEY2.EQ. 'BOUND ') BIGBND = RVALUE * 0.99999 - IF (KEY2.EQ. 'STEP ') BIGDX = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'IPRMLS ') THEN -* Allow things like IPRMLS 21 = 100 to set IPRMLS(21) = 100 - IVALUE = RVALUE - IF (IVALUE .GE. 1 .AND. IVALUE .LE. MXPARM) THEN - READ (KEY3, '(BN, I16)') IPRMLS(IVALUE) - ELSE - WRITE(NOUT, 2400) IVALUE - END IF - ELSE IF (KEY .EQ. 'ITERATIONS ') THEN - ITMAX2 = RVALUE - ELSE IF (KEY .EQ. 'LINEAR ') THEN - NNCLIN = RVALUE - ELSE IF (KEY .EQ. 'LOWER ') THEN - BNDLOW = RVALUE - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'OPTIMALITY ') THEN - ITMAX2 = RVALUE - ELSE IF (KEY .EQ. 'PROBLEM ') THEN - IF (KEY2 .EQ. 'NUMBER') THEN - NPROB = RVALUE - ELSE IF (KEY2 .EQ. 'TYPE ') THEN - -* Recognize Problem type = LP etc. - - CALL OPLOOK( MAXTYP, TYPE, SORTED, KEY3, LOC3 ) - IF (KEY3 .EQ. 'FP' ) LPROB = 1 - IF (KEY3 .EQ. 'LP' ) LPROB = 2 - IF (KEY3 .EQ. 'QP1') LPROB = 3 - IF (KEY3 .EQ. 'QP2') LPROB = 4 - IF (KEY3 .EQ. 'QP3') LPROB = 5 - IF (KEY3 .EQ. 'QP4') LPROB = 6 - IF (KEY3 .EQ. 'LS1') LPROB = 7 - IF (KEY3 .EQ. 'LS2') LPROB = 8 - IF (KEY3 .EQ. 'LS3') LPROB = 9 - IF (KEY3 .EQ. 'LS4') LPROB = 10 - IF (LOC3 .EQ. 0 ) WRITE(NOUT, 2330) KEY3 - ELSE - WRITE(NOUT, 2320) KEY2 - END IF - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'PRINT ') THEN - MSGLS = RVALUE - ELSE IF (KEY .EQ. 'RANK ') THEN - TOLRNK = RVALUE - ELSE IF (KEY .EQ. 'RPRMLS ') THEN -* Allow things like RPRMLS 21 = 2 to set RPRMLS(21) = 2.0 - IVALUE = RVALUE - IF (IVALUE .GE. 1 .AND. IVALUE .LE. MXPARM) THEN - READ (KEY3, '(BN, E16.0)') RPRMLS(IVALUE) - ELSE - WRITE(NOUT, 2400) IVALUE - END IF - ELSE IF (KEY .EQ. 'START ') THEN - IDBGLS = RVALUE - ELSE IF (KEY .EQ. 'UPPER ') THEN - BNDUPP = RVALUE - ELSE IF (KEY .EQ. 'VARIABLES ') THEN - NN = RVALUE - ELSE IF (KEY .EQ. 'WARM ') THEN - LCRASH = 1 - ELSE - WRITE(NOUT, 2300) KEY - END IF - END IF - - 900 RETURN - - 2300 FORMAT(' XXX Keyword not recognized: ', A) - 2320 FORMAT(' XXX Second keyword not recognized: ', A) - 2330 FORMAT(' XXX Third keyword not recognized: ', A) - 2400 FORMAT(' XXX The PARM subscript is out of range:', I10) - -* End of LSKEY - - END
deleted file mode 100644 --- a/libcruft/npsol/lsloc.f +++ /dev/null @@ -1,90 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSLOC ( LPROB, N, NCLIN, LITOTL, LWTOTL ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - -************************************************************************ -* LSLOC allocates the addresses of the work arrays for LSCORE. -* -* Note that the arrays ( GQ, CQ ) and ( RES, RES0, HZ ) lie in -* contiguous areas of workspace. -* RES, RES0 and HZ are not needed for LP. -* CQ is defined when the objective has an explicit linear term. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 29-October-1984. -* This version of LSLOC dated 16-February-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT, NCOLT, NQ - - PARAMETER ( LENLS = 20 ) - COMMON /SOL1LS/ LOCLS(LENLS) - - LOGICAL LSDBG - PARAMETER ( LDBG = 5 ) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - MINIW = LITOTL + 1 - MINW = LWTOTL + 1 - - -* Assign array lengths that depend upon the problem dimensions. - - IF (NCLIN .EQ. 0) THEN - LENT = 0 - LENZY = 0 - ELSE - LENT = NROWT*NCOLT - LENZY = NQ *NQ - END IF - - LENCQ = 0 - IF (LPROB .EQ. 2*(LPROB/2)) LENCQ = N - LENRES = 0 - IF (LPROB .GT. 2 ) LENRES = N - - LKACTV = MINIW - MINIW = LKACTV + N - - LANORM = MINW - LAP = LANORM + NCLIN - LPX = LAP + NCLIN - LGQ = LPX + N - LCQ = LGQ + N - LRES = LCQ + LENCQ - LRES0 = LRES + LENRES - LHZ = LRES0 + LENRES - LRLAM = LHZ + LENRES - LT = LRLAM + N - LZY = LT + LENT - LWTINF = LZY + LENZY - LWRK = LWTINF + N + NCLIN - LFEATL = LWRK + N + NCLIN - MINW = LFEATL + N + NCLIN - - LOCLS( 1) = LKACTV - LOCLS( 2) = LANORM - LOCLS( 3) = LAP - LOCLS( 4) = LPX - LOCLS( 5) = LRES - LOCLS( 6) = LRES0 - LOCLS( 7) = LHZ - LOCLS( 8) = LGQ - LOCLS( 9) = LCQ - LOCLS(10) = LRLAM - LOCLS(11) = LT - LOCLS(12) = LZY - LOCLS(13) = LWTINF - LOCLS(14) = LWRK - LOCLS(15) = LFEATL - - LITOTL = MINIW - 1 - LWTOTL = MINW - 1 - - RETURN - -* End of LSLOC . - - END
deleted file mode 100644 --- a/libcruft/npsol/lsmove.f +++ /dev/null @@ -1,83 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSMOVE( HITCON, HITLOW, LINOBJ, UNITGZ, - $ NCLIN, NRANK, NZ1, - $ N, NROWR, JADD, NUMINF, - $ ALFA, CTP, CTX, XNORM, - $ AP, AX, BL, BU, GQ, HZ, P, RES, - $ R, X, WORK ) - - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - LOGICAL HITCON, HITLOW, LINOBJ, UNITGZ - DOUBLE PRECISION AP(*), AX(*), BL(*), BU(*), GQ(*), HZ(*), - $ P(N), RES(*), R(NROWR,*), X(N) - DOUBLE PRECISION WORK(*) - -************************************************************************ -* LSMOVE changes X to X + ALFA*P and updates CTX, AX, RES and GQ -* accordingly. -* -* If a bound was added to the working set, move X exactly on to it, -* except when a negative step was taken (CMALF may have had to move -* to some other closer constraint.) -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 27-December-1985. -* Level 2 BLAS added 11-June-1986. -* This version of LSMOVE dated 11-June-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL DDOT , DNRM2 - INTRINSIC ABS , MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - CALL DAXPY ( N, ALFA, P, 1, X, 1 ) - IF (LINOBJ) CTX = CTX + ALFA*CTP - - IF (HITCON .AND. JADD .LE. N) THEN - BND = BU(JADD) - IF (HITLOW) BND = BL(JADD) - IF (ALFA .GE. ZERO) X(JADD) = BND - END IF - XNORM = DNRM2 ( N, X, 1 ) - - IF (NCLIN .GT. 0) - $ CALL DAXPY ( NCLIN, ALFA, AP, 1, AX, 1 ) - - IF (NZ1 .LE. NRANK) THEN - IF (UNITGZ) THEN - RES(NZ1) = RES(NZ1) - ALFA*HZ(NZ1) - ELSE - CALL DAXPY ( NZ1, (-ALFA), HZ, 1, RES, 1 ) - END IF - - IF (NUMINF .EQ. 0) THEN - -* Update the transformed gradient GQ so that -* GQ = GQ + ALFA*R'( HZ ). -* ( 0 ) - - IF (UNITGZ) THEN - CALL DAXPY ( N-NZ1+1, ALFA*HZ(NZ1), R(NZ1,NZ1), NROWR, - $ GQ(NZ1) , 1 ) - ELSE - CALL DCOPY ( NZ1, HZ, 1, WORK, 1 ) - CALL DTRMV ( 'U', 'T', 'N', NZ1, R, NROWR, WORK, 1 ) - IF (NZ1 .LT. N) - $ CALL DGEMV ( 'T', NZ1, N-NZ1, ONE, R(1,NZ1+1), NROWR, - $ HZ, 1, ZERO, WORK(NZ1+1), 1 ) - CALL DAXPY ( N, ALFA, WORK, 1, GQ, 1 ) - END IF - END IF - END IF - - RETURN - -* End of LSMOVE. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsmuls.f +++ /dev/null @@ -1,196 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSMULS( PRBTYP, - $ MSGLVL, N, NACTIV, NFREE, - $ NROWA, NROWT, NUMINF, NZ, NZ1, - $ ISTATE, KACTIV, KX, DINKY, - $ JSMLST, KSMLST, JINF, JTINY, - $ JBIGST, KBIGST, TRULAM, - $ A, ANORMS, GQ, RLAMDA, T, WTINF ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*2 PRBTYP - INTEGER ISTATE(*), KACTIV(N), KX(N) - DOUBLE PRECISION A(NROWA,*), ANORMS(*), - $ GQ(N), RLAMDA(N), T(NROWT,*), WTINF(*) - -************************************************************************ -* LSMULS first computes the Lagrange multiplier estimates for the -* given working set. It then determines the values and indices of -* certain significant multipliers. In this process, the multipliers -* for inequalities at their upper bounds are adjusted so that a -* negative multiplier for an inequality constraint indicates non- -* optimality. All adjusted multipliers are scaled by the 2-norm -* of the associated constraint row. In the following, the term -* minimum refers to the ordering of numbers on the real line, and -* not to their magnitude. -* -* JSMLST is the index of the minimum of the set of adjusted -* multipliers with values less than - DINKY. A negative -* JSMLST defines the index in Q'g of the artificial -* constraint to be deleted. -* KSMLST marks the position of general constraint JSMLST in KACTIV. -* -* JBIGST is the index of the largest of the set of adjusted -* multipliers with values greater than (1 + DINKY). -* KBIGST marks its position in KACTIV. -* -* On exit, elements 1 thru NACTIV of RLAMDA contain the unadjusted -* multipliers for the general constraints. Elements NACTIV onwards -* of RLAMDA contain the unadjusted multipliers for the bounds. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version of LSMULS dated 30-June-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - INTRINSIC ABS, MIN - PARAMETER ( ZERO =0.0D+0,ONE =1.0D+0 ) - - NFIXED = N - NFREE - - JSMLST = 0 - KSMLST = 0 - SMLLST = - DINKY - - TINYLM = DINKY - JTINY = 0 - - JBIGST = 0 - KBIGST = 0 - BIGGST = ONE + DINKY - - IF (NZ1 .LT. NZ) THEN -* --------------------------------------------------------------- -* Compute JSMLST for the artificial constraints. -* --------------------------------------------------------------- - DO 100 J = NZ1+1, NZ - RLAM = - ABS( GQ(J) ) - IF (RLAM .LT. SMLLST) THEN - SMLLST = RLAM - JSMLST = - J - ELSE IF (RLAM .LT. TINYLM) THEN - TINYLM = RLAM - JTINY = J - END IF - 100 CONTINUE - - IF (MSGLVL .GE. 20) - $ WRITE (NOUT, 1000) (GQ(K), K=NZ1+1,NZ) - - END IF - -* ------------------------------------------------------------------ -* Compute JSMLST for regular constraints and temporary bounds. -* ------------------------------------------------------------------ -* First, compute the Lagrange multipliers for the general -* constraints in the working set, by solving T'*lamda = Y'g. - - IF (N .GT. NZ) - $ CALL DCOPY ( N-NZ, GQ(NZ+1), 1, RLAMDA, 1 ) - IF (NACTIV .GT. 0) - $ CALL CMTSOL( 2, NROWT, NACTIV, T(1,NZ+1), RLAMDA ) - -* ----------------------------------------------------------------- -* Now set elements NACTIV, NACTIV+1,... of RLAMDA equal to -* the multipliers for the bound constraints. -* ----------------------------------------------------------------- - DO 190 L = 1, NFIXED - J = KX(NFREE+L) - BLAM = RLAMDA(NACTIV+L) - DO 170 K = 1, NACTIV - I = KACTIV(K) - BLAM = BLAM - A(I,J)*RLAMDA(K) - 170 CONTINUE - RLAMDA(NACTIV+L) = BLAM - 190 CONTINUE - -* ----------------------------------------------------------------- -* Find JSMLST and KSMLST. -* ----------------------------------------------------------------- - DO 330 K = 1, N - NZ - IF (K .GT. NACTIV) THEN - J = KX(NZ+K) - ELSE - J = KACTIV(K) + N - END IF - - IS = ISTATE(J) - - I = J - N - IF (J .LE. N) ANORMJ = ONE - IF (J .GT. N) ANORMJ = ANORMS(I) - - RLAM = RLAMDA(K) - -* Change the sign of the estimate if the constraint is in -* the working set at its upper bound. - - IF (IS .EQ. 2) RLAM = - RLAM - IF (IS .EQ. 3) RLAM = ABS( RLAM ) - IF (IS .EQ. 4) RLAM = - ABS( RLAM ) - - IF (IS .NE. 3) THEN - SCDLAM = RLAM * ANORMJ - IF (SCDLAM .LT. SMLLST) THEN - SMLLST = SCDLAM - JSMLST = J - KSMLST = K - ELSE IF (SCDLAM .LT. TINYLM) THEN - TINYLM = SCDLAM - JTINY = J - END IF - END IF - - IF (NUMINF .GT. 0 .AND. J .GT. JINF) THEN - SCDLAM = RLAM/WTINF(J) - IF (SCDLAM .GT. BIGGST) THEN - BIGGST = SCDLAM - TRULAM = RLAMDA(K) - JBIGST = J - KBIGST = K - END IF - END IF - 330 CONTINUE - -* ----------------------------------------------------------------- -* If required, print the multipliers. -* ----------------------------------------------------------------- - IF (MSGLVL .GE. 20) THEN - IF (NFIXED .GT. 0) - $ WRITE (NOUT, 1100) PRBTYP, (KX(NFREE+K), - $ RLAMDA(NACTIV+K), K=1,NFIXED) - IF (NACTIV .GT. 0) - $ WRITE (NOUT, 1200) PRBTYP, (KACTIV(K), - $ RLAMDA(K), K=1,NACTIV) - END IF - - IF (LSDBG .AND. ILSDBG(1) .GT. 0) THEN - WRITE (NOUT, 9000) JSMLST, SMLLST, KSMLST - WRITE (NOUT, 9100) JBIGST, BIGGST, KBIGST - WRITE (NOUT, 9200) JTINY , TINYLM - END IF - - RETURN - - 1000 FORMAT(/ ' Multipliers for the artificial constraints ' - $ / 4(5X, 1PE11.2)) - 1100 FORMAT(/ ' Multipliers for the ', A2, ' bound constraints ' - $ / 4(I5, 1PE11.2)) - 1200 FORMAT(/ ' Multipliers for the ', A2, ' linear constraints ' - $ / 4(I5, 1PE11.2)) - 9000 FORMAT(/ ' //LSMULS// JSMLST SMLLST KSMLST (Scaled) ' - $ / ' //LSMULS// ', I6, 1PE11.2, 5X, I6 ) - 9100 FORMAT( ' //LSMULS// JBIGST BIGGST KBIGST (Scaled) ' - $ / ' //LSMULS// ', I6, 1PE11.2, 5X, I6 ) - 9200 FORMAT( ' //LSMULS// JTINY TINYLM ' - $ / ' //LSMULS// ', I6, 1PE11.2) - -* End of LSMULS. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsoptn.f +++ /dev/null @@ -1,68 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSOPTN( STRING ) - CHARACTER*(*) STRING - -************************************************************************ -* LSOPTN loads the option supplied in STRING into the relevant -* element of IPRMLS or RPRMLS. -************************************************************************ - - LOGICAL NEWOPT - COMMON /SOL3LS/ NEWOPT - SAVE /SOL3LS/ - - DOUBLE PRECISION WMACH(15) - COMMON /SOLMCH/ WMACH - SAVE /SOLMCH/ - - EXTERNAL MCHPAR - CHARACTER*16 KEY - CHARACTER*72 BUFFER - LOGICAL FIRST , PRNT - SAVE FIRST , NOUT , PRNT - DATA FIRST /.TRUE./ - -* If first time in, set NOUT. -* NEWOPT is true first time into LSFILE or LSOPTN -* and just after a call to LSSOL. -* PRNT is set to true whenever NEWOPT is true. - - IF (FIRST) THEN - FIRST = .FALSE. - NEWOPT = .TRUE. - CALL MCHPAR() - NOUT = WMACH(11) - END IF - BUFFER = STRING - -* Call LSKEY to decode the option and set the parameter value. -* If NEWOPT is true, reset PRNT and test specially for NOLIST. - - IF (NEWOPT) THEN - NEWOPT = .FALSE. - PRNT = .TRUE. - CALL LSKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'NOLIST') THEN - PRNT = .FALSE. - ELSE - WRITE (NOUT, '(// A / A /)') - $ ' Calls to LSOPTN', - $ ' ---------------' - WRITE (NOUT, '( 6X, A )') BUFFER - END IF - ELSE - IF (PRNT) - $ WRITE (NOUT, '( 6X, A )') BUFFER - CALL LSKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'LIST') PRNT = .TRUE. - IF (KEY .EQ. 'NOLIST') PRNT = .FALSE. - END IF - - RETURN - -* End of LSOPTN. - - END
deleted file mode 100644 --- a/libcruft/npsol/lsprt.f +++ /dev/null @@ -1,151 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSPRT ( PRBTYP, PRNT1, ISDEL, ITER, JADD, JDEL, - $ MSGLVL, NACTIV, NFREE, N, NCLIN, - $ NRANK, NROWR, NROWT, NZ, NZ1, ISTATE, - $ ALFA, CONDRZ, CONDT, GFNORM, GZNORM, GZ1NRM, - $ NUMINF, SUMINF, CTX, SSQ, - $ AX, R, T, X, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*2 PRBTYP - LOGICAL PRNT1 - INTEGER ISTATE(*) - DOUBLE PRECISION AX(*), R(NROWR,*), T(NROWT,*), X(N) - DOUBLE PRECISION WORK(N) - -************************************************************************ -* LSPRT prints various levels of output for LSCORE. -* -* Msg Cumulative result -* --- ----------------- -* -* le 0 no output. -* -* eq 1 nothing now (but full output later). -* -* eq 5 one terse line of output. -* -* ge 10 same as 5 (but full output later). -* -* ge 20 constraint status, x and Ax. -* -* ge 30 diagonals of T and R. -* -* -* Debug printing is performed depending on the logical variable LSDBG. -* LSDBG is set true when IDBG major iterations have been performed. -* At this point, printing is done according to a string of binary -* digits of the form SVT (stored in the integer array ILSDBG). -* -* S set 'on' gives information from the maximum step routine CMALF. -* V set 'on' gives various vectors in LSCORE and its auxiliaries. -* T set 'on' gives a trace of which routine was called and an -* indication of the progress of the run. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version of LSPRT dated 14-January-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - CHARACTER*2 LADD, LDEL - CHARACTER*2 LSTATE(0:5) - DATA LSTATE(0), LSTATE(1), LSTATE(2) - $ /' ' , 'L ' , 'U ' / - DATA LSTATE(3), LSTATE(4), LSTATE(5) - $ /'E ' , 'T ' , 'Z ' / - - IF (MSGLVL .GE. 15) WRITE (NOUT, 1000) PRBTYP, ITER - - IF (MSGLVL .GE. 5) THEN - IF (JDEL .GT. 0) THEN - KDEL = ISDEL - ELSE IF (JDEL .LT. 0) THEN - JDEL = - JDEL - KDEL = 5 - ELSE - KDEL = 0 - END IF - - IF (JADD .GT. 0) THEN - KADD = ISTATE(JADD) - ELSE - KADD = 0 - END IF - - LDEL = LSTATE(KDEL) - LADD = LSTATE(KADD) - - IF (NUMINF .GT. 0) THEN - OBJ = SUMINF - ELSE - OBJ = SSQ + CTX - END IF - -* --------------------------------------------------------------- -* Print the terse line. -* --------------------------------------------------------------- - IF (NRANK .EQ. 0) THEN - IF (PRNT1 .OR. MSGLVL .GE. 15) WRITE (NOUT, 1100) - WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - $ ALFA, NUMINF, OBJ, N-NFREE, NACTIV, - $ NZ, NZ1, GFNORM, GZ1NRM, CONDT - ELSE - IF (PRNT1 .OR. MSGLVL .GE. 15) WRITE (NOUT, 1110) - WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - $ ALFA, NUMINF, OBJ, N-NFREE, NACTIV, - $ NZ, NZ1, GFNORM, GZ1NRM, CONDT, CONDRZ - END IF - - IF (MSGLVL .GE. 20) THEN - WRITE (NOUT, 2000) PRBTYP - WRITE (NOUT, 2100) (X(J) , ISTATE(J) , J=1,N) - IF (NCLIN .GT. 0) - $ WRITE (NOUT, 2200) (AX(K), ISTATE(N+K), K=1,NCLIN ) - - IF (MSGLVL .GE. 30) THEN -* --------------------------------------------------------- -* Print the diagonals of T and R. -* --------------------------------------------------------- - IF (NACTIV .GT. 0) THEN - CALL DCOPY ( NACTIV, T(NACTIV,NZ+1), NROWT-1, WORK,1 ) - WRITE (NOUT, 3000) PRBTYP, (WORK(J), J=1,NACTIV) - END IF - IF (NRANK .GT. 0) - $ WRITE (NOUT, 3100) PRBTYP, (R(J,J) , J=1,NRANK ) - END IF - WRITE (NOUT, 5000) - END IF - END IF - - PRNT1 = .FALSE. - - RETURN - - 1000 FORMAT(/// ' ', A2, ' iteration', I5 - $ / ' =================' ) - 1100 FORMAT(// ' Itn Jdel Jadd Step', - $ ' Ninf Sinf/Objective', ' Bnd', ' Lin', ' Nz', - $ ' Nz1 Norm Gf Norm Gz1 Cond T' ) - 1110 FORMAT(// ' Itn Jdel Jadd Step', - $ ' Ninf Sinf/Objective', ' Bnd', ' Lin', ' Nz', - $ ' Nz1 Norm Gf Norm Gz1 Cond T Cond Rz1' ) - 1200 FORMAT(I5, I5, A1, I5, A1, 1PE9.1, I5, 1X, 1PE15.6, 2I5, - $ 2I6, 1P2E10.2, 1P2E9.1 ) - 2000 FORMAT(/ ' Values and status of the ', A2, ' constraints' - $ / ' ---------------------------------------' ) - 2100 FORMAT(/ ' Variables...' / (1X, 5(1PE15.6, I5))) - 2200 FORMAT(/ ' General linear constraints...'/ (1X, 5(1PE15.6, I5))) - 3000 FORMAT(/ ' Diagonals of ' , A2,' working set factor T'/(1P5E15.6)) - 3100 FORMAT(/ ' Diagonals of ' , A2, ' triangle R '/(1P5E15.6)) - 5000 FORMAT(/// ' ---------------------------------------------------', - $ '--------------------------------------------' ) - -* End of LSPRT . - - END
deleted file mode 100644 --- a/libcruft/npsol/lssetx.f +++ /dev/null @@ -1,152 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSSETX( LINOBJ, ROWERR, UNITQ, - $ NCLIN, NACTIV, NFREE, NRANK, NZ, - $ N, NCTOTL, NQ, NROWA, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ JMAX, ERRMAX, CTX, XNORM, - $ A, AX, BL, BU, CQ, RES, RES0, FEATOL, - $ R, T, X, ZY, P, WORK ) - - IMPLICIT DOUBLE PRECISION (A-H,O-Z) - LOGICAL LINOBJ, ROWERR, UNITQ - INTEGER ISTATE(NCTOTL), KACTIV(N), KX(N) - DOUBLE PRECISION A(NROWA,*), AX(*), BL(NCTOTL), BU(NCTOTL), - $ CQ(*), RES(*), RES0(*), FEATOL(NCTOTL), P(N), - $ R(NROWR,*), T(NROWT,*), ZY(NQ,*), X(N) - DOUBLE PRECISION WORK(NCTOTL) - -************************************************************************ -* LSSETX computes the point on a working set that is closest to the -* input vector x (in the least-squares sense). The norm of x, the -* transformed residual vector Pr - RQ'x, and the constraint values -* Ax are also initialized. -* -* If the computed point gives a row error of more than the feasibility -* tolerance, an extra step of iterative refinement is used. If x is -* still infeasible, the logical variable ROWERR is set. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* This version dated 29-December-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - - EXTERNAL IDAMAX, DDOT - INTRINSIC ABS, MIN - PARAMETER ( NTRY = 2 ) - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - -* ------------------------------------------------------------------ -* Move x onto the simple bounds in the working set. -* ------------------------------------------------------------------ - DO 100 K = NFREE+1, N - J = KX(K) - IS = ISTATE(J) - BND = BL(J) - IF (IS .GE. 2) BND = BU(J) - IF (IS .NE. 4) X(J) = BND - 100 CONTINUE - -* ------------------------------------------------------------------ -* Move x onto the general constraints in the working set. -* We shall make ntry tries at getting acceptable row errors. -* ------------------------------------------------------------------ - KTRY = 1 - JMAX = 1 - ERRMAX = ZERO - -* REPEAT - 200 IF (NACTIV .GT. 0) THEN - -* Set work = residuals for constraints in the working set. -* Solve for p, the smallest correction to x that gives a point -* on the constraints in the working set. Define p = Y*(py), -* where py solves the triangular system T*(py) = residuals. - - DO 220 I = 1, NACTIV - K = KACTIV(I) - J = N + K - BND = BL(J) - IF (ISTATE(J) .EQ. 2) BND = BU(J) - WORK(I) = BND - DDOT ( N, A(K,1), NROWA, X, 1 ) - 220 CONTINUE - - CALL CMTSOL( 1, NROWT, NACTIV, T(1,NZ+1), WORK ) - CALL DLOAD ( N, ZERO, P, 1 ) - CALL DCOPY ( NACTIV, WORK, 1, P(NZ+1), 1 ) - - CALL CMQMUL( 2, N, NZ, NFREE, NQ, UNITQ, KX, P, ZY, WORK ) - CALL DAXPY ( N, ONE, P, 1, X, 1 ) - END IF - -* --------------------------------------------------------------- -* Compute the 2-norm of x. -* Initialize Ax for all the general constraints. -* --------------------------------------------------------------- - XNORM = DNRM2 ( N, X, 1 ) - IF (NCLIN .GT. 0) - $ CALL DGEMV ( 'N', NCLIN, N, ONE, A, NROWA, - $ X, 1, ZERO, AX, 1 ) - -* --------------------------------------------------------------- -* Check the row residuals. -* --------------------------------------------------------------- - IF (NACTIV .GT. 0) THEN - DO 300 K = 1, NACTIV - I = KACTIV(K) - J = N + I - IS = ISTATE(J) - IF (IS .EQ. 1) WORK(K) = BL(J) - AX(I) - IF (IS .GE. 2) WORK(K) = BU(J) - AX(I) - 300 CONTINUE - - JMAX = IDAMAX( NACTIV, WORK, 1 ) - ERRMAX = ABS( WORK(JMAX) ) - END IF - - KTRY = KTRY + 1 -* UNTIL (ERRMAX .LE. FEATOL(JMAX) .OR. KTRY .GT. NTRY - IF (.NOT.(ERRMAX .LE. FEATOL(JMAX) .OR. KTRY .GT. NTRY)) GO TO 200 - - ROWERR = ERRMAX .GT. FEATOL(JMAX) - -* ================================================================== -* Compute the linear objective value c'x and the transformed -* residual Pr - RQ'x = RES0 - RQ'x. -* ================================================================== - IF (NRANK .GT. 0 .OR. LINOBJ) THEN - CALL DCOPY ( N, X, 1, P, 1 ) - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, P, ZY, WORK ) - END IF - - CTX = ZERO - IF (LINOBJ) - $ CTX = DDOT ( N, CQ, 1, P, 1 ) - - IF (NRANK .GT. 0) THEN - - CALL DTRMV ( 'U', 'N', 'N', NRANK, R, NROWR, P, 1 ) - IF (NRANK .LT. N) - $ CALL DGEMV ( 'N', NRANK, N-NRANK, ONE, R(1,NRANK+1), NROWR, - $ P(NRANK+1), 1, ONE, P, 1 ) - - CALL DCOPY ( NRANK, RES0, 1, RES, 1 ) - CALL DAXPY ( NRANK, -ONE, P , 1, RES, 1 ) - - END IF - - IF (LSDBG .AND. ILSDBG(2) .GT. 0) - $ WRITE (NOUT, 2200) (X(J), J = 1, N) - - RETURN - - 2200 FORMAT(/ ' //LSSETX// Variables after refinement ... '/ (5G12.3)) - -* End of LSSETX. - - END
deleted file mode 100644 --- a/libcruft/npsol/lssol.f +++ /dev/null @@ -1,523 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE LSSOL ( MM, N, - $ NCLIN, NROWA, NROWR, - $ A, BL, BU, CVEC, - $ ISTATE, KX, X, R, B, - $ INFORM, ITER, OBJ, CLAMDA, - $ IW, LENIW, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER LENIW, LENW - INTEGER ISTATE(N+NCLIN), KX(N) - INTEGER IW(LENIW) - DOUBLE PRECISION BL(N+NCLIN), BU(N+NCLIN), A(NROWA,*) - DOUBLE PRECISION CLAMDA(N+NCLIN), CVEC(*) - DOUBLE PRECISION R(NROWR,*), X(N), B(*) - DOUBLE PRECISION W(LENW) - -************************************************************************ -* LSSOL solves problems of the form -* -* Minimize F(x) -* x -* ( x ) -* subject to bl .le.( ).ge. bu, -* ( Ax ) -* -* where ' denotes the transpose of a column vector, x denotes the -* n-vector of parameters and F(x) is one of the following functions.. -* -* FP = None (find a feasible point). -* LP = c'x -* QP1= 1/2 x'Rx R n times n, symmetric pos. def. -* QP2= c'x + 1/2 x'Rx . . .. .. .. .. -* QP3= 1/2 x'R'Rx R m times n, upper triangular. -* QP4= c'x + 1/2 x'R'Rx . . .. . .. ... -* LS1= 1/2 (b - Rx)'(b - Rx) R m times n, rectangular. -* LS2= c'x + 1/2 (b - Rx)'(b - Rx) . . .. . ... -* LS3= 1/2 (b - Rx)'(b - Rx) R m times n, upper triangular. -* LS4= c'x + 1/2 (b - Rx)'(b - Rx) . . .. . .. ... -* -* The matrix R is entered as the two-dimensional array R (of row -* dimension NROWR). If NROWR = 0, R is not accessed. -* -* The vector c is entered in the one-dimensional array CVEC. -* -* NCLIN is the number of general linear constraints (rows of A). -* (NCLIN may be zero.) -* -* The first N components of BL and BU are lower and upper -* bounds on the variables. The next NCLIN components are -* lower and upper bounds on the general linear constraints. -* -* The matrix A of coefficients in the general linear constraints -* is entered as the two-dimensional array A (of dimension -* NROWA by N). If NCLIN = 0, A is not accessed. -* -* The vector x must contain an initial estimate of the solution, -* and will contain the computed solution on output. -* -* -* Complete documentation for LSSOL is contained in Report SOL 86-1, -* Users Guide for LSSOL (Version 1.0), by P.E. Gill, S. J. Hammarling, -* W. Murray, M.A. Saunders and M.H. Wright, Department of -* Operations Research, Stanford University, Stanford, California 94305. -* -* Systems Optimization Laboratory, Stanford University. -* Version 1.01 Dated 30-June-1986. -* -* Copyright 1984 Stanford University. -* -* This material may be reproduced by or for the U.S. Government pursu- -* ant to the copyright license under DAR clause 7-104.9(a) (1979 Mar). -* -* This material is based upon work partially supported by the National -* Science Foundation under Grants MCS-7926009 and ECS-8312142; the -* Department of Energy Contract AM03-76SF00326, PA No. DE-AT03- -* 76ER72018; the Army Research Office Contract DAA29-84-K-0156; -* and the Office of Naval Research Grant N00014-75-C-0267. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT, NCOLT, NQ - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN - - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - LOGICAL LSDBG - PARAMETER (LDBG = 5) - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (MSGLS , MSGLVL), (IDBGLS, IDBG), (LDBGLS, MSGDBG) - - INTRINSIC MAX, MIN - -* Local variables. - - LOGICAL COLD , FACTRZ, LINOBJ, NAMED , ROWERR, - $ UNITQ , VERTEX - CHARACTER*2 PRBTYP - CHARACTER*8 NAMES(1) - PARAMETER ( ZERO =0.0D+0, POINT1 =0.1D+0, POINT3 =3.3D-1) - PARAMETER ( POINT8 =0.8D+0, POINT9 =0.9D+0, ONE =1.0D+0) - - CHARACTER*40 TITLE - DATA TITLE - $ / 'SOL/LSSOL --- Version 1.01 June 1986' / - -* Set the machine-dependent constants. - - CALL MCHPAR() - - EPSMCH = WMACH( 3) - RTEPS = WMACH( 4) - NOUT = WMACH(11) - - EPSPT3 = EPSMCH**POINT3 - EPSPT5 = RTEPS - EPSPT8 = EPSMCH**POINT8 - EPSPT9 = EPSMCH**POINT9 - - NAMED = .FALSE. - - INFORM = 0 - ITER = 0 - - CONDMX = ONE / EPSPT5 - - NCTOTL = N + NCLIN - -* Set the default values of the parameters. - - CALL LSDFLT( MM, N, NCLIN, TITLE ) - -* Set all parameters determined by the problem type. - - IF (LPROB .EQ. 1 ) THEN - PRBTYP = 'FP' - M = 0 - LINOBJ = .FALSE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 2 ) THEN - PRBTYP = 'LP' - M = 0 - LINOBJ = .TRUE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 3 ) THEN - PRBTYP = 'QP' - M = MM - LINOBJ = .FALSE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 4 ) THEN - PRBTYP = 'QP' - M = MM - LINOBJ = .TRUE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 5 ) THEN - PRBTYP = 'QP' - M = MM - LINOBJ = .FALSE. - FACTRZ = .FALSE. - ELSE IF (LPROB .EQ. 6 ) THEN - PRBTYP = 'QP' - M = MM - LINOBJ = .TRUE. - FACTRZ = .FALSE. - ELSE IF (LPROB .EQ. 7 ) THEN - PRBTYP = 'LS' - M = MM - LINOBJ = .FALSE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 8 ) THEN - PRBTYP = 'LS' - M = MM - LINOBJ = .TRUE. - FACTRZ = .TRUE. - ELSE IF (LPROB .EQ. 9 ) THEN - PRBTYP = 'LS' - M = MM - LINOBJ = .FALSE. - FACTRZ = .FALSE. - ELSE IF (LPROB .EQ. 10) THEN - PRBTYP = 'LS' - M = MM - LINOBJ = .TRUE. - FACTRZ = .FALSE. - END IF - -* Assign the dimensions of arrays in the parameter list of LSCORE. -* Economies of storage are possible if the minimum number of active -* constraints and the minimum number of fixed variables are known in -* advance. The expert user should alter MINACT and MINFXD -* accordingly. -* If a linear program is being solved and the matrix of general -* constraints is fat, i.e., NCLIN .LT. N, a non-zero value is -* known for MINFXD. Note that in this case, VERTEX must be -* set .TRUE.. - - MINACT = 0 - MINFXD = 0 - - VERTEX = .FALSE. - IF ( (PRBTYP .EQ. 'LP' .OR. PRBTYP .EQ. 'FP') - $ .AND. NCLIN .LT. N ) THEN - MINFXD = N - NCLIN - 1 - VERTEX = .TRUE. - END IF - - MXFREE = N - MINFXD - MAXACT = MAX( 1, MIN( N, NCLIN ) ) - MAXNZ = N - ( MINFXD + MINACT ) - - IF (NCLIN .EQ. 0) THEN - NQ = 1 - NROWT = 1 - NCOLT = 1 - VERTEX = .FALSE. - ELSE - NQ = MAX( 1, MXFREE ) - NROWT = MAX( MAXNZ, MAXACT ) - NCOLT = MXFREE - END IF - - NCNLN = 0 - LENNAM = 1 - -* Allocate certain arrays that are not done in LSLOC. - - LITOTL = 0 - - LAX = 1 - LWTOTL = LAX + NCLIN - 1 - -* Allocate remaining work arrays. - - CALL LSLOC ( LPROB, N, NCLIN, LITOTL, LWTOTL ) - - COLD = LCRASH .EQ. 0 - -* Check input parameters and storage limits. - - CALL CMCHK ( NERROR, MSGLVL, COLD, (.NOT.FACTRZ), - $ LENIW, LENW, LITOTL, LWTOTL, - $ N, NCLIN, NCNLN, - $ ISTATE, KX, NAMED, NAMES, LENNAM, - $ BL, BU, X ) - - IF (NERROR .GT. 0) THEN - INFORM = 6 - GO TO 800 - END IF - - LKACTV = LOCLS( 1) - - LANORM = LOCLS( 2) - LPX = LOCLS( 4) - LRES = LOCLS( 5) - LRES0 = LOCLS( 6) - LGQ = LOCLS( 8) - LCQ = LOCLS( 9) - LRLAM = LOCLS(10) - LT = LOCLS(11) - LZY = LOCLS(12) - LWTINF = LOCLS(13) - LWRK = LOCLS(14) - LFEATL = LOCLS(15) - - IF (TOLFEA .GT. ZERO) - $ CALL DLOAD ( N+NCLIN, (TOLFEA), W(LFEATL), 1 ) - - IANRMJ = LANORM - DO 200 J = 1, NCLIN - W(IANRMJ) = DNRM2 ( N, A(J,1), NROWA ) - IANRMJ = IANRMJ + 1 - 200 CONTINUE - IF (NCLIN .GT. 0) - $ CALL DCOND ( NCLIN, W(LANORM), 1, ASIZE, AMIN ) - - CALL DCOND ( NCTOTL, W(LFEATL), 1, FEAMAX, FEAMIN ) - CALL DCOPY ( NCTOTL, W(LFEATL), 1, W(LWTINF), 1 ) - CALL DSCAL ( NCTOTL, (ONE/FEAMIN), W(LWTINF), 1 ) - - SSQ1 = ZERO - - IF (FACTRZ) THEN -* =============================================================== -* Factorize R using QR or Cholesky. KX must be initialized. -* =============================================================== - DO 210 I = 1, N - KX(I) = I - 210 CONTINUE - - IF (PRBTYP .EQ. 'LP' .OR. PRBTYP .EQ. 'FP') THEN - NRANK = 0 - ELSE IF (PRBTYP .EQ. 'QP') THEN -* ------------------------------------------------------------ -* Compute the Cholesky factorization of R. The Hessian is -* M times M and resides in the upper left-hand corner of R. -* ------------------------------------------------------------ - DO 220 J = M+1, N - CALL DLOAD ( M, (ZERO), R(1,J), 1 ) - 220 CONTINUE - - CALL LSCHOL( NROWR, M, NRANK, TOLRNK, KX, R, INFO ) - - IF (NRANK .GT. 0) - $ CALL DLOAD ( NRANK, (ZERO), W(LRES0), 1 ) - - ELSE IF (PRBTYP .EQ. 'LS') THEN -* ------------------------------------------------------------ -* Compute the orthogonal factorization PRQ = ( U ), where P -* ( 0 ) -* is an orthogonal matrix and Q is a permutation matrix. -* Overwrite R with the upper-triangle U. The orthogonal -* matrix P is applied to the residual and discarded. The -* permutation is stored in the array KX. Once U has been -* computed we need only work with vectors of length N within -* LSCORE. However, it is necessary to store the sum of -* squares of the terms B(NRANK+1),...,B(M), where B = Pr. -* ------------------------------------------------------------ - CALL DGEQRP( 'Column iterchanges', M, N, R, NROWR, - $ W(LWRK), IW(LKACTV), W(LGQ), INFO ) - - LJ = LKACTV - DO 230 J = 1, N - JMAX = IW(LJ) - IF (JMAX .GT. J) THEN - JSAVE = KX(JMAX) - KX(JMAX) = KX(J) - KX(J) = JSAVE - END IF - LJ = LJ + 1 - 230 CONTINUE - - CALL DGEAPQ( 'Transpose', 'Separate', M, N, R, NROWR, - $ W(LWRK), 1, B, M, W(LGQ), INFO ) - - NRANK = IDRANK( MIN(N, M), R, NROWR+1, TOLRNK ) - - IF (M .GT. NRANK) SSQ1 = DNRM2 ( M-NRANK, B(NRANK+1), 1 ) - - IF (NRANK .GT. 0) - $ CALL DCOPY ( NRANK, B, 1, W(LRES0), 1 ) - END IF - ELSE -* =============================================================== -* R is input as an upper-triangular matrix with M rows. -* =============================================================== - NRANK = M - IF (NRANK .GT. 0) THEN - IF (PRBTYP .EQ. 'QP') THEN - CALL DLOAD ( NRANK, (ZERO), W(LRES0), 1 ) - ELSE IF (PRBTYP .EQ. 'LS') THEN - CALL DCOPY ( NRANK, B, 1, W(LRES0), 1 ) - END IF - END IF - END IF - - IF ( MSGLVL .GT. 0 .AND. NRANK .LT. N - $ .AND. PRBTYP .NE. 'LP' .AND. PRBTYP .NE. 'FP') - $ WRITE (NOUT, 9000) NRANK - -* ------------------------------------------------------------------ -* Find an initial working set. -* ------------------------------------------------------------------ - CALL LSCRSH( COLD, VERTEX, - $ NCLIN, NCTOTL, NACTIV, NARTIF, - $ NFREE, N, NROWA, - $ ISTATE, IW(LKACTV), - $ BIGBND, TOLACT, - $ A, W(LAX), BL, BU, X, W(LGQ), W(LWRK) ) - -* ------------------------------------------------------------------ -* Compute the TQ factorization of the constraints while keeping R in -* upper-triangular form. Transformations associated with Q are -* applied to CQ. Transformations associated with P are applied to -* RES0. If some simple bounds are in the working set, KX is -* re-ordered so that the free variables come first. -* ------------------------------------------------------------------ -* First, add the bounds. To save a bit of work, CQ is not loaded -* until after KX has been re-ordered. - - NGQ = 0 - NRES = 0 - IF (NRANK .GT. 0) NRES = 1 - UNITQ = .TRUE. - - CALL LSBNDS( UNITQ, - $ INFORM, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, KX, - $ CONDMX, - $ A, R, W(LT), W(LRES0), W(LCQ), - $ W(LZY), W(LGQ), W(LWRK) ) - - IF (LINOBJ) THEN - -* Install the transformed linear term in CQ. -* CMQMUL applies the permutations in KX to CVEC. - - NGQ = 1 - CALL DCOPY ( N, CVEC, 1, W(LCQ), 1 ) - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, - $ KX, W(LCQ), W(LZY), W(LWRK) ) - END IF - - IF (NACTIV .GT. 0) THEN - NACT1 = NACTIV - NACTIV = 0 - - CALL LSADDS( UNITQ, VERTEX, - $ INFORM, 1, NACT1, NACTIV, NARTIF, NZ, NFREE, - $ NRANK, NREJTD, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, IW(LKACTV), KX, - $ CONDMX, - $ A, R, W(LT), W(LRES0), W(LCQ), - $ W(LZY), W(LGQ), W(LWRK) ) - END IF - -* ------------------------------------------------------------------ -* Move the initial x onto the constraints in the working set. -* Compute the transformed residual vector Pr = Pb - RQ'x. -* ------------------------------------------------------------------ - CALL LSSETX( LINOBJ, ROWERR, UNITQ, - $ NCLIN, NACTIV, NFREE, NRANK, NZ, - $ N, NCTOTL, NQ, NROWA, NROWR, NROWT, - $ ISTATE, IW(LKACTV), KX, - $ JMAX, ERRMAX, CTX, XNORM, - $ A, W(LAX), BL, BU, W(LCQ), W(LRES), W(LRES0), - $ W(LFEATL), R, W(LT), X, W(LZY), W(LPX), W(LWRK) ) - - JINF = 0 - - CALL LSCORE( PRBTYP, NAMED, NAMES, LINOBJ, UNITQ, - $ INFORM, ITER, JINF, NCLIN, NCTOTL, - $ NACTIV, NFREE, NRANK, NZ, NZ1, - $ N, NROWA, NROWR, - $ ISTATE, IW(LKACTV), KX, - $ CTX, OBJ, SSQ1, - $ SUMINF, NUMINF, XNORM, - $ BL, BU, A, CLAMDA, W(LAX), - $ W(LFEATL), R, X, IW, W ) - - OBJ = OBJ + CTX - IF (PRBTYP .EQ. 'LS' .AND. NRANK .GT. 0) - $ CALL DCOPY ( NRANK, W(LRES), 1, B, 1 ) - -* ================================================================== -* Print messages if required. -* ================================================================== - 800 IF (MSGLVL .GT. 0) THEN - IF (INFORM .EQ. 0) THEN - IF (PRBTYP .EQ. 'FP') THEN - WRITE (NOUT, 2001) - ELSE - WRITE (NOUT, 2002) PRBTYP - END IF - END IF - IF (INFORM .EQ. 1) WRITE (NOUT, 2010) PRBTYP - IF (INFORM .EQ. 2) WRITE (NOUT, 2020) PRBTYP - IF (INFORM .EQ. 3) WRITE (NOUT, 2030) - IF (INFORM .EQ. 4) WRITE (NOUT, 2040) - IF (INFORM .EQ. 5) WRITE (NOUT, 2050) - IF (INFORM .EQ. 6) WRITE (NOUT, 2060) NERROR - - IF (INFORM .LT. 6) THEN - IF (NUMINF .EQ. 0) THEN - IF (PRBTYP .NE. 'FP') WRITE (NOUT, 3000) PRBTYP, OBJ - ELSE IF (INFORM .EQ. 3) THEN - WRITE (NOUT, 3010) SUMINF - ELSE - WRITE (NOUT, 3020) SUMINF - END IF - IF (NUMINF .GT. 0) OBJ = SUMINF - END IF - END IF - -* Recover the optional parameters set by the user. - - CALL ICOPY ( MXPARM, IPSVLS, 1, IPRMLS, 1 ) - CALL DCOPY ( MXPARM, RPSVLS, 1, RPRMLS, 1 ) - - RETURN - - 2001 FORMAT(/ ' Exit LSSOL - Feasible point found. ') - 2002 FORMAT(/ ' Exit LSSOL - Optimal ', A2, ' solution.') - 2010 FORMAT(/ ' Exit LSSOL - Weak ', A2, ' solution.') - 2020 FORMAT(/ ' Exit LSSOL - ', A2, ' solution is unbounded.' ) - 2030 FORMAT(/ ' Exit LSSOL - Cannot satisfy the linear constraints. ' ) - 2040 FORMAT(/ ' Exit LSSOL - Too many iterations.') - 2050 FORMAT(/ ' Exit LSSOL - Too many iterations without changing X.' ) - 2060 FORMAT(/ ' Exit LSSOL - ', I10, ' errors found in the input', - $ ' parameters. Problem abandoned.' ) - 3000 FORMAT(/ ' Final ', A2, ' objective value =', G16.7 ) - 3010 FORMAT(/ ' Minimum sum of infeasibilities =', G16.7 ) - 3020 FORMAT(/ ' Final sum of infeasibilities =', G16.7 ) - - 9000 FORMAT(/ ' Rank of the objective function data matrix = ', I5 ) - -* End of LSSOL . - - END
deleted file mode 100644 --- a/libcruft/npsol/mcenv1.f +++ /dev/null @@ -1,145 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE MCENV1( BETA, T, RND ) - LOGICAL RND - INTEGER BETA, T - -* MCENV1 returns the machine parameters given by: -* -* BETA - INTEGER. -* The base of the machine. -* -* T - INTEGER. -* The number of ( BETA ) digits in the mantissa. -* -* RND - LOGICAL. -* Whether proper rounding ( RND = .TRUE. ) or chopping -* ( RND = .FALSE. ) occurs in addition. This may not be a -* reliable guide to the way in which the machine perfoms -* its arithmetic. -* -* The routine is based on the routine ENVRON by Malcolm -* and incorporates suggestions by Gentleman and Marovich. See -* -* Malcolm M. A. (1972) Algorithms to reveal properties of -* floating-point arithmetic. Comms. of the ACM, 15, 949-951. -* -* Gentleman W. M. and Marovich S. B. (1974) More on algorithms -* that reveal properties of floating point arithmetic units. -* Comms. of the ACM, 17, 276-277. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (ENVRON). -* -* -- Written on 26-November-1984. -* Sven Hammarling and Mick Pont, Nag Central Office. - - EXTERNAL MCSTOR - LOGICAL FIRST , LRND - INTEGER LBETA , LT - DOUBLE PRECISION A , B , C , F , ONE , QTR - DOUBLE PRECISION MCSTOR - - SAVE FIRST , LBETA , LRND , LT - DATA FIRST / .TRUE. / - - IF( FIRST )THEN - FIRST = .FALSE. - ONE = 1 - -* LBETA, LT and LRND are the local values of BETA, T and RND. -* -* Throughout this routine we use the function MCSTOR to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* Compute a = 2.0**m with the smallest positive integer m such -* that -* -* fl( a + 1.0 ) = a. - - A = 1 - C = 1 - -*+ WHILE( C.EQ.ONE )LOOP - 10 IF ( C.EQ.ONE )THEN - A = 2*A - C = MCSTOR( A, ONE ) - C = MCSTOR( C, -A ) - GO TO 10 - END IF -*+ END WHILE - -* Now compute b = 2.0**m with the smallest positive integer m -* such that -* -* fl( a + b ) .gt. a. - - B = 1 - C = MCSTOR( A, B ) - -*+ WHILE( C.EQ.A )LOOP - 20 IF ( C.EQ.A )THEN - B = 2*B - C = MCSTOR( A, B ) - GO TO 20 - END IF -*+ END WHILE - -* Now compute the base. a and b are neighbouring floating point -* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so -* their difference is beta. Adding 0.25 to c is to ensure that it -* is truncated to beta and not ( beta - 1 ). - - - QTR = ONE/4 - C = MCSTOR( C, -A ) - LBETA = C + QTR - -* Now determine whether rounding or chopping occurs, by adding -* a bit less than beta/2 and a bit more than beta/2 to a. - - B = LBETA - F = MCSTOR( B/2, -B/100 ) - C = MCSTOR( F, A ) - IF( C.EQ.A) THEN - LRND = .TRUE. - ELSE - LRND = .FALSE. - END IF - F = MCSTOR( B/2, B/100 ) - C = MCSTOR( F, A ) - IF( ( LRND ).AND.( C.EQ.A ) ) - $ LRND = .FALSE. - -* Now find the mantissa, t. It should be the integer part of -* log to the base beta of a, however it is safer to determine t -* by powering. So we find t as the smallest positive integer -* for which -* -* fl( beta**t + 1.0 ) = 1.0. - - LT = 0 - A = 1 - C = 1 - -*+ WHILE( C.EQ.ONE )LOOP - 30 IF ( C.EQ.ONE )THEN - LT = LT + 1 - A = A*LBETA - C = MCSTOR( A, ONE ) - C = MCSTOR( C, -A ) - GO TO 30 - END IF -*+ END WHILE - - END IF - - BETA = LBETA - T = LT - RND = LRND - RETURN - -* End of MCENV1 (ENVRON). - - END
deleted file mode 100644 --- a/libcruft/npsol/mcenv2.f +++ /dev/null @@ -1,203 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE MCENV2( BETA, T, EPS, EMIN, RMIN ) - INTEGER BETA, T, EMIN - DOUBLE PRECISION EPS, RMIN - -* MCENV2 returns the machine parameters given by: -* -* BETA - INTEGER. -* The base of the machine. -* -* T - INTEGER. -* The number of ( BETA ) digits in the mantissa. -* -* EPS - REAL. -* The smallest positive number such that -* -* fl( 1.0 - EPS ) .lt. 1.0, -* -* where fl denotes the computed value. -* -* EMIN - INTEGER. -* The minimum exponent before (gradual) underflow occurs. -* -* RMIN - REAL. -* The smallest normalized number for the machine given by -* BASE**( EMIN - 1 ), where BASE is the floating point -* value of BETA. -* -* -* The computation of EPS, EMIN and RMIN is based on a routine, -* PARANOIA by W. Kahan of the University of California at Berkeley. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (ENVIRN). -* -* -- Written on 6-January-1986. -* Sven Hammarling, Mick Pont and Janet Welding, Nag Central Office. - - EXTERNAL MCENV1, MCMIN , MCSTOR - INTRINSIC ABS , MAX - LOGICAL FIRST , IWARN , LRND - INTEGER GNMIN , GPMIN , I , LBETA , LEMIN , LEMIN1 - INTEGER LEMIN2, LT , NGNMIN, NGPMIN - DOUBLE PRECISION A , B , C , HALF , LEPS , LRMIN - DOUBLE PRECISION ONE , RBASE , SIXTH , SMALL , MCSTOR, THIRD - DOUBLE PRECISION TWO , XBASE , ZERO - - COMMON /SOL1CM/ NOUT - - SAVE FIRST , IWARN , LBETA , LEMIN , LEPS , LRMIN - SAVE LT - DATA FIRST / .TRUE. / , IWARN / .FALSE. / - - IF( FIRST )THEN - FIRST = .FALSE. - ZERO = 0 - ONE = 1 - TWO = 2 - -* LBETA, LT, LEPS, LEMIN and LRMIN are the local values of BETA, -* T, EPS, EMIN and RMIN. -* -* Throughout this routine we use the function MCSTOR to ensure -* that relevant values are stored and not held in registers, or -* are not affected by optimizers. -* -* MCENV1 returns the parameters LBETA and LT. ( LRND is not used -* here. ) - - CALL MCENV1( LBETA, LT, LRND ) - -* Start to find EPS. - - B = LBETA - A = B**( -LT ) - LEPS = A - -* Try some tricks to see whether or not this is the correct EPS. - - B = TWO/3 - HALF = ONE/2 - SIXTH = MCSTOR( B , -HALF ) - THIRD = MCSTOR( SIXTH, SIXTH ) - B = MCSTOR( THIRD, -HALF ) - B = MCSTOR( B , SIXTH ) - B = ABS ( B ) - IF( B.LT.LEPS ) - $ B = LEPS - - LEPS = 1 - -*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP - 10 IF ( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )THEN - LEPS = B - C = MCSTOR( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) ) - C = MCSTOR( HALF , -C ) - B = MCSTOR( HALF , C ) - C = MCSTOR( HALF , -B ) - B = MCSTOR( HALF , C ) - GO TO 10 - END IF -*+ END WHILE - - IF( A.LT.LEPS ) - $ LEPS = A - -* Computation of EPS complete. Now find EMIN. -* First compute the next floating point value below 1.0, a, and -* keep dividing a by BETA until (gradual) underflow occurs. -* This is detected when we cannot recover the previous a. - - XBASE = LBETA - RBASE = 1/XBASE - SMALL = ONE - DO 20, I = 1, LT - 1 - SMALL = MCSTOR( SMALL/LBETA, ZERO ) - 20 CONTINUE - A = MCSTOR( ONE, SMALL ) - CALL MCMIN ( NGPMIN, ONE, XBASE, RBASE, LBETA ) - CALL MCMIN ( NGNMIN, -ONE, XBASE, RBASE, LBETA ) - CALL MCMIN ( GPMIN, A, XBASE, RBASE, LBETA ) - CALL MCMIN ( GNMIN, -A, XBASE, RBASE, LBETA ) - LEMIN = 0 - IF( ( NGPMIN.EQ.NGNMIN ).AND.( GPMIN.EQ.GNMIN ) )THEN - IF( NGPMIN.EQ.GPMIN )THEN - LEMIN = NGPMIN - ELSE IF( NGPMIN.LT.GPMIN )THEN - IF( ABS( GPMIN - NGPMIN - LT ).LT.3 )THEN - LEMIN = GPMIN - ELSE - LEMIN = NGPMIN - IWARN = .TRUE. - END IF - ELSE - WRITE( NOUT, 9999 ) - CALL XSTOPX (' ') - END IF - ELSE - IF( NGPMIN.EQ.GPMIN )THEN - LEMIN1 = NGPMIN - ELSE IF( NGPMIN.LT.GPMIN )THEN - IF( ABS( GPMIN - NGPMIN - LT ).LT.3 )THEN - LEMIN1 = GPMIN - ELSE - LEMIN1 = NGPMIN - IWARN = .TRUE. - END IF - ELSE - WRITE( NOUT, 9999 ) - CALL XSTOPX (' ') - END IF - IF( NGNMIN.EQ.GNMIN )THEN - LEMIN2 = NGNMIN - ELSE IF( NGNMIN.LT.GNMIN )THEN - IF( ABS( GNMIN - NGNMIN - LT ).LT.3 )THEN - LEMIN2 = GNMIN - ELSE - LEMIN2 = NGNMIN - IWARN = .TRUE. - END IF - ELSE - WRITE( NOUT, 9999 ) - CALL XSTOPX (' ') - END IF - LEMIN = MAX( LEMIN1, LEMIN2 ) - END IF -*** -* Comment out this IF block if Emin is ok - IF( IWARN )THEN - FIRST = .TRUE. - WRITE( NOUT, 9998 )LEMIN - END IF -*** - -* Finally compute RMIN by successive division by BETA. -* We could compute RMIN as base**( EMIN - 1 ), but some machines -* underflow during this computation. - - LRMIN = 1 - DO 30, I = 1, 1 - LEMIN - LRMIN = LRMIN/LBETA - 30 CONTINUE - END IF - - BETA = LBETA - T = LT - EPS = LEPS - EMIN = LEMIN - RMIN = LRMIN - RETURN - - 9999 FORMAT( // ' ** ERROR . No reliable value for Emin could be', - $ ' found.' / ' Please contact Stanford University.'// ) - 9998 FORMAT( // ' WARNING. The value Emin may be incorrect:- Emin = ', - $ I8 / ' If after inspection the value Emin looks', - $ ' acceptable please comment out ' / ' the IF block', - $ ' as marked within the code of routine mcenv2,' / - $ ' otherwise contact Stanford University. ' / ) - -* End of MCENV2 (ENVIRN). - - END
deleted file mode 100644 --- a/libcruft/npsol/mceps.f +++ /dev/null @@ -1,51 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DOUBLE PRECISION FUNCTION MCEPS () - -* MCEPS returns approximately the relative machine precision via -* the function name. -* -* The value returned is given by -* -* MCEPS = (1/2)*beta**( 1 - t ) when rnd = true -* -* MCEPS = beta**( 1 - t ) when rnd = false, -* -* where beta is the base of the machine, t is the number of ( beta ) -* digits in the mantissa and rnd is true when rounding occurs and is -* false when chopping occurs. This is the Wilkinson unit rounding -* error. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (EPSLON). -* -* -- Written on 26-November-1984. -* Sven Hammarling, Nag Central Office. - - EXTERNAL MCENV1 - LOGICAL FIRST , RND - INTEGER BETA , T - DOUBLE PRECISION BASE , EPS - - SAVE EPS , FIRST - DATA FIRST / .TRUE. / - - IF( FIRST )THEN - FIRST = .FALSE. - - CALL MCENV1( BETA, T, RND ) - - BASE = BETA - IF( RND )THEN - EPS = ( BASE**( 1 - T ) )/2 - ELSE - EPS = BASE**( 1 - T ) - END IF - END IF - - MCEPS = EPS - RETURN - -* End of MCEPS (EPSLON). - - END
deleted file mode 100644 --- a/libcruft/npsol/mchpar.f +++ /dev/null @@ -1,87 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File MCSUBS FORTRAN -* -* MCHPAR MCEPS MCENV1 MCENV2 MCSTOR MCSMAL MCMIN -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE MCHPAR() - -************************************************************************ -* MCHPAR must define certain machine parameters as follows: -* wmach(1) = NBASE = base of floating-point arithmetic. -* wmach(2) = NDIGIT = no. of base wmach(1) digits of precision. -* wmach(3) = EPS = floating-point precision. -* wmach(4) = RTEPS = sqrt(EPS). -* wmach(5) = RMIN = smallest positive normalized floating-point -* number. -* wmach(6) = RTRMIN = sqrt(RMIN). -* wmach(7) = RMAX = largest positive floating-point number. -* wmach(8) = RTRMAX = sqrt(RMAX). -* wmach(9) = UNDFLW = 0 if underflow is not fatal, +ve otherwise. -* wmach(10) = NIN = standard file number of the input stream. -* wmach(11) = NOUT = standard file number of the output stream. -************************************************************************ - - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - EXTERNAL MCENV2, MCEPS , MCSMAL, D1MACH, I1MACH - INTRINSIC SQRT - LOGICAL FIRST , HDWIRE - INTEGER EMIN , NBASE , NDIGIT, NIN , NOUT , I1MACH - DOUBLE PRECISION BASE , EPS , MCEPS , MCSMAL, RMAX , RMIN - DOUBLE PRECISION RTEPS , RTMAX , RTMIN , SMALL , UNDFLW, D1MACH - SAVE FIRST - DATA FIRST / .TRUE. / - - IF (FIRST) THEN - FIRST = .FALSE. - -* --------------------------------------------------------------- -* Machine-dependent code. -* 1. Set UNDFLW, NIN, NOUT, HDWIRE as desired. -* 2. If HDWIRE = .TRUE. set the machine constants -* NBASE, NDIGIT, EPS, RMIN, RMAX -* in-line. Otherwise, they will be computed by MCENV2. -* A call to MCENV2 will cause eight underflows. -* --------------------------------------------------------------- - - UNDFLW = 0 - NIN = I1MACH(1) - NOUT = I1MACH(2) - HDWIRE = .TRUE. - - IF (HDWIRE) THEN - NBASE = I1MACH(10) - NDIGIT = I1MACH(14) - BASE = NBASE - EPS = D1MACH(4) - RMIN = D1MACH(1) - RMAX = D1MACH(2) - ELSE - CALL MCENV2( NBASE, NDIGIT, EPS, EMIN, RMIN ) - - EPS = MCEPS () - SMALL = MCSMAL() - RMAX = 1/SMALL - END IF - - WMACH(1) = NBASE - WMACH(2) = NDIGIT - WMACH(3) = EPS - WMACH(4) = SQRT( EPS ) - WMACH(5) = RMIN - WMACH(6) = SQRT( RMIN ) - WMACH(7) = RMAX - WMACH(8) = SQRT( RMAX ) - WMACH(9) = UNDFLW - WMACH(10) = NIN - WMACH(11) = NOUT - END IF - - RETURN - -* End of MCHPAR. - - END
deleted file mode 100644 --- a/libcruft/npsol/mcmin.f +++ /dev/null @@ -1,53 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE MCMIN ( EMIN, START, XBASE, RBASE, BASE ) - INTEGER EMIN, BASE - DOUBLE PRECISION START, XBASE, RBASE - -* Service routine for MCENV2. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (GETMIN). -* -* -- Written on 6-January-1986. -* Sven Hammarling and Mick Pont, Nag Central Office. - - EXTERNAL MCSTOR - INTEGER I - DOUBLE PRECISION A , B1 , B2 , C1 , C2 , D1 - DOUBLE PRECISION D2 , MCSTOR, ZERO - - A = START - ZERO = 0 - EMIN = 1 - B1 = MCSTOR( A/XBASE, ZERO ) - C1 = A - C2 = A - D1 = A - D2 = A -*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. -*+ $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP - 10 IF ( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. - $ ( D1.EQ.A ).AND.( D2.EQ.A ) )THEN - EMIN = EMIN - 1 - A = B1 - B1 = MCSTOR( A /XBASE, ZERO ) - C1 = MCSTOR( B1*XBASE, ZERO ) - D1 = ZERO - DO 20, I = 1, BASE - D1 = D1 + B1 - 20 CONTINUE - B2 = MCSTOR( A *RBASE, ZERO ) - C2 = MCSTOR( B2/RBASE, ZERO ) - D2 = ZERO - DO 30, I = 1, BASE - D2 = D2 + B2 - 30 CONTINUE - GO TO 10 - END IF -*+ END WHILE - RETURN - -* End of MCMIN (GETMIN). - - END
deleted file mode 100644 --- a/libcruft/npsol/mcsmal.f +++ /dev/null @@ -1,34 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DOUBLE PRECISION FUNCTION MCSMAL() - -* MCSMAL is intended to return a small positive value such that the -* reciprocal of MCSMAL does not overflow. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (SMALL). -* -* -- Written on 28-November-1984. -* Sven Hammarling, Nag Central Office. - - EXTERNAL MCENV2 - LOGICAL FIRST - INTEGER BETA , EMIN , T - DOUBLE PRECISION BASE , EPS , FLMIN , RMIN - - SAVE FIRST , FLMIN - DATA FIRST / .TRUE. / - - IF( FIRST )THEN - FIRST = .FALSE. - CALL MCENV2( BETA, T, EPS, EMIN, RMIN ) - BASE = BETA - FLMIN = RMIN*BASE**4 - END IF - - MCSMAL = FLMIN - RETURN - -* End of MCSMAL (SMALL). - - END
deleted file mode 100644 --- a/libcruft/npsol/mcstor.f +++ /dev/null @@ -1,22 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - DOUBLE PRECISION FUNCTION MCSTOR( A, B ) - DOUBLE PRECISION A, B - -* MCSTOR is intended to force A and B to be stored prior to doing -* the addition of A and B. For use in situations where optimizers -* might hold one of these in a register. -* -* -* Nag Fortran 77 O( 1 ) basic linear algebra routine (STORE). -* -* -- Written on 28-November-1984. -* Sven Hammarling, Nag Central Office. - - MCSTOR = A + B - - RETURN - -* End of MCSTOR (STORE). - - END
deleted file mode 100644 --- a/libcruft/npsol/npalf.f +++ /dev/null @@ -1,112 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File NPSUBS FORTRAN -* -* NPALF NPCHKD NPCORE NPCRSH NPDFLT NPFD NPFEAS -* NPFILE NPIQP NPKEY NPLOC NPMRT NPOPTN NPPRT -* NPRSET NPSETX NPSRCH NPUPDT NPSOL -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPALF ( INFORM, N, NCLIN, NCNLN, - $ ALFA, ALFMIN, ALFMAX, BIGBND, DXNORM, - $ ANORM, ADX, AX, BL, BU, - $ DSLK, DX, SLK, X ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - DOUBLE PRECISION ANORM(*), ADX(*), AX(*), BL(*), BU(*), - $ DSLK(*), DX(N), SLK(*), X(N) - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - LOGICAL CMDBG - INTEGER LCMDBG - PARAMETER (LCMDBG = 5) - COMMON /CMDEBG/ ICMDBG(LCMDBG), CMDBG - -************************************************************************ -* NPALF finds a step ALFA such that the point x + ALFA*P reaches one -* of the slacks or linear constraints. The step ALFA is the maximum -* step that can be taken without violating one of the slacks or linear -* constraints that is currently satisfied. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 77 version written June 1986. -* This version of NPALF dated 27-June-1986. -************************************************************************ - INTRINSIC ABS, MAX, MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - IF (CMDBG .AND. ICMDBG(3) .GT. 0) WRITE (NOUT, 1000) - - ALFA = ALFMAX - J = 1 - -*+ WHILE (J .LE. N+NCLIN+NCNLN .AND. ALFA .GT. ALFMIN) DO - 100 IF (J .LE. N+NCLIN+NCNLN .AND. ALFA .GT. ALFMIN) THEN - - IF (J .LE. N ) THEN - AXI = X(J) - ADXI = DX(J) - ROWNRM = ONE - ELSE IF (J .LE. N+NCLIN) THEN - I = J - N - AXI = AX(I) - ADXI = ADX(I) - ROWNRM = ANORM(I) + ONE - ELSE - I = J - N - NCLIN - AXI = SLK(I) - ADXI = DSLK(I) - ROWNRM = ONE - END IF - - RES = - ONE - IF (ADXI .LE. - EPSPT9*ROWNRM*DXNORM) THEN - -* Constraint decreasing. - - ADXI = - ADXI - IF (BL(J) .GT. -BIGBND) RES = AXI - BL(J) - - ELSE IF (ADXI .GT. EPSPT9*ROWNRM*DXNORM) THEN - -* Constraint increasing. - - IF (BU(J) .LT. BIGBND) RES = BU(J) - AXI - - END IF - - IF (RES .GT. ZERO .AND. ALFA*ADXI .GT. RES) - $ ALFA = RES / ADXI - - IF (CMDBG .AND. ICMDBG(3) .GT. 0) - $ WRITE (NOUT, 1200) J, RES, ADXI, ALFA - - J = J + 1 - GO TO 100 -*+ END WHILE - END IF - -* ================================================================== -* Determine ALFA, the bound on the step to be taken. -* ================================================================== - ALFA = MAX( ALFA, ALFMIN ) - - INFORM = 0 - IF (ALFA .GE. ALFMAX) INFORM = 1 - - IF (CMDBG .AND. ICMDBG(1) .GT. 0 .AND. INFORM .GT. 0) - $ WRITE (NOUT, 9010) ALFA - - RETURN - - 1000 FORMAT(/ ' NPALF entered' - $ / ' J RES AP ALFA '/) - 1200 FORMAT( I5, 3G15.5 ) - 9010 FORMAT(/ ' //NPALF // No finite step.' - $ / ' //NPALF // ALFA' - $ / ' //NPALF // ', G15.4 ) - -* End of NPALF . - - END
deleted file mode 100644 --- a/libcruft/npsol/npchkd.f +++ /dev/null @@ -1,208 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPCHKD( INFORM, MSGNP, NSTATE, LVLDER, NFUN, NGRAD, - $ NROWJ, NROWUJ, N, NCNLN, - $ CONFUN, OBJFUN, NEEDC, - $ BIGBND, EPSRF, CDINT, FDINT, - $ FDCHK, FDNORM, OBJF, XNORM, - $ BL, BU, C, C1, CJAC, UJAC, CJDX, - $ DX, GRAD, UGRAD, HFORWD, HCNTRL, - $ X, WRK1, WRK2, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER NEEDC(*) - DOUBLE PRECISION C(*), C1(*), CJAC(NROWJ,*), UJAC(NROWUJ,*), - $ CJDX(*) - DOUBLE PRECISION BL(N), BU(N), DX(N), GRAD(N), UGRAD(N), X(N) - DOUBLE PRECISION HFORWD(*), HCNTRL(*) - DOUBLE PRECISION WRK1(N+NCNLN), WRK2(N+NCNLN), W(LENW) - EXTERNAL CONFUN, OBJFUN - -************************************************************************ -* NPCHKD performs the following... -* (1) Computes the objective and constraint values OBJF and C. -* (2) Evaluates the user-provided gradients in UJAC and UGRAD. -* (3) Counts the missing gradients. -* (4) Loads the known gradients into GRAD and CJAC. -* (5) Checks that the known gradients are programmed correctly. -* (6) Computes the missing gradient elements. -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version written 4-September-1985. -* This version of NPCHKD dated 14-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - - LOGICAL CENTRL, NEEDFD - PARAMETER ( RDUMMY =-11111.0) - - INFORM = 0 - MODE = 2 - NFDIFF = 0 - NCDIFF = 0 - NCSET = N*NCNLN - - IF (NCNLN .GT. 0) THEN -* =============================================================== -* Compute the constraints and Jacobian matrix. -* =============================================================== -* If some derivatives are missing, load the Jacobian with dummy -* values. Any elements left unaltered after the call to CONFUN -* must be estimated. A record of the missing Jacobian elements -* is stored in UJAC. - - NEEDFD = LVLDER .EQ. 0 .OR. LVLDER .EQ. 1 - - IF (NEEDFD) THEN - DO 100 J = 1, N - CALL DLOAD ( NCNLN, RDUMMY, UJAC(1,J), 1 ) - 100 CONTINUE - END IF - - CALL ILOAD ( NCNLN, (1), NEEDC, 1 ) - - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - DO 110 J = 1, N - CALL DCOPY ( NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 ) - 110 CONTINUE - - IF (NEEDFD) THEN - -* Count the number of missing Jacobian elements. - - DO 220 J = 1, N - DO 210 I = 1, NCNLN - IF (UJAC(I,J) .EQ. RDUMMY) NCDIFF = NCDIFF + 1 - 210 CONTINUE - 220 CONTINUE - - NCSET = NCSET - NCDIFF - IF (NSTATE .EQ. 1) THEN - IF (NCDIFF .EQ. 0) THEN - IF (LVLDER .EQ. 0) LVLDER = 2 - IF (LVLDER .EQ. 1) LVLDER = 3 - WRITE (NOUT, 1000) LVLDER - ELSE IF (MSGNP .GT. 0) THEN - WRITE (NOUT, 1100) NCSET, N*NCNLN, NCDIFF - END IF - END IF - END IF - END IF - -* ================================================================== -* Repeat the procedure above for the objective function. -* ================================================================== - NEEDFD = LVLDER .EQ. 0 .OR. LVLDER .EQ. 2 - - IF (NEEDFD) - $ CALL DLOAD ( N, RDUMMY, UGRAD, 1 ) - - CALL OBJFUN( MODE, N, X, OBJF, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - CALL DCOPY ( N, UGRAD, 1, GRAD, 1 ) - - IF (NEEDFD) THEN - -* Count the number of missing gradient elements. - - DO 300 J = 1, N - IF (UGRAD(J) .EQ. RDUMMY) NFDIFF = NFDIFF + 1 - 300 CONTINUE - - IF (NSTATE .EQ. 1) THEN - IF (NFDIFF .EQ. 0) THEN - IF (LVLDER .EQ. 0) LVLDER = 1 - IF (LVLDER .EQ. 2) LVLDER = 3 - WRITE (NOUT, 2000) LVLDER - ELSE IF (MSGNP .GT. 0) THEN - WRITE (NOUT, 2100) N - NFDIFF, N, NFDIFF - END IF - END IF - END IF - - NFUN = NFUN + 1 - NGRAD = NGRAD + 1 - -* ================================================================== -* Check whatever gradient elements have been provided. -* ================================================================== - IF (LVRFYC .GE. 0) THEN - IF (NCSET .GT. 0) THEN - CALL CHKJAC( INFORM, LVLDER, MSGNP, - $ NCSET, N, NCNLN, NROWJ, NROWUJ, - $ BIGBND, EPSRF, EPSPT3, FDCHK, XNORM, - $ CONFUN, NEEDC, - $ BL, BU, C, C1, CJAC, UJAC, CJDX, - $ DX, WRK1, X, WRK2, W, LENW ) - IF (INFORM .LT. 0) GO TO 800 - END IF - - IF (NFDIFF .LT. N) THEN - CALL CHKGRD( INFORM, MSGNP, N, - $ BIGBND, EPSRF, EPSPT3, FDCHK, OBJF, XNORM, - $ OBJFUN, - $ BL, BU, GRAD, UGRAD, DX, X, WRK1, W, LENW ) - IF (INFORM .LT. 0) GO TO 800 - END IF - END IF - - NEEDFD = NCDIFF .GT. 0 .OR. NFDIFF .GT. 0 - IF (NEEDFD) THEN -* =============================================================== -* Compute the missing gradient elements. -* =============================================================== - CALL CHFD ( INFORM, MSGNP, LVLDER, - $ N, NCNLN, NROWJ, NROWUJ, - $ BIGBND, EPSRF, FDNORM, OBJF, - $ OBJFUN, CONFUN, NEEDC, - $ BL, BU, C, C1, CJDX, CJAC, UJAC, - $ GRAD, UGRAD, HFORWD, HCNTRL, X, - $ DX, W, LENW ) - - IF (INFORM .LT. 0) GO TO 800 - - IF (LFDSET .GT. 0) THEN - CENTRL = .FALSE. - CALL NPFD ( CENTRL, INFORM, - $ NROWJ, NROWUJ, N, NCNLN, - $ BIGBND, CDINT, FDINT, FDNORM, OBJF, - $ CONFUN, OBJFUN, NEEDC, - $ BL, BU, C, C1, CJDX, CJAC, UJAC, - $ GRAD, UGRAD, HFORWD, HCNTRL, X, - $ W, LENW ) - - IF (INFORM .LT. 0) GO TO 800 - END IF - END IF - - 800 RETURN - -* The user requested termination. - - 999 INFORM = MODE - RETURN - - 1000 FORMAT(//' All Jacobian elements have been set. ', - $ ' Derivative level increased to ', I4 ) - 1100 FORMAT(//' The user sets ', I6, ' out of', I6, - $ ' Jacobian elements.' - $ / ' Each iteration, ', I6, - $ ' Jacobian elements will be estimated numerically.' ) - 2000 FORMAT(//' All objective gradient elements have been set. ', - $ ' Derivative level increased to ', I4 ) - 2100 FORMAT(//' The user sets ', I6, ' out of', I6, - $ ' objective gradient elements.' - $ / ' Each iteration, ', I6, - $ ' gradient elements will be estimated numerically.' ) - -* End of NPCHKD. - - END
deleted file mode 100644 --- a/libcruft/npsol/npcore.f +++ /dev/null @@ -1,662 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPCORE( NAMED, NAMES, UNITQ, INFORM, MAJITS, - $ N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ, - $ NROWA, NROWJ, NROWUJ, NROWQP, NROWR, - $ NFUN, NGRAD, ISTATE, KACTIV, KX, - $ OBJF, FDNORM, XNORM, OBJFUN, CONFUN, - $ AQP, AX, BL, BU, C, CJAC, UJAC, CLAMDA, - $ FEATOL, GRAD, UGRAD, R, X, IW, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL NAMED - INTEGER ISTATE(*), KACTIV(N), KX(N) - INTEGER IW(*) - DOUBLE PRECISION AQP(NROWQP,*), AX(*), BL(NCTOTL), BU(NCTOTL), - $ C(*), CJAC(NROWJ,*), UJAC(NROWUJ,*) - DOUBLE PRECISION CLAMDA(NCTOTL), FEATOL(NCTOTL), GRAD(N), - $ UGRAD(N), R(NROWR,*), X(N) - DOUBLE PRECISION W(LENW) - EXTERNAL OBJFUN, CONFUN - - DOUBLE PRECISION ASIZE, DTMAX, DTMIN - CHARACTER*8 NAMES(*) - -************************************************************************ -* NPCORE is the core routine for NPSOL, a sequential quadratic -* programming (SQP) method for nonlinearly constrained optimization. -* -* Systems Optimization Laboratory, Stanford University. -* Original version February-1982. -* This version of NPCORE dated 4-August-1986. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT , NCOLT , NQ - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE , DTMAX , DTMIN - COMMON /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN - - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - PARAMETER (LENNP = 35) - COMMON /SOL1NP/ LOCNP(LENNP) - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - PARAMETER (LDBG = 5) - LOGICAL CMDBG, NPDBG - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG - -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- -*----------------------------------------------------------------------- - INTEGER IPRMNP(MXPARM), IPSVNP - DOUBLE PRECISION RPRMNP(MXPARM), RPSVNP - - COMMON /NPPAR1/ IPSVNP(MXPARM), - $ IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4, - $ LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF , - $ NLNJ , NLNX , NNCNLN, IPADNP(15) - - COMMON /NPPAR2/ RPSVNP(MXPARM), - $ CDINT , CTOL , EPSRF , ETA , FDINT , FTOL , - $ RPADNP(24) - - EQUIVALENCE (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT) - - SAVE /NPPAR1/, /NPPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (IDBGNP, IDBG ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR) - EQUIVALENCE (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP ) - - LOGICAL GOODGQ, NEWGQ - LOGICAL CENTRL, CONVRG, CONVPT, DONE , ERROR , FEASQP - LOGICAL INFEAS, NEEDFD, OPTIML, OVERFL, UNITQ - LOGICAL KTCOND(2) - INTRINSIC ABS , MAX , MIN , MOD , REAL , SQRT - EXTERNAL DDIV , DDOT , DNRM2 - - CHARACTER*4 LSUMRY - CHARACTER*2 JOB - PARAMETER ( JOB = 'NP' ) - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) - PARAMETER ( GROWTH=1.0D+2 ) - -* Specify machine-dependent parameters. - - EPSMCH = WMACH(3) - FLMAX = WMACH(7) - RTMAX = WMACH(8) - - LANORM = LOCLS( 2) - LRPQ = LOCLS( 5) - LQRWRK = LOCLS( 6) - LHPQ = LOCLS( 8) - LGQ = LOCLS( 9) - LRLAM = LOCLS(10) - LT = LOCLS(11) - LZY = LOCLS(12) - LWTINF = LOCLS(13) - LWRK1 = LOCLS(14) - LQPTOL = LOCLS(15) - - LIPERM = LOCNP( 2) - LAQP = LOCNP( 3) - LADX = LOCNP( 4) - LBL = LOCNP( 5) - LBU = LOCNP( 6) - LDX = LOCNP( 7) - LGQ1 = LOCNP( 8) - LX1 = LOCNP(11) - LWRK2 = LOCNP(12) - LCS1 = LOCNP(13) - LCS2 = LOCNP(14) - LC1MUL = LOCNP(15) - LCMUL = LOCNP(16) - LCJDX1 = LOCNP(17) - LDLAM = LOCNP(18) - LDSLK = LOCNP(19) - LRHO = LOCNP(20) - LWRK3 = LOCNP(21) - LSLK1 = LOCNP(22) - LSLK = LOCNP(23) - LNEEDC = LOCNP(24) - LHFRWD = LOCNP(25) - LHCTRL = LOCNP(26) - - LCJAC1 = LAQP + NCLIN - LCJDX = LADX + NCLIN - LVIOLN = LWRK3 - -* Initialize - - LSUMRY = ' ' - NQPINF = 0 - - NPLIN = N + NCLIN - NCQP = NCLIN + NCNLN - NL = MIN( NPLIN + 1, NCTOTL ) - - NROWJ1 = MAX( NCQP , 1 ) - - NEEDFD = LVLDER .EQ. 0 .OR. LVLDER .EQ. 2 - $ .OR. (LVLDER .EQ. 1 .AND. NCNLN .GT. 0) - - ALFA = ZERO - ALFDX = ZERO - RTFTOL = SQRT( FTOL ) - ROOTN = SQRT( REAL(N) ) - -* If debug printing is required, turn off any extensive printing -* until iteration IDBG. - - MSGSV1 = MSGNP - MSGSV2 = MSGQP - IF (IDBG .LE. NMAJOR .AND. IDBG .GT. 0) THEN - MSGNP = 0 - IF (MSGSV1 .GE. 5) MSGNP = 5 - MSGQP = 0 - IF (MSGSV2 .GE. 5) MSGQP = 5 - END IF - -* ------------------------------------------------------------------ -* Information from the feasibility phase will be used to generate a -* hot start for the first QP subproblem. -* ------------------------------------------------------------------ - CALL DCOPY ( NCTOTL, FEATOL, 1, W(LQPTOL), 1 ) - - MAJITS = 0 - NSTATE = 0 - - LVLDIF = 0 - IF (NEEDFD) LVLDIF = 1 - - OBJALF = OBJF - IF (NCNLN .GT. 0) THEN - OBJALF = OBJALF - DDOT ( NCNLN, W(LCMUL), 1, C, 1 ) - - INCRUN = .TRUE. - RHONRM = ZERO - RHODMP = ONE - SCALE = ONE - CALL DLOAD ( NCNLN, (ZERO), W(LRHO), 1 ) - END IF - - NEWGQ = .FALSE. - -*+ REPEAT -*+ REPEAT - - 100 CENTRL = LVLDIF .EQ. 2 - - IF (NEWGQ) THEN - IF (NEEDFD) THEN -* ------------------------------------------------------ -* Compute any missing gradient elements and the -* transformed gradient of the objective. -* ------------------------------------------------------ - CALL NPFD ( CENTRL, MODE, - $ NROWJ, NROWUJ, N, NCNLN, - $ BIGBND, CDINT, FDINT, FDNORM, OBJF, - $ CONFUN, OBJFUN, IW(LNEEDC), - $ BL, BU, C, W(LWRK2), W(LWRK3),CJAC,UJAC, - $ GRAD, UGRAD, W(LHFRWD), W(LHCTRL), X, - $ W, LENW ) - INFORM = MODE - IF (MODE .LT. 0) GO TO 800 - - END IF - - CALL DCOPY ( N, GRAD, 1, W(LGQ), 1 ) - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, - $ KX, W(LGQ), W(LZY), W(LWRK1) ) - - NEWGQ = .FALSE. - END IF - -* ============================================================ -* (1) Solve an inequality quadratic program (IQP) for the -* search direction and multiplier estimates. -* (2) For each nonlinear inequality constraint, compute -* the slack variable for which the merit function is -* minimized. -* (3) Compute the search direction for the slack variables -* and multipliers. -* -* Note that the array VIOLN is WRK3. -* ============================================================ - CALL NPIQP ( FEASQP, UNITQ, NQPERR, MINITS, - $ N, NCLIN, NCNLN, NROWA, NROWJ, NROWQP,NROWR, - $ LINACT, NLNACT, NACTIV, NFREE, NZ, NUMINF, - $ ISTATE, KACTIV, KX, - $ DXNORM, GDX, QPCURV, - $ AQP, W(LADX), W(LANORM), AX, BL, BU, - $ C, CJAC, CLAMDA, W(LCMUL), W(LCS1), - $ W(LDLAM), W(LDSLK), W(LDX), W(LBL), W(LBU), - $ W(LQPTOL), R, W(LRHO), W(LSLK), W(LVIOLN), X, - $ W(LWTINF), IW, W ) - - IF (FEASQP) THEN - NQPINF = 0 - ELSE - NQPINF = NQPINF + 1 - LSUMRY(2:2) = 'Infeasible subproblem' - END IF - -* ============================================================ -* Compute quantities needed for the convergence test. -* ============================================================ -* Compute the norms of the projected gradient and the -* gradient with respect to the free variables. - - GZNORM = ZERO - IF (NZ .GT. 0) - $ GZNORM = DNRM2 ( NZ , W(LGQ), 1 ) - GFNORM = GZNORM - IF (NFREE .GT. 0 .AND. NACTIV .GT. 0) - $ GFNORM = DNRM2 ( NFREE, W(LGQ), 1 ) - -* If the forward-difference estimate of the transformed -* gradient of the Lagrangian function is small, switch to -* central differences, recompute the derivatives and re-solve -* the QP. - - GOODGQ = .TRUE. - IF (NEEDFD .AND. .NOT. CENTRL) THEN - - GLNORM = DNRM2 ( N, W(LHPQ), 1 ) - IF (NCNLN .EQ. 0) THEN - CNORM = ZERO - ELSE - CNORM = DNRM2 ( NCNLN, C, 1 ) - END IF - - GLTEST = (ONE + ABS(OBJF) + ABS(CNORM))*EPSRF/FDNORM - IF (GLNORM .LE. GLTEST) THEN - GOODGQ = .FALSE. - LSUMRY(3:3) = 'Central differences' - LVLDIF = 2 - NEWGQ = .TRUE. - END IF - - END IF - -*+ UNTIL (GOODGQ) - IF (.NOT. GOODGQ ) GO TO 100 - -* =============================================================== -* (1) Compute the number of constraints that are violated by more -* than FEATOL. -* (2) Compute the 2-norm of the residuals of the constraints in -* the QP working set. -* =============================================================== - CALL NPFEAS( N, NCLIN, NCNLN, ISTATE, - $ BIGBND, CVNORM, ERRMAX, JMAX, NVIOL, - $ AX, BL, BU, C, FEATOL, X, W(LWRK2) ) - -* Define small quantities that reflect the magnitude of OBJF and -* the norm of GRAD(free). - - OBJSIZ = ONE + ABS( OBJF ) - XSIZE = ONE + XNORM - GTEST = MAX( OBJSIZ, GFNORM ) - DINKY = RTFTOL * GTEST - - IF (NACTIV .EQ. 0) THEN - CONDT = ZERO - ELSE IF (NACTIV .EQ. 1) THEN - CONDT = DTMIN - ELSE - CONDT = DDIV ( DTMAX, DTMIN, OVERFL ) - END IF - - CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN ) - - CONDH = DDIV ( DRMAX, DRMIN, OVERFL ) - IF (CONDH .LT. RTMAX) THEN - CONDH = CONDH*CONDH - ELSE - CONDH = FLMAX - END IF - - IF (NZ .EQ. 0) THEN - CONDHZ = ONE - ELSE IF (NZ .EQ. N) THEN - CONDHZ = CONDH - ELSE - CALL DCOND ( NZ, R, NROWR+1, DRZMAX, DRZMIN ) - CONDHZ = DDIV ( DRZMAX, DRZMIN, OVERFL ) - IF (CONDHZ .LT. RTMAX) THEN - CONDHZ = CONDHZ*CONDHZ - ELSE - CONDHZ = FLMAX - END IF - END IF - -* --------------------------------------------------------------- -* Test for convergence. -* The point test CONVPT checks for a K-T point at the initial -* point or after a large change in X. -* --------------------------------------------------------------- - CONVPT = GZNORM .LE. EPSPT8*GTEST .AND. NVIOL .EQ. 0 - - KTCOND(1) = GZNORM .LT. DINKY - KTCOND(2) = NVIOL .EQ. 0 - OPTIML = KTCOND(1) .AND. KTCOND(2) - - CONVRG = MAJITS .GT. 0 .AND. ALFDX .LE. RTFTOL*XSIZE - - INFEAS = CONVRG .AND. .NOT. FEASQP - $ .OR. NQPINF .GT. 7 - - DONE = CONVPT .OR. (CONVRG .AND. OPTIML) - $ .OR. INFEAS - - OBJALF = OBJF - GRDALF = GDX - GLF1 = GDX - IF (NCNLN .GT. 0) THEN - GLF1 = GLF1 - $ - DDOT( NCNLN, W(LCJDX), 1, CLAMDA(NL), 1 ) - -* Compute the value and directional derivative of the -* augmented Lagrangian merit function. -* The penalty parameters may be increased or decreased. - - CALL NPMRT ( FEASQP, N, NCLIN, NCNLN, - $ OBJALF, GRDALF, QPCURV, - $ ISTATE, - $ W(LCJDX), W(LCMUL), W(LCS1), - $ W(LDLAM), W(LRHO), W(LVIOLN), - $ W(LWRK1), W(LWRK2) ) - END IF - -* =============================================================== -* Print the details of this iteration. -* =============================================================== - CALL NPPRT ( KTCOND, CONVRG, LSUMRY, MSGNP, MSGQP, - $ NROWR, NROWT, N, NCLIN, NCNLN, - $ NCTOTL, NACTIV, LINACT, NLNACT, NZ, NFREE, - $ MAJITS, MINITS, ISTATE, ALFA, NFUN, - $ CONDHZ, CONDH, CONDT, OBJALF, OBJF, - $ GFNORM, GZNORM, CVNORM, - $ AX, C, R, W(LT), W(LVIOLN), X, W(LWRK1) ) - - ALFA = ZERO - ERROR = MAJITS .GE. NMAJOR - - IF (.NOT. (DONE .OR. ERROR)) THEN - MAJITS = MAJITS + 1 - - IF (MAJITS .EQ. IDBG) THEN - NPDBG = .TRUE. - CMDBG = NPDBG - MSGNP = MSGSV1 - MSGQP = MSGSV2 - END IF - -* Make copies of information needed for the BFGS update. - - CALL DCOPY ( N, X , 1, W(LX1) , 1 ) - CALL DCOPY ( N, W(LGQ), 1, W(LGQ1), 1 ) - - IF (NCNLN .GT. 0) THEN - CALL DCOPY ( NCNLN, W(LCJDX), 1, W(LCJDX1), 1 ) - CALL DCOPY ( NCNLN, W(LCMUL), 1, W(LC1MUL), 1 ) - CALL DCOPY ( NCNLN, W(LSLK) , 1, W(LSLK1) , 1 ) - END IF - -* ============================================================ -* Compute the parameters for the linesearch. -* ============================================================ -* Compute ALFMAX, the largest feasible step. Also compute -* ALFBND, a tentative upper bound on the step. If the -* merit function is decreasing at ALFBND and certain -* conditions hold, ALFBND will be increased in multiples -* of two (subject to not being greater than ALFMAX). - - ALFMAX = DDIV ( BIGDX, DXNORM, OVERFL ) - ALFMIN = ONE - IF (.NOT. FEASQP) ALFMIN = ZERO - - CALL NPALF ( INFO, N, NCLIN, NCNLN, - $ ALFA, ALFMIN, ALFMAX, BIGBND, DXNORM, - $ W(LANORM), W(LADX), AX, BL, BU, - $ W(LDSLK), W(LDX), W(LSLK), X ) - - ALFMAX = ALFA - IF (ALFMAX .LT. ONE + EPSPT3 .AND. FEASQP) - $ ALFMAX = ONE - - IF (NCNLN .EQ. 0) THEN - ALFBND = ALFMAX - ELSE - IF (NEEDFD) ALFMAX = ONE - ALFBND = MIN( ONE, ALFMAX ) - END IF - ALFA = ONE - - ALFSML = ZERO - IF (NEEDFD .AND. .NOT. CENTRL) THEN - ALFSML = DDIV ( FDNORM, DXNORM, OVERFL ) - ALFSML = MIN ( ALFSML, ALFMAX ) - END IF - -* ============================================================ -* Compute the steplength using safeguarded interpolation. -* ============================================================ - CALL NPSRCH( NEEDFD, NLSERR, N, NCNLN, - $ NROWJ, NROWUJ, NFUN, NGRAD, - $ IW(LNEEDC), CONFUN, OBJFUN, - $ ALFA, ALFBND, ALFMAX, ALFSML, DXNORM, - $ EPSRF, ETA, GDX, GRDALF, GLF1, GLF2, - $ OBJF, OBJALF, QPCURV, XNORM, - $ C, CJAC, UJAC, W(LCJDX), - $ W(LC1MUL), W(LCMUL), W(LCS1), - $ W(LCS2), W(LDX), W(LDLAM), W(LDSLK), GRAD, - $ UGRAD, CLAMDA(NL), W(LRHO), - $ W(LSLK1), W(LSLK), W(LX1), X, W, LENW ) - -* ------------------------------------------------------------ -* NPSRCH sets NLSERR to the following values... -* -* NLSERR will be negative if the user set MODE LT 0. -* -* Values of NLSERR occurring with a nonzero value of ALFA. -* 1 -- if the search was successful and ALFA LT ALFMAX. -* 2 -- if the search was successful and ALFA = ALFMAX. -* 3 -- if the search ended after MFSRCH iterations. -* -* Values of NLSERR occurring with a zero value of ALFA.... -* 4 -- if ALFMAX was too small. -* 6 -- if no improved point could be found. -* 7 -- if the input value of GDX is non-negative. -* ------------------------------------------------------------ - IF (NLSERR .LT. 0) THEN - INFORM = NLSERR - GO TO 800 - END IF - - ERROR = NLSERR .GE. 4 - IF (ERROR) THEN -* --------------------------------------------------------- -* The linesearch failed to find a better point. -* If exact gradients or central differences are being used, -* or the KT conditions are satisfied, stop. Otherwise, -* switch to central differences and re-solve the QP. -* --------------------------------------------------------- - IF (NEEDFD .AND. .NOT. CENTRL) THEN - IF (.NOT. OPTIML) THEN - ERROR = .FALSE. - LSUMRY(3:3) = 'Central differences' - LVLDIF = 2 - NEWGQ = .TRUE. - END IF - END IF - ELSE - IF (NEEDFD) THEN -* ====================================================== -* Compute the missing gradients. -* ====================================================== - MODE = 1 - NGRAD = NGRAD + 1 - - IF (NCNLN .GT. 0) THEN - CALL ILOAD ( NCNLN, (1), IW(LNEEDC), 1 ) - - CALL CONFUN( MODE, NCNLN, N, NROWUJ, IW(LNEEDC), - $ X, W(LWRK1), UJAC, NSTATE ) - INFORM = MODE - IF (MODE .LT. 0) GO TO 800 - - DO 410 J = 1, N - CALL DCOPY (NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 ) - 410 CONTINUE - END IF - - CALL OBJFUN( MODE, N, X, OBJ, UGRAD, NSTATE ) - INFORM = MODE - IF (MODE .LT. 0) GO TO 800 - - CALL DCOPY ( N, UGRAD, 1, GRAD, 1 ) - - CALL NPFD ( CENTRL, MODE, - $ NROWJ, NROWUJ, N, NCNLN, - $ BIGBND, CDINT, FDINT, FDNORM, OBJF, - $ CONFUN, OBJFUN, IW(LNEEDC), - $ BL, BU, C, W(LWRK2), W(LWRK3),CJAC,UJAC, - $ GRAD, UGRAD, W(LHFRWD), W(LHCTRL), X, - $ W, LENW ) - - INFORM = MODE - IF (MODE .LT. 0) GO TO 800 - - GDX = DDOT( N, GRAD, 1, W(LDX), 1 ) - GLF2 = GDX - IF (NCNLN .GT. 0) THEN - CALL DGEMV ( 'N', NCNLN, N, ONE, CJAC, NROWJ, - $ W(LDX), 1, ZERO, W(LCJDX), 1 ) - GLF2 = GLF2 - - $ DDOT( NCNLN, W(LCJDX), 1, CLAMDA(NL), 1 ) - END IF - END IF - - CALL DCOPY ( N, GRAD, 1, W(LGQ), 1 ) - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, - $ KX, W(LGQ), W(LZY), W(LWRK1) ) - - XNORM = DNRM2 ( N, X, 1 ) - - IF (NCNLN .GT. 0 .AND. ALFA .GE. ONE) - $ CALL DCOPY ( NCNLN, CLAMDA(NL), 1, W(LCMUL), 1 ) - - IF (NCLIN .GT. 0) - $ CALL DAXPY ( NCLIN, ALFA, W(LADX), 1, AX, 1 ) - ALFDX = ALFA * DXNORM - -* ========================================================= -* Update the factors of the approximate Hessian of the -* Lagrangian function. -* ========================================================= - CALL NPUPDT( LSUMRY, UNITQ, - $ N, NCNLN, NFREE, NZ, - $ NROWJ1, NROWJ, NQ, NROWR, KX, - $ ALFA, GLF1, GLF2, QPCURV, - $ W(LCJAC1), CJAC, W(LCJDX1), W(LCJDX), - $ W(LCS1), W(LCS2), W(LGQ1), W(LGQ), - $ W(LHPQ), W(LRPQ), CLAMDA(NL), R, - $ W(LWRK3), W(LZY), W(LWRK2), W(LWRK1) ) - - CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN ) - COND = DDIV ( DRMAX, DRMIN, OVERFL ) - - IF ( COND .GT. RCNDBD - $ .OR. RFROBN .GT. ROOTN*GROWTH*DRMAX) THEN -* ------------------------------------------------------ -* Reset the condition estimator and range-space -* partition of Q'HQ. -* ------------------------------------------------------ - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 9000) RFROBN, DRMAX, DRMIN,COND,RCNDBD - - LSUMRY(4:4) = 'Refactorize Hessian' - - CALL NPRSET( UNITQ, - $ N, NFREE, NZ, NQ, NROWR, - $ IW(LIPERM), KX, - $ W(LGQ), R, W(LZY), W(LWRK1), W(LQRWRK) ) - END IF - END IF - END IF - -*+ UNTIL (DONE .OR. ERROR) - IF (.NOT. (DONE .OR. ERROR) ) GO TO 100 - -* ======================end of main loop============================ - - IF (DONE) THEN - IF (CONVPT .OR. OPTIML) THEN - INFORM = 0 - ELSE IF (INFEAS) THEN - INFORM = 3 - END IF - ELSE IF (ERROR) THEN - IF (MAJITS .GE. NMAJOR) THEN - INFORM = 4 - ELSE IF (OPTIML) THEN - INFORM = 1 - ELSE - INFORM = 6 - END IF - END IF - -* ------------------------------------------------------------------ -* Set CLAMDA. Print the full solution. -* ------------------------------------------------------------------ - 800 MSGNP = MSGSV1 - MSGQP = MSGSV2 - IF (MSGNP .GT. 0) - $ WRITE (NOUT, 2100) INFORM, MAJITS, NFUN, NGRAD - - CALL CMPRT ( MSGNP, NFREE, NROWQP, - $ N, NCLIN, NCNLN, NCTOTL, BIGBND, - $ NAMED, NAMES, LENNAM, - $ NACTIV, ISTATE, KACTIV, KX, - $ AQP, BL, BU, C, CLAMDA, W(LRLAM), X ) - - RETURN - - 2100 FORMAT(/ ' Exit NP phase. INFORM = ', I2, ' MAJITS = ', I5, - $ ' NFUN = ', I5, ' NGRAD = ', I5 ) - - 9000 FORMAT(/ ' //NPCORE// RFROBN DRMAX DRMIN' - $ / ' //NPCORE//', 1P3E14.2 - $ / ' //NPCORE// COND RCNDBD' - $ / ' //NPCORE//', 1P2E14.2 ) - -* End of NPCORE. - - END
deleted file mode 100644 --- a/libcruft/npsol/npcrsh.f +++ /dev/null @@ -1,128 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPCRSH( COLD, N, NCLIN, NCNLN, - $ NCTOTL, NACTIV, NFREE, NZ, - $ ISTATE, KACTIV, BIGBND, TOLACT, - $ BL, BU, C ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL COLD - INTEGER ISTATE(NCTOTL), KACTIV(N) - DOUBLE PRECISION C(*), BL(NCTOTL), BU(NCTOTL) -************************************************************************ -* NPCRSH adds indices of nonlinear constraints to the initial working -* set. -* -* Systems Optimization Laboratory, Stanford University. -* Original version 14-February 1985. -* This version of NPCRSH dated 14-November-1985. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - - LOGICAL NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - INTRINSIC ABS, MIN - PARAMETER ( ONE = 1.0D+0 ) - - NFIXED = N - NFREE - LINACT = NACTIV - NPLIN = N + NCLIN - -* If a cold start is being made, initialize the status of the QP -* working set. First, if BL(j) = BU(j), set ISTATE(j)=3. - - IF (COLD) THEN - DO 130 J = NPLIN+1, NCTOTL - ISTATE(J) = 0 - IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3 - 130 CONTINUE - END IF - -* Increment NACTIV and KACTIV. -* Ensure that the number of bounds and general constraints in the -* QP working set does not exceed N. - - DO 200 J = NPLIN+1, NCTOTL - IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0 - IF (ISTATE(J) .GT. 0) THEN - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = J - N - END IF - 200 CONTINUE - - IF (COLD) THEN - -* --------------------------------------------------------------- -* If a cold start is required, an attempt is made to add as many -* nonlinear constraints as possible to the working set. -* --------------------------------------------------------------- -* The following loop finds the most violated constraint. If -* there is room in KACTIV, it will be added to the working set -* and the process will be repeated. - - - IS = 1 - BIGLOW = - BIGBND - BIGUPP = BIGBND - TOOBIG = TOLACT + TOLACT - -* while (is .gt. 0 .and. nfixed + nactiv .lt. n) do - 500 IF (IS .GT. 0 .AND. NFIXED + NACTIV .LT. N) THEN - IS = 0 - CMIN = TOLACT - - DO 520 I = 1, NCNLN - J = NPLIN + I - IF (ISTATE(J) .EQ. 0) THEN - B1 = BL(J) - B2 = BU(J) - RESL = TOOBIG - RESU = TOOBIG - IF (B1 .GT. BIGLOW) - $ RESL = ABS( C(I) - B1 ) / (ONE + ABS( B1 )) - IF (B2 .LT. BIGUPP) - $ RESU = ABS( C(I) - B2 ) / (ONE + ABS( B2 )) - RES = MIN( RESL, RESU ) - IF (RES .LT. CMIN) THEN - CMIN = RES - IMIN = I - IS = 1 - IF (RESL .GT. RESU) IS = 2 - END IF - END IF - 520 CONTINUE - - IF (IS .GT. 0) THEN - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = NCLIN + IMIN - J = NPLIN + IMIN - ISTATE(J) = IS - END IF - GO TO 500 -* end while - END IF - END IF - -* ------------------------------------------------------------------ -* An initial working set has now been selected. -* ------------------------------------------------------------------ - NLNACT = NACTIV - LINACT - NZ = NFREE - NACTIV - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) NFIXED, LINACT, NLNACT - - RETURN - - 1000 FORMAT(/ ' //NPCRSH// Working set selected....' - $ / ' //NPCRSH// NFIXED LINACT NLNACT ' - $ / ' //NPCRSH//', 3I7 ) - -* End of NPCRSH. - - END
deleted file mode 100644 --- a/libcruft/npsol/npdflt.f +++ /dev/null @@ -1,256 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPDFLT( N, NCLIN, NCNLN, LENIW, LENW, TITLE ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - - CHARACTER*(*) TITLE - -************************************************************************ -* NPDFLT loads the default values of parameters not set in the options -* file. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 77 version written 10-September-1985. -* This version of NPDFLT dated 14-July-1986. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - - LOGICAL CMDBG, LSDBG, NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG - - LOGICAL NEWOPT - COMMON /SOL7NP/ NEWOPT - SAVE /SOL7NP/ - -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- -*----------------------------------------------------------------------- - INTEGER IPRMNP(MXPARM), IPSVNP - DOUBLE PRECISION RPRMNP(MXPARM), RPSVNP - - COMMON /NPPAR1/ IPSVNP(MXPARM), - $ IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4, - $ LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF , - $ NLNJ , NLNX , NNCNLN, IPADNP(15) - - COMMON /NPPAR2/ RPSVNP(MXPARM), - $ CDINT , CTOL , EPSRF , ETA , FDINT , FTOL , - $ RPADNP(24) - - EQUIVALENCE (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT) - - SAVE /NPPAR1/, /NPPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (IDBGNP, IDBG ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR) - EQUIVALENCE (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP ) - - INTRINSIC ABS , LEN , MOD - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - PARAMETER ( POINT3 = 3.3D-1, POINT8 = 0.8D+0 ) - PARAMETER ( POINT9 = 0.9D+0 ) - PARAMETER ( RDUMMY = -11111., IDUMMY = -11111 ) - PARAMETER ( GIGANT = 1.0D+10*.99999 ) - PARAMETER ( WRKTOL = 1.0D-2 ) - - CHARACTER*4 ICRSH(0:2) - CHARACTER*16 KEY - DATA ICRSH(0), ICRSH(1), ICRSH(2) - $ / 'COLD' , 'WARM' , 'HOT ' / - - EPSMCH = WMACH( 3) - NOUT = WMACH(11) - NCQP = NCLIN + NCNLN - NPLIN = N + NCLIN - NCTOTL = NPLIN + NCNLN - -* Make a dummy call NPKEY to ensure that the defaults are set. - - CALL NPKEY ( NOUT, '*', KEY ) - NEWOPT = .TRUE. - -* Save the optional parameters set by the user. The values in -* IPRMLS, RPRMLS, IPRMNP and RPRMNP may be changed to their -* default values. - - CALL ICOPY ( MXPARM, IPRMLS, 1, IPSVLS, 1 ) - CALL DCOPY ( MXPARM, RPRMLS, 1, RPSVLS, 1 ) - CALL ICOPY ( MXPARM, IPRMNP, 1, IPSVNP, 1 ) - CALL DCOPY ( MXPARM, RPRMNP, 1, RPSVNP, 1 ) - - IF ( LCRASH .LT. 0 - $ .OR. LCRASH .GT. 2 ) LCRASH = 0 - IF ( LVLDER .LT. 0 - $ .OR. LVLDER .GT. 3 ) LVLDER = 3 - IF ( LFORMH .LT. 0 - $ .OR. LFORMH .GT. 1 ) LFORMH = 0 - IF ( NMAJOR .LT. 0 ) NMAJOR = MAX(50, 3*NPLIN+ - $ 10*NCNLN ) - IF ( NMINOR .LT. 1 ) NMINOR = MAX(50, 3*NCTOTL) - IF ( MJRDBG .LT. 0 ) MJRDBG = 0 - IF ( MNRDBG .LT. 0 ) MNRDBG = 0 - IF ( IDBG .LT. 0 - $ .OR. IDBG .GT. NMAJOR) IDBG = 0 - IF ( MJRDBG .EQ. 0 - $ .AND. MNRDBG .EQ. 0 ) IDBG = NMAJOR + 1 - IF ( MSGNP .EQ. IDUMMY) MSGNP = 10 - IF ( MSGQP .EQ. IDUMMY) MSGQP = 0 - NLNF = N - NLNJ = N - NLNX = N - IF ( JVRFY2 .LT. 0 - $ .OR. JVRFY2 .GT. N ) JVRFY2 = N - IF ( JVRFY1 .LT. 0 - $ .OR. JVRFY1 .GT. JVRFY2) JVRFY1 = 1 - IF ( JVRFY4 .LT. 0 - $ .OR. JVRFY4 .GT. N ) JVRFY4 = N - IF ( JVRFY3 .LT. 0 - $ .OR. JVRFY3 .GT. JVRFY4) JVRFY3 = 1 - IF ( LVERFY .EQ. IDUMMY - $ .OR. LVERFY .GT. 13 ) LVERFY = 0 - IF ( TOLACT .LT. ZERO - $ .OR. TOLACT .GE. ONE ) TOLACT = WRKTOL - IF ( TOLFEA .LT. EPSMCH - $ .OR. TOLFEA .GE. ONE ) TOLFEA = EPSPT5 - IF ( EPSRF .LT. EPSMCH - $ .OR. EPSRF .GE. ONE ) EPSRF = EPSPT9 - LFDSET = 0 - IF ( FDINT .LT. ZERO ) LFDSET = 2 - IF ( FDINT .EQ. RDUMMY) LFDSET = 0 - IF ( FDINT .GE. EPSMCH - $ .AND. FDINT .LT. ONE ) LFDSET = 1 - IF ( LFDSET .EQ. 1 - $ .AND. (CDINT .LT. EPSMCH - $ .OR. CDINT .GE. ONE )) CDINT = EPSRF**POINT3 - IF ( BIGBND .LE. ZERO ) BIGBND = GIGANT - IF ( BIGDX .LE. ZERO ) BIGDX = MAX( GIGANT,BIGBND ) - IF ( ETA .LT. ZERO - $ .OR. ETA .GE. ONE ) ETA = POINT9 - IF ( FTOL .LT. EPSRF - $ .OR. FTOL .GE. ONE ) FTOL = EPSRF**POINT8 - - DCTOL = EPSPT5 - IF ( LVLDER .LT. 2 ) DCTOL = EPSPT3 - IF ( CTOL .LT. EPSMCH - $ .OR. CTOL .GE. ONE ) CTOL = DCTOL - - ITMAX1 = MAX( 50, 3*(N + NCLIN + NCNLN) ) - JVERFY(1) = JVRFY1 - JVERFY(2) = JVRFY2 - JVERFY(3) = JVRFY3 - JVERFY(4) = JVRFY4 - - NPDBG = IDBG .EQ. 0 - CMDBG = NPDBG - - K = 1 - MSG1 = MJRDBG - MSG2 = MNRDBG - DO 200 I = 1, LDBG - INPDBG(I) = MOD( MSG1/K, 10 ) - ICMDBG(I) = INPDBG(I) - ILSDBG(I) = MOD( MSG2/K, 10 ) - K = K*10 - 200 CONTINUE - - IF (MSGNP .GT. 0) THEN - -* Print the title. - - LENT = LEN( TITLE ) - IF (LENT .GT. 0) THEN - NSPACE = (81 - LENT)/2 + 1 - WRITE (NOUT, '(///// (80A1) )') - $ (' ', J=1, NSPACE), (TITLE(J:J), J=1,LENT) - WRITE (NOUT, '(80A1 //)') - $ (' ', J=1, NSPACE), ('=' , J=1,LENT) - END IF - - WRITE (NOUT, 2000) - WRITE (NOUT, 2100) NCLIN , TOLFEA, ICRSH(LCRASH) , - $ N , BIGBND, TOLACT, - $ BIGDX - WRITE (NOUT, 2200) NCNLN , FTOL , EPSRF , - $ NLNJ , CTOL , - $ NLNF , ETA , - $ EPSMCH, - $ LVLDER, LVERFY - WRITE (NOUT, 2300) NMAJOR, MSGNP, - $ NMINOR, MSGQP - - IF (LVLDER .LT. 3) THEN - IF (LFDSET .EQ. 0) THEN - WRITE (NOUT, 2400) - ELSE IF (LFDSET .EQ. 1) THEN - WRITE (NOUT, 2401) FDINT, CDINT - ELSE IF (LFDSET .EQ. 2) THEN - WRITE (NOUT, 2402) - END IF - END IF - - END IF - - RETURN - - 2000 FORMAT( - $//' Parameters' - $/ ' ----------' ) - 2100 FORMAT( - $/ ' Linear constraints.....', I10, 6X, - $ ' Linear feasibility.....', 1PE10.2, 6X, - $ 1X, A4, ' start.............' - $/ ' Variables..............', I10, 6X, - $ ' Infinite bound size....', 1PE10.2, 6X, - $ ' Crash tolerance........', 1PE10.2 - $/ 24X, 16X, - $ ' Infinite step size.....', 1PE10.2 ) - 2200 FORMAT( - $/ ' Nonlinear constraints..', I10, 6X, - $ ' Optimality tolerance...', 1PE10.2, 6X, - $ ' Function precision.....', 1PE10.2 - $/ ' Nonlinear Jacobian vars', I10, 6X, - $ ' Nonlinear feasibility..', 1PE10.2 - $/ ' Nonlinear objectiv vars', I10, 6X, - $ ' Linesearch tolerance...', 1PE10.2 - $/ ' EPS (machine precision)', 1PE10.2, 6X, - $ ' Derivative level.......', I10, 6X, - $ ' Verify level...........', I10) - 2300 FORMAT( - $/ ' Major iterations limit.', I10, 6X, - $ ' Major print level......', I10 - $/ ' Minor iterations limit.', I10, 6X, - $ ' Minor print level......', I10 ) - 2400 FORMAT(/ ' Difference intervals to be computed.' ) - 2401 FORMAT(/ ' Difference interval....', 1PE10.2, 6X, - $ ' Central diffce interval', 1PE10.2 ) - 2402 FORMAT(/ ' User-supplied difference intervals.' ) - -* End of NPDFLT. - - END
deleted file mode 100644 --- a/libcruft/npsol/npfd.f +++ /dev/null @@ -1,165 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPFD ( CENTRL, INFORM, - $ NROWJ, NROWUJ, N, NCNLN, - $ BIGBND, CDINT, FDINT, FDNORM, OBJF, - $ CONFUN, OBJFUN, NEEDC, - $ BL, BU, C, C1, C2, CJAC, UJAC, - $ GRAD, UGRAD, HFORWD, HCNTRL, X, - $ W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL CENTRL - INTEGER NEEDC(*) - - DOUBLE PRECISION BL(N), BU(N), C(*), C1(*), C2(*), - $ CJAC(NROWJ,*), UJAC(NROWUJ,*) - DOUBLE PRECISION GRAD(N), UGRAD(N), HFORWD(N), HCNTRL(N), X(N) - DOUBLE PRECISION W(LENW) - EXTERNAL CONFUN, OBJFUN - -************************************************************************ -* NPFD evaluates any missing gradients. -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version written 3-July-1986. -* This version of NPFD dated 14-July-1986. -************************************************************************ - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - INTRINSIC ABS , MAX - - PARAMETER (RDUMMY=-11111.0) - PARAMETER (ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0) - PARAMETER (TWO = 2.0D+0, THREE = 3.0D+0, FOUR = 4.0D+0) - - INFORM = 0 - -* ================================================================== -* Use the pre-assigned difference intervals to approximate the -* derivatives. -* ================================================================== -* Use either the same interval for each component (LFDSET = 1), -* or the intervals already in HFORWD or HCNTRL (LFDSET = 0 or 2). - - NSTATE = 0 - MODE = 0 - - BIGLOW = - BIGBND - BIGUPP = BIGBND - - FDNORM = ZERO - - DO 340 J = 1, N - - XJ = X(J) - NFOUND = 0 - IF (NCDIFF .GT. 0) THEN - DO 310 I = 1, NCNLN - IF (UJAC(I,J) .EQ. RDUMMY) THEN - NEEDC(I) = 1 - NFOUND = NFOUND + 1 - ELSE - NEEDC(I) = 0 - END IF - 310 CONTINUE - END IF - - IF (NFOUND .GT. 0 .OR. UGRAD(J) .EQ. RDUMMY) THEN - STEPBL = BIGLOW - STEPBU = BIGUPP - IF (BL(J) .GT. BIGLOW) STEPBL = BL(J) - XJ - IF (BU(J) .LT. BIGUPP) STEPBU = BU(J) - XJ - - IF (CENTRL) THEN - IF (LFDSET .EQ. 1) THEN - DELTA = CDINT - ELSE - DELTA = HCNTRL(J) - END IF - ELSE - IF (LFDSET .EQ. 1) THEN - DELTA = FDINT - ELSE - DELTA = HFORWD(J) - END IF - END IF - - DELTA = DELTA*(ONE + ABS(XJ)) - FDNORM = MAX (FDNORM, DELTA) - IF (HALF*(STEPBL + STEPBU) .LT. ZERO) DELTA = - DELTA - - X(J) = XJ + DELTA - IF (NFOUND .GT. 0) THEN - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C1, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - END IF - - IF (UGRAD(J) .EQ. RDUMMY) THEN - CALL OBJFUN( MODE, N, X, OBJF1, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - END IF - - IF (CENTRL) THEN -* --------------------------------------------------------- -* Central differences. -* --------------------------------------------------------- - X(J) = XJ + DELTA + DELTA - - IF (NFOUND .GT. 0) THEN - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, C2, UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - DO 320 I = 1, NCNLN - IF (NEEDC(I) .EQ. 1) - $ CJAC(I,J) = (FOUR*C1(I) - THREE*C(I) - C2(I)) - $ / (DELTA + DELTA) - 320 CONTINUE - END IF - - IF (UGRAD(J) .EQ. RDUMMY) THEN - CALL OBJFUN( MODE, N, X, OBJF2, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - GRAD(J) = (FOUR*OBJF1 - THREE*OBJF - OBJF2) - $ / (DELTA + DELTA) - - END IF - ELSE -* --------------------------------------------------------- -* Forward Differences. -* --------------------------------------------------------- - IF (NFOUND .GT. 0) THEN - DO 330 I = 1, NCNLN - IF (NEEDC(I) .EQ. 1) - $ CJAC(I,J) = (C1(I) - C(I))/ DELTA - 330 CONTINUE - END IF - - IF (UGRAD(J) .EQ. RDUMMY) - $ GRAD(J) = (OBJF1 - OBJF) / DELTA - - END IF - END IF - X(J) = XJ - - 340 CONTINUE - - RETURN - - 999 INFORM = MODE - RETURN - -* End of NPFD . - - END
deleted file mode 100644 --- a/libcruft/npsol/npfeas.f +++ /dev/null @@ -1,113 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPFEAS( N, NCLIN, NCNLN, ISTATE, - $ BIGBND, CVNORM, ERRMAX, JMAX, NVIOL, - $ AX, BL, BU, C, FEATOL, X, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - INTEGER ISTATE(N+NCLIN+NCNLN) - DOUBLE PRECISION AX(*), BL(N+NCLIN+NCNLN), BU(N+NCLIN+NCNLN) - DOUBLE PRECISION C(*), FEATOL(N+NCLIN+NCNLN), X(N) - DOUBLE PRECISION WORK(N+NCLIN+NCNLN) -************************************************************************ -* NPFEAS computes the following... -* (1) The number of constraints that are violated by more -* than FEATOL and the 2-norm of the constraint violations. -* -* Systems Optimization Laboratory, Stanford University. -* Original version April 1984. -* This version of NPFEAS dated 16-October-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - EXTERNAL IDAMAX, DNRM2 - INTRINSIC ABS - PARAMETER ( ZERO = 0.0D+0 ) - - BIGLOW = - BIGBND - BIGUPP = BIGBND - -* ================================================================== -* Compute NVIOL, the number of constraints violated by more than -* FEATOL, and CVNORM, the 2-norm of the constraint -* violations and residuals of the constraints in the QP working set. -* ================================================================== - NVIOL = 0 - - DO 200 J = 1, N+NCLIN+NCNLN - FEASJ = FEATOL(J) - RES = ZERO - - IF (J .LE. N + NCLIN) THEN - -* Bound or general linear constraint. - - IF (J .LE. N) THEN - CON = X(J) - ELSE - CON = AX(J-N) - END IF - - TOLJ = FEASJ - ELSE - -* Nonlinear constraint. - - CON = C(J-N-NCLIN) - TOLJ = ZERO - END IF - -* Check for constraint violations. - - IF (BL(J) .GT. BIGLOW) THEN - RES = BL(J) - CON - IF (RES .GT. FEASJ ) NVIOL = NVIOL + 1 - IF (RES .GT. TOLJ ) GO TO 190 - END IF - - IF (BU(J) .LT. BIGUPP) THEN - RES = BU(J) - CON - IF (RES .LT. (-FEASJ)) NVIOL = NVIOL + 1 - IF (RES .LT. (-TOLJ)) GO TO 190 - END IF - -* This constraint is satisfied, but count the residual as a -* violation if the constraint is in the working set. - - IS = ISTATE(J) - - IF (IS .EQ. 0) THEN - RES = ZERO - ELSE IF (IS .EQ. 1 .OR. IS .LE. -2) THEN - RES = BL(J) - CON - ELSE IF (IS .GE. 2 .OR. IS .EQ. -1) THEN - RES = BU(J) - CON - END IF - - IF (ABS( RES ) .GT. FEASJ) NVIOL = NVIOL + 1 - -* Set the array of violations. - - 190 WORK(J) = RES - 200 CONTINUE - - JMAX = IDAMAX( N+NCLIN+NCNLN, WORK, 1 ) - ERRMAX = ABS ( WORK(JMAX) ) - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) ERRMAX, JMAX - - CVNORM = DNRM2 ( N+NCLIN+NCNLN, WORK, 1 ) - - RETURN - - 1000 FORMAT(/ ' //NPFEAS// The maximum violation is ', 1PE14.2, - $ ' in constraint', I5 ) - -* End of NPFEAS. - - END
deleted file mode 100644 --- a/libcruft/npsol/npfile.f +++ /dev/null @@ -1,54 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPFILE( IOPTNS, INFORM ) - INTEGER IOPTNS, INFORM - -************************************************************************ -* NPFILE reads the options file from unit IOPTNS and loads the -* options into the relevant elements of IPRMNP and RPRMNP. -* -* If IOPTNS .lt. 0 or IOPTNS .gt. 99 then no file is read, -* otherwise the file associated with unit IOPTNS is read. -* -* Output: -* -* INFORM = 0 if a complete OPTIONS file was found -* (starting with BEGIN and ending with END); -* 1 if IOPTNS .lt. 0 or IOPTNS .gt. 99; -* 2 if BEGIN was found, but end-of-file -* occurred before END was found; -* 3 if end-of-file occurred before BEGIN or -* ENDRUN were found; -* 4 if ENDRUN was found before BEGIN. -************************************************************************ - LOGICAL NEWOPT - COMMON /SOL7NP/ NEWOPT - SAVE /SOL7NP/ - - DOUBLE PRECISION WMACH(15) - COMMON /SOLMCH/ WMACH - SAVE /SOLMCH/ - - EXTERNAL MCHPAR, NPKEY - LOGICAL FIRST - SAVE FIRST , NOUT - DATA FIRST /.TRUE./ - -* If first time in, set NOUT. -* NEWOPT is true first time into NPFILE or NPOPTN -* and just after a call to NPSOL. - - IF (FIRST) THEN - FIRST = .FALSE. - NEWOPT = .TRUE. - CALL MCHPAR() - NOUT = WMACH(11) - END IF - - CALL OPFILE( IOPTNS, NOUT, INFORM, NPKEY ) - - RETURN - -* End of NPFILE. - - END
deleted file mode 100644 --- a/libcruft/npsol/npiqp.f +++ /dev/null @@ -1,579 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPIQP ( FEASQP, UNITQ, NQPERR, MINITS, - $ N, NCLIN, NCNLN, NROWA, NROWJ, NROWQP, NROWR, - $ LINACT, NLNACT, NACTIV, NFREE, NZ, NUMINF, - $ ISTATE, KACTIV, KX, - $ DXNORM, GDX, QPCURV, - $ AQP, ADX, ANORM, AX, BL, BU, - $ C, CJAC, CLAMDA, CMUL, CS, - $ DLAM, DSLK, DX, QPBL, QPBU, QPTOL, - $ R, RHO, SLK, VIOLN, X, - $ WTINF, IW, W ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL FEASQP, UNITQ - INTEGER ISTATE(*), KACTIV(N), KX(N) - INTEGER IW(*) - DOUBLE PRECISION AQP(NROWQP,*), ADX(*), ANORM(*), AX(*), - $ BL(*), BU(*), - $ C(*), CJAC(NROWJ,*), CLAMDA(*), CMUL(*), CS(*) - DOUBLE PRECISION DLAM(*), DSLK(*), DX(N) - DOUBLE PRECISION QPBL(*), QPBU(*), - $ QPTOL(*), R(NROWR,*), RHO(*), SLK(*), - $ VIOLN(*), X(N), WTINF(*) - DOUBLE PRECISION W(*) - -************************************************************************ -* NPIQP does the following: -* -* (1) Generate the upper and lower bounds for the QP subproblem. -* -* (2) Compute the TQ factors of the rows of AQP specified by -* the array ISTATE. The part of the factorization defined by -* the first contiguous group of linear constraints does not -* need to be recomputed. The remaining rows (which could be -* comprised of both linear and nonlinear constraints) are -* included as new rows of the TQ factorization stored in -* T and ZY. Note that if there are no nonlinear constraints, -* no factorization is required. -* -* (3) Solve the QP subproblem. -* minimize 1/2 (W p - d)'(Wp - d) + g'p -* -* subject to qpbl .le. ( p ) .le. qpbu, -* ( Ap ) -* -* where W is a matrix (not stored) such that W'W = H and -* WQ = R, d is the zero vector, and g is the gradient. -* If the subproblem is infeasible, compute the point which -* minimizes the sum of infeasibilities. -* -* (4) Find the value of each slack variable for which the merit -* function is minimized. -* -* (5) Compute DSLK, DLAM and DX, the search directions for -* the slack variables, the multipliers and the variables. -* -* Systems Optimization Laboratory, Stanford University. -* Fortran 66 version written 10-January-1983. -* This version of NPIQP dated 31-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT , NCOLT , NQ - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE , DTMAX , DTMIN - COMMON /SOL6CM/ RCNDBD, RFROBN, DRMAX , DRMIN - - INTEGER LOCLS - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL CMDBG, LSDBG, NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG - -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- -*----------------------------------------------------------------------- - INTEGER IPRMNP(MXPARM), IPSVNP - DOUBLE PRECISION RPRMNP(MXPARM), RPSVNP - - COMMON /NPPAR1/ IPSVNP(MXPARM), - $ IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4, - $ LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF , - $ NLNJ , NLNX , NNCNLN, IPADNP(15) - - COMMON /NPPAR2/ RPSVNP(MXPARM), - $ CDINT , CTOL , EPSRF , ETA , FDINT , FTOL , - $ RPADNP(24) - - EQUIVALENCE (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT) - - SAVE /NPPAR1/, /NPPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (IDBGNP, IDBG ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR) - EQUIVALENCE (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP ) - - CHARACTER*8 NAMES(1) - LOGICAL LINOBJ, OVERFL, QPNAMD, VERTEX - INTRINSIC ABS , MIN , MAX - EXTERNAL DDIV , DDOT , DNRM2 - PARAMETER ( QPNAMD =.FALSE.,VERTEX =.FALSE. ) - PARAMETER ( ZERO =0.0D+0, ONE =1.0D+0, TWO =2.0D+0 ) - PARAMETER ( HUNDRD =1.0D+2 ) - - IDBGSV = IDBG - IF (NPDBG) THEN - IDBG = 0 - ELSE - IDBG = NMINOR + 1 - END IF - LSDBG = NPDBG - CMDBG = NPDBG - CALL ICOPY ( LDBG, ILSDBG, 1, ICMDBG, 1 ) - - LRPQ = LOCLS( 5) - LRPQ0 = LOCLS( 6) - LHPQ = LOCLS( 8) - LGQ = LOCLS( 9) - LT = LOCLS(11) - LZY = LOCLS(12) - LWRK1 = LOCLS(14) - - NRPQ = 0 - NGQ = 1 - - FEASQP = .TRUE. - LINOBJ = .TRUE. - - BIGLOW = - BIGBND - BIGUPP = BIGBND - SSQ1 = ZERO - - NPLIN = N + NCLIN - NCTOTL = NPLIN + NCNLN - NCQP = NCLIN + NCNLN - NRANK = N - NREJTD = 0 - -* ================================================================== -* Generate the upper and lower bounds upon the search direction, the -* weights on the sum of infeasibilities and the nonlinear constraint -* violations. -* ================================================================== - WSCALE = - ONE - DO 170 J = 1, NCTOTL - - IF (J .LE. N) THEN - CON = X(J) - ELSE IF (J .LE. NPLIN) THEN - CON = AX(J-N) - ELSE - CON = C(J-NPLIN) - END IF - - BLJ = BL(J) - BUJ = BU(J) - IF (BLJ .GT. BIGLOW) BLJ = BLJ - CON - IF (BUJ .LT. BIGUPP) BUJ = BUJ - CON - - WEIGHT = ONE - IF (J .LE. NPLIN) THEN - IF (ABS(BLJ) .LE. QPTOL(J)) BLJ = ZERO - IF (ABS(BUJ) .LE. QPTOL(J)) BUJ = ZERO - ELSE - I = J - NPLIN - VIOL = ZERO - IF (BL(J) .GT. BIGLOW) THEN - IF (BLJ .GT. ZERO) THEN - VIOL = BLJ - WEIGHT = BLJ - IF (RHO(I) .GT. ZERO) WEIGHT = VIOL*RHO(I) - WSCALE = MAX( WSCALE, WEIGHT ) - GO TO 160 - END IF - END IF - - IF (BU(J) .LT. BIGUPP) THEN - IF (BUJ .LT. ZERO) THEN - VIOL = BUJ - WEIGHT = - BUJ - IF (RHO(I) .GT. ZERO) WEIGHT = - VIOL*RHO(I) - WSCALE = MAX( WSCALE, - WEIGHT ) - END IF - END IF - -* Set the vector of nonlinear constraint violations. - - 160 VIOLN(I) = VIOL - END IF - - WTINF(J) = WEIGHT - QPBL(J) = BLJ - QPBU(J) = BUJ - - 170 CONTINUE - - IF (WSCALE .GT. ZERO) THEN - WSCALE = ONE/WSCALE - CALL DSCAL ( NCTOTL, (WSCALE), WTINF, 1 ) - END IF - -* Set the maximum allowable condition estimator of the constraints -* in the working set. Note that a relatively well-conditioned -* working set is used to start the QP iterations. - - CONDMX = MAX( ONE/EPSPT3, HUNDRD ) - - IF (NCNLN .GT. 0) THEN -* =============================================================== -* Refactorize part of the QP constraint matrix. -* =============================================================== -* Load the new Jacobian into the QP matrix A. Compute the -* 2-norms of the rows of the Jacobian. - - DO 180 J = 1, N - CALL DCOPY ( NCNLN, CJAC(1,J), 1, AQP(NCLIN+1,J), 1 ) - 180 CONTINUE - - DO 190 J = NCLIN+1, NCQP - ANORM(J) = DNRM2 ( N, AQP(J,1), NROWQP ) - 190 CONTINUE - -* Count the number of linear constraints in the working set and -* move them to the front of KACTIV. Compute the norm of the -* matrix of constraints in the working set. -* Let K1 point to the first nonlinear constraint. Constraints -* with indices KACTIV(K1),..., KACTIV(NACTIV) must be -* refactorized. - - ASIZE = ZERO - LINACT = 0 - K1 = NACTIV + 1 - DO 200 K = 1, NACTIV - I = KACTIV(K) - ASIZE = MAX( ASIZE, ANORM(I) ) - - IF (I .LE. NCLIN) THEN - LINACT = LINACT + 1 - IF (LINACT .NE. K) THEN - ISWAP = KACTIV(LINACT) - KACTIV(LINACT) = I - KACTIV(K) = ISWAP - END IF - ELSE - -* Record the old position of the 1st. nonlinear constraint. - - IF (K1 .GT. NACTIV) K1 = K - END IF - 200 CONTINUE - - IF (NACTIV .LE. 1 ) - $ CALL DCOND ( NCQP, ANORM, 1, ASIZE, AMIN ) - -* Compute the absolute values of the nonlinear constraints in -* the working set. Use DX as workspace. - - DO 210 K = LINACT+1, NACTIV - J = N + KACTIV(K) - IF (ISTATE(J) .EQ. 1) DX(K) = ABS( QPBL(J) ) - IF (ISTATE(J) .GE. 2) DX(K) = ABS( QPBU(J) ) - 210 CONTINUE - -* Sort the elements of KACTIV corresponding to nonlinear -* constraints in descending order of violation (i.e., -* the first element of KACTIV for a nonlinear constraint -* is associated with the most violated constraint.) -* In this way, the rows of the Jacobian corresponding -* to the more violated constraints tend to be included -* in the TQ factorization. - -* The sorting procedure is taken from the simple insertion -* sort in D. Knuth, ACP Volume 3, Sorting and Searching, -* Page 81. It should be replaced by a faster sort if the -* number of active nonlinear constraints becomes large. - - DO 230 K = LINACT+2, NACTIV - L = K - VIOL = DX(L) - KVIOL = KACTIV(L) -* WHILE (L .GT. LINACT+1 .AND. DX(L-1) .LT. VIOL) DO - 220 IF (L .GT. LINACT+1 ) THEN - IF ( DX(L-1) .LT. VIOL) THEN - DX(L) = DX(L-1) - KACTIV(L) = KACTIV(L-1) - L = L - 1 - GO TO 220 - END IF -* END WHILE - END IF - DX(L) = VIOL - KACTIV(L) = KVIOL - 230 CONTINUE - - K2 = NACTIV - NACTIV = K1 - 1 - NZ = NFREE - NACTIV - -* Update the factors R, T and Q to include constraints -* K1 through K2. - - IF (K1 .LE. K2) - $ CALL LSADDS( UNITQ, VERTEX, - $ INFORM, K1, K2, NACTIV, NARTIF, NZ, NFREE, - $ NRANK, NREJTD, NRPQ, NGQ, - $ N, NQ, NROWQP, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ CONDMX, - $ AQP, R, W(LT), W(LRPQ), W(LGQ), - $ W(LZY), W(LWRK1), DX ) - END IF - -* ================================================================== -* Solve for DX, the vector of minimum two-norm that satisfies the -* constraints in the working set. -* ================================================================== - CALL NPSETX( UNITQ, - $ NCQP, NACTIV, NFREE, NZ, - $ N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ DXNORM, GDX, - $ AQP, ADX, QPBL, QPBU, W(LRPQ), W(LRPQ0), DX, W(LGQ), - $ R, W(LT), W(LZY), W(LWRK1) ) - -* ================================================================== -* Solve a quadratic program for the search direction DX and -* multiplier estimates CLAMDA. -* ================================================================== -* If there is no feasible point for the subproblem, the sum of -* infeasibilities is minimized subject to the linear constraints -* (1 thru JINF) being satisfied. - - JINF = N + NCLIN - - NTRY = 1 -*+ REPEAT - 450 CALL LSCORE( 'QP subproblem', QPNAMD, NAMES, LINOBJ, UNITQ, - $ NQPERR, MINITS, JINF, NCQP, NCTOTL, - $ NACTIV, NFREE, NRANK, NZ, NZ1, - $ N, NROWQP, NROWR, - $ ISTATE, KACTIV, KX, - $ GDX, SSQ, SSQ1, SUMINF, NUMINF, DXNORM, - $ QPBL, QPBU, AQP, CLAMDA, ADX, - $ QPTOL, R, DX, IW, W ) - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 8000) NQPERR - - NVIOL = 0 - IF (NUMINF .GT. 0) THEN - -* Count the violated linear constraints. - - DO 460 J = 1, NPLIN - IF (ISTATE(J) .LT. 0) NVIOL = NVIOL + 1 - 460 CONTINUE - - IF (NVIOL .GT. 0) THEN - NTRY = NTRY + 1 - UNITQ = .TRUE. - NACTIV = 0 - NFREE = N - NZ = N - CALL ILOAD ( NCTOTL, (0), ISTATE, 1 ) - - CALL NPSETX( UNITQ, - $ NCQP, NACTIV, NFREE, NZ, - $ N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ DXNORM, GDX, - $ AQP, ADX, QPBL, QPBU, W(LRPQ), W(LRPQ0), - $ DX, W(LGQ), R, W(LT), W(LZY), W(LWRK1) ) - END IF - END IF - IF (.NOT. (NVIOL .EQ. 0 .OR. NTRY .GT. 2)) GO TO 450 -*+ UNTIL ( NVIOL .EQ. 0 .OR. NTRY .GT. 2) - -* ================================================================== -* Count the number of nonlinear constraint gradients in the QP -* working set. Make sure that all small QP multipliers associated -* with nonlinear inequality constraints have the correct sign. -* ================================================================== - NLNACT = 0 - IF (NACTIV .GT. 0 .AND. NCNLN .GT. 0) THEN - DO 500 K = 1, NACTIV - L = KACTIV(K) - IF (L .GT. NCLIN) THEN - NLNACT = NLNACT + 1 - J = N + L - IF (ISTATE(J) .EQ. 1) CLAMDA(J) = MAX( ZERO, CLAMDA(J) ) - IF (ISTATE(J) .EQ. 2) CLAMDA(J) = MIN( ZERO, CLAMDA(J) ) - END IF - 500 CONTINUE - END IF - - LINACT = NACTIV - NLNACT - -* ------------------------------------------------------------------ -* Extract various useful quantities from the QP solution. -* ------------------------------------------------------------------ -* Compute HPQ = R'R(pq) from the transformed gradient of the QP -* objective function and R(pq) from the transformed residual. - - CALL DSCAL ( N, (-ONE), W(LRPQ), 1 ) - CALL DAXPY ( N, (-ONE), W(LGQ) , 1, W(LHPQ), 1 ) - QPCURV = TWO*SSQ - - IF (NCNLN .GT. 0) THEN - IF (NUMINF .GT. 0) THEN - FEASQP = .FALSE. - CALL DLOAD ( NCTOTL, (ZERO), CLAMDA, 1 ) - - IF (NZ .GT. 0) THEN -* --------------------------------------------------------- -* Compute a null space component for the search direction -* as the solution of Z'HZ(pz) = -Z'g - Z'HY(py). -* --------------------------------------------------------- -* Overwrite DX with the transformed search direction -* Q'(dx). The first NZ components of DX are zero. - - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, - $ KX, DX, W(LZY), W(LWRK1) ) - -* Overwrite the first NZ components of DX with the solution -* of (Rz)u = -(v + w), where (Rz)'w = Z'g and v is -* vector of first NZ components of R(pq). - - CALL DCOPY ( NZ, W(LGQ), 1, DX, 1 ) - CALL DTRSV ( 'U', 'T', 'N', NZ, R, NROWR, DX, 1 ) - - CALL DAXPY ( NZ, (ONE), W(LRPQ), 1, DX, 1 ) - - CALL DTRSV ( 'U', 'N', 'N', NZ, R, NROWR, DX, 1 ) - CALL DSCAL ( NZ, (-ONE), DX, 1 ) - -* Recompute RPQ, HPQ, GDX and QPCURV. - - CALL DCOPY ( NLNX, DX, 1, W(LRPQ), 1 ) - CALL DTRMV ( 'U', 'N', 'N', NLNX, R, NROWR, W(LRPQ), 1 ) - IF (NLNX .LT. N) - $ CALL DGEMV( 'N', NLNX, N-NLNX, ONE, R(1,NLNX+1),NROWR, - $ DX(NLNX+1), 1, ONE, W(LRPQ), 1 ) - - GDX = DDOT ( N, W(LGQ) , 1, DX , 1 ) - QPCURV = DDOT ( N, W(LRPQ), 1, W(LRPQ), 1 ) - - CALL CMQMUL( 3, N, NZ, NFREE, NQ, UNITQ, - $ KX, DX, W(LZY), W(LWRK1) ) - -* --------------------------------------------------------- -* Recompute ADX and the 2-norm of DX. -* --------------------------------------------------------- - DXNORM = DNRM2 ( N, DX, 1 ) - IF (NCQP .GT. 0) - $ CALL DGEMV ( 'N', NCQP, N, ONE, AQP, NROWQP, - $ DX, 1, ZERO, ADX, 1 ) - - IF (NPDBG .AND. INPDBG(2) .GT. 0) - $ WRITE (NOUT, 8100) (DX(J), J = 1, N) - END IF - - CALL DCOPY ( NLNX, W(LRPQ), 1, W(LHPQ), 1 ) - CALL DTRMV ( 'U', 'T', 'N', NLNX, R, NROWR, W(LHPQ), 1 ) - IF (NLNX .LT. N) - $ CALL DGEMV ( 'T', NLNX, N-NLNX, ONE, R(1,NLNX+1), NROWR, - $ W(LRPQ), 1, ZERO, W(LHPQ+NLNX), 1 ) - END IF - -* =============================================================== -* For given values of the objective function and constraints, -* attempt to minimize the merit function with respect to each -* slack variable. -* =============================================================== - DO 600 I = 1, NCNLN - J = NPLIN + I - CON = C(I) - - IF ( .NOT. FEASQP .AND. - $ VIOLN(I) .NE. ZERO .AND. RHO(I) .LE. ZERO ) - $ RHO(I) = ONE - - QUOTNT = DDIV ( CMUL(I), SCALE*RHO(I), OVERFL ) - -* Define the slack variable to be CON - MULT / RHO. -* Force each slack to lie within its upper and lower bounds. - - IF (BL(J) .GT. BIGLOW) THEN - IF (QPBL(J) .GE. - QUOTNT) THEN - SLK(I) = BL(J) - GO TO 550 - END IF - END IF - - IF (BU(J) .LT. BIGUPP) THEN - IF (QPBU(J) .LE. - QUOTNT) THEN - SLK(I) = BU(J) - GO TO 550 - END IF - END IF - - SLK(I) = CON - QUOTNT - -* The slack has been set within its bounds. - - 550 CS(I) = CON - SLK(I) - -* ------------------------------------------------------------ -* Compute the search direction for the slacks and multipliers. -* ------------------------------------------------------------ - DSLK(I) = ADX(NCLIN+I) + CS(I) - - IF (FEASQP) THEN -* -* If any constraint is such that (DLAM)*(C - S) is -* positive, the merit function may be reduced immediately -* by substituting the QP multiplier. -* - DLAM(I) = CLAMDA(J) - CMUL(I) - IF (DLAM(I) * CS(I) .GE. ZERO) THEN - CMUL(I) = CLAMDA(J) - DLAM(I) = ZERO - END IF - ELSE - -* The QP subproblem was infeasible. - - DLAM(I) = ZERO - - IF (ISTATE(J) .LT. 0 .OR. VIOLN(I) .NE. ZERO) - $ DSLK(I) = ZERO - - END IF - 600 CONTINUE - - IF (.NOT. FEASQP) - $ RHONRM = DNRM2 ( NCNLN, RHO, 1 ) - - IF (NPDBG .AND. INPDBG(2) .GT. 0) THEN - WRITE (NOUT, 8200) (VIOLN(I), I=1,NCNLN) - WRITE (NOUT, 8300) (SLK(I) , I=1,NCNLN) - END IF - END IF - - CALL ICOPY ( LDBG, INPDBG, 1, ICMDBG, 1 ) - IDBG = IDBGSV - - RETURN - - 8000 FORMAT(/ ' //NPIQP // NQPERR' - $ / ' //NPIQP // ', I6 ) - 8100 FORMAT(/ ' //NPIQP // DX recomputed with null space portion...' - $ / (5G12.3)) - 8200 FORMAT(/ ' //NPIQP // Violations = '/ (1P5E15.6)) - 8300 FORMAT(/ ' //NPIQP // Slacks = '/ (1P5E15.6)) - -* End of NPIQP . - - END
deleted file mode 100644 --- a/libcruft/npsol/npkey.f +++ /dev/null @@ -1,332 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPKEY ( NOUT, BUFFER, KEY ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*(*) BUFFER - -************************************************************************ -* NPKEY decodes the option contained in BUFFER in order to set -* a parameter value in the relevant element of the parameter arrays. -* -* -* Input: -* -* NOUT A unit number for printing error messages. -* NOUT must be a valid unit. -* -* Output: -* -* KEY The first keyword contained in BUFFER. -* -* -* NPKEY calls OPNUMB and the subprograms -* LOOKUP, SCANNR, TOKENS, UPCASE -* (now called OPLOOK, OPSCAN, OPTOKN, OPUPPR) -* supplied by Informatics General, Inc., Palo Alto, California. -* -* Systems Optimization Laboratory, Stanford University. -* This version of NPKEY dated 12-July-1986. -************************************************************************ -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- -*----------------------------------------------------------------------- - INTEGER IPRMNP(MXPARM), IPSVNP - DOUBLE PRECISION RPRMNP(MXPARM), RPSVNP - - COMMON /NPPAR1/ IPSVNP(MXPARM), - $ IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4, - $ LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF , - $ NLNJ , NLNX , NNCNLN, IPADNP(15) - - COMMON /NPPAR2/ RPSVNP(MXPARM), - $ CDINT , CTOL , EPSRF , ETA , FDINT , FTOL , - $ RPADNP(24) - - EQUIVALENCE (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT) - - SAVE /NPPAR1/, /NPPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (IDBGNP, IDBG ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR) - EQUIVALENCE (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP ) - - EXTERNAL OPNUMB - LOGICAL FIRST , MORE , NUMBER, OPNUMB, SORTED - SAVE FIRST - - PARAMETER ( MAXKEY = 38, MAXTIE = 19, MAXTOK = 10) - CHARACTER*16 KEYS(MAXKEY), TIES(MAXTIE), TOKEN(MAXTOK) - CHARACTER*16 KEY, KEY2, KEY3, VALUE - - PARAMETER (IDUMMY = -11111, RDUMMY = -11111.0, - $ SORTED = .TRUE., ZERO = 0.0 ) - - DATA FIRST - $ /.TRUE./ - DATA KEYS - $ / 'BEGIN ', - $ 'CENTRAL ', 'COLD ', 'CONSTRAINTS ', - $ 'CRASH ', 'DEBUG ', 'DEFAULTS ', - $ 'DERIVATIVE ', 'DIFFERENCE ', - $ 'END ', 'FEASIBILITY ', 'FUNCTION ', - $ 'HESSIAN ', 'HOT ', 'INFINITE ', - $ 'IPRMLS ', 'ITERATIONS ', 'ITERS:ITERATIONS', - $ 'ITNS :ITERATIONS', 'LINEAR ', 'LINESEARCH ', - $ 'LIST ', 'LOWER ', - $ 'MAJOR ', 'MINOR ', - $ 'NOLIST ', - $ 'NONLINEAR ', 'OPTIMALITY ', 'PRINT ', - $ 'PROBLEM ', 'ROW ', 'RPRMLS ', - $ 'START ', 'STOP ', 'UPPER ', - $ 'VARIABLES ', 'VERIFY ', 'WARM '/ - - DATA TIES - $ / 'BOUND ', 'CONSTRAINTS ', 'DEBUG ', - $ 'FEASIBILITY ', 'GRADIENTS ', - $ 'ITERATIONS ', 'ITERS:ITERATIONS', - $ 'ITNS :ITERATIONS', 'JACOBIAN ', 'LEVEL ', - $ 'NO ', - $ 'NO. :NUMBER', - $ 'NUMBER ', 'OBJECTIVE ', 'PRINT ', - $ 'STEP ', 'TOLERANCE ', - $ 'VARIABLES ', 'YES '/ -*----------------------------------------------------------------------- - - IF (FIRST) THEN - FIRST = .FALSE. - DO 10 I = 1, MXPARM - RPRMLS(I) = RDUMMY - IPRMLS(I) = IDUMMY - RPRMNP(I) = RDUMMY - IPRMNP(I) = IDUMMY - 10 CONTINUE - END IF - -* Eliminate comments and empty lines. -* A '*' appearing anywhere in BUFFER terminates the string. - - I = INDEX( BUFFER, '*' ) - IF (I .EQ. 0) THEN - LENBUF = LEN( BUFFER ) - ELSE - LENBUF = I - 1 - END IF - IF (LENBUF .LE. 0) THEN - KEY = '*' - GO TO 900 - END IF - -* ------------------------------------------------------------------ -* Extract up to MAXTOK tokens from the record. -* NTOKEN returns how many were actually found. -* KEY, KEY2, KEY3 are the first tokens if any, otherwise blank. -* ------------------------------------------------------------------ - NTOKEN = MAXTOK - CALL OPTOKN( BUFFER(1:LENBUF), NTOKEN, TOKEN ) - KEY = TOKEN(1) - KEY2 = TOKEN(2) - KEY3 = TOKEN(3) - -* Certain keywords require no action. - - IF (KEY .EQ. ' ' .OR. KEY .EQ. 'BEGIN' ) GO TO 900 - IF (KEY .EQ. 'LIST' .OR. KEY .EQ. 'NOLIST') GO TO 900 - IF (KEY .EQ. 'END' ) GO TO 900 - -* Most keywords will have an associated integer or real value, -* so look for it no matter what the keyword. - - I = 1 - NUMBER = .FALSE. - - 50 IF (I .LT. NTOKEN .AND. .NOT. NUMBER) THEN - I = I + 1 - VALUE = TOKEN(I) - NUMBER = OPNUMB( VALUE ) - GO TO 50 - END IF - - IF (NUMBER) THEN - READ (VALUE, '(BN, E16.0)') RVALUE - ELSE - RVALUE = ZERO - END IF - -* Convert the keywords to their most fundamental form -* (upper case, no abbreviations). -* SORTED says whether the dictionaries are in alphabetic order. -* LOCi says where the keywords are in the dictionaries. -* LOCi = 0 signals that the keyword wasn't there. - - CALL OPLOOK( MAXKEY, KEYS, SORTED, KEY , LOC1 ) - CALL OPLOOK( MAXTIE, TIES, SORTED, KEY2, LOC2 ) - -* ------------------------------------------------------------------ -* Decide what to do about each keyword. -* The second keyword (if any) might be needed to break ties. -* Some seemingly redundant testing of MORE is used -* to avoid compiler limits on the number of consecutive ELSE IFs. -* ------------------------------------------------------------------ - MORE = .TRUE. - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'CENTRAL ') THEN - CDINT = RVALUE - ELSE IF (KEY .EQ. 'COLD ') THEN - LCRASH = 0 - ELSE IF (KEY .EQ. 'CONSTRAINTS ') THEN - NNCLIN = RVALUE - ELSE IF (KEY .EQ. 'CRASH ') THEN - TOLACT = RVALUE - ELSE IF (KEY .EQ. 'DEBUG ') THEN - IDBG = RVALUE - ELSE IF (KEY .EQ. 'DEFAULTS ') THEN - DO 20 I = 1, MXPARM - IPRMLS(I) = IDUMMY - RPRMLS(I) = RDUMMY - IPRMNP(I) = IDUMMY - RPRMNP(I) = RDUMMY - 20 CONTINUE - ELSE IF (KEY .EQ. 'DERIVATIVE ') THEN - LVLDER = RVALUE - ELSE IF (KEY .EQ. 'DIFFERENCE ') THEN - FDINT = RVALUE - ELSE IF (KEY .EQ. 'FEASIBILITY ') THEN - TOLFEA = RVALUE - CTOL = RVALUE - ELSE IF (KEY .EQ. 'FUNCTION ') THEN - EPSRF = RVALUE - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'HESSIAN ') THEN - LFORMH = 1 - IF (KEY2.EQ. 'NO ') LFORMH = 0 - ELSE IF (KEY .EQ. 'HOT ') THEN - LCRASH = 2 - ELSE IF (KEY .EQ. 'INFINITE ') THEN - IF (KEY2.EQ. 'BOUND ') BIGBND = RVALUE * 0.99999 - IF (KEY2.EQ. 'STEP ') BIGDX = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'IPRMLS ') THEN -* Allow things like IPRMLS 21 = 100 to set IPRMLS(21) = 100 - IVALUE = RVALUE - IF (IVALUE .GE. 1 .AND. IVALUE .LE. MXPARM) THEN - READ (KEY3, '(BN, I16)') IPRMLS(IVALUE) - ELSE - WRITE(NOUT, 2400) IVALUE - END IF - ELSE IF (KEY .EQ. 'ITERATIONS ') THEN - NMAJOR = RVALUE - ELSE IF (KEY .EQ. 'LINEAR ') THEN - IF (KEY2 .EQ. 'CONSTRAINTS ') NNCLIN = RVALUE - IF (KEY2 .EQ. 'FEASIBILITY ') TOLFEA = RVALUE - IF (LOC2 .EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'LINESEARCH ') THEN - ETA = RVALUE - ELSE IF (KEY .EQ. 'LOWER ') THEN - BNDLOW = RVALUE - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'MAJOR ') THEN - IF (KEY2.EQ. 'DEBUG ') MJRDBG = RVALUE - IF (KEY2.EQ. 'ITERATIONS ') NMAJOR = RVALUE - IF (KEY2.EQ. 'PRINT ') MSGNP = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'MINOR ') THEN - IF (KEY2.EQ. 'DEBUG ') MNRDBG = RVALUE - IF (KEY2.EQ. 'ITERATIONS ') NMINOR = RVALUE - IF (KEY2.EQ. 'PRINT ') MSGQP = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'NONLINEAR ') THEN - IF (KEY2.EQ. 'CONSTRAINTS ') NNCNLN = RVALUE - IF (KEY2.EQ. 'FEASIBILITY ') CTOL = RVALUE - IF (KEY2.EQ. 'JACOBIAN ') NLNJ = RVALUE - IF (KEY2.EQ. 'OBJECTIVE ') NLNF = RVALUE - IF (KEY2.EQ. 'VARIABLES ') NLNX = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'OPTIMALITY ') THEN - FTOL = RVALUE - ELSE - MORE = .TRUE. - END IF - END IF - - IF (MORE) THEN - MORE = .FALSE. - IF (KEY .EQ. 'PRINT ') THEN - MSGNP = RVALUE - ELSE IF (KEY .EQ. 'PROBLEM ') THEN - IF (KEY2.EQ. 'NUMBER ') NPROB = RVALUE - ELSE IF (KEY .EQ. 'ROW ') THEN - IF (KEY2.EQ. 'TOLERANCE ') CTOL = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'RPRMLS ') THEN -* Allow things like RPRMLS 21 = 2 to set RPRMLS(21) = 2.0 - IVALUE = RVALUE - IF (IVALUE .GE. 1 .AND. IVALUE .LE. MXPARM) THEN - READ (KEY3, '(BN, E16.0)') RPRMLS(IVALUE) - ELSE - WRITE(NOUT, 2400) IVALUE - END IF - ELSE IF (KEY .EQ. 'START ') THEN - IF (KEY2.EQ. 'CONSTRAINTS ') JVRFY3 = RVALUE - IF (KEY2.EQ. 'OBJECTIVE ') JVRFY1 = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'STOP ') THEN - IF (KEY2.EQ. 'CONSTRAINTS ') JVRFY4 = RVALUE - IF (KEY2.EQ. 'OBJECTIVE ') JVRFY2 = RVALUE - IF (LOC2.EQ. 0 ) WRITE(NOUT, 2320) KEY2 - ELSE IF (KEY .EQ. 'UPPER ') THEN - BNDUPP = RVALUE - ELSE IF (KEY .EQ. 'VARIABLES ') THEN - NN = RVALUE - ELSE IF (KEY .EQ. 'VERIFY ') THEN - IF (KEY2.EQ. 'OBJECTIVE ') LVERFY = 1 - IF (KEY2.EQ. 'CONSTRAINTS ') LVERFY = 2 - IF (KEY2.EQ. 'NO ') LVERFY = -1 - IF (KEY2.EQ. 'YES ') LVERFY = 3 - IF (KEY2.EQ. 'GRADIENTS ') LVERFY = 3 - IF (KEY2.EQ. 'LEVEL ') LVERFY = RVALUE - IF (LOC2.EQ. 0 ) LVERFY = 3 - ELSE IF (KEY .EQ. 'WARM ') THEN - LCRASH = 1 - ELSE - WRITE(NOUT, 2300) KEY - END IF - END IF - - 900 RETURN - - 2300 FORMAT(' XXX Keyword not recognized: ', A) - 2320 FORMAT(' XXX Second keyword not recognized: ', A) - 2330 FORMAT(' XXX Third keyword not recognized: ', A) - 2400 FORMAT(' XXX The PARM subscript is out of range:', I10) - -* End of NPKEY - - END
deleted file mode 100644 --- a/libcruft/npsol/nploc.f +++ /dev/null @@ -1,159 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPLOC ( N, NCLIN, NCNLN, NCTOTL, LITOTL, LWTOTL) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - -************************************************************************ -* NPLOC allocates the addresses of the work arrays for NPCORE and -* LSCORE. -* -* Systems Optimization Laboratory, Stanford University. -* Original version 14-February-1985. -* This version of NPLOC dated 12-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT, NCOLT, NQ - - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - PARAMETER (LENNP = 35) - COMMON /SOL1NP/ LOCNP(LENNP) - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - MINIW = LITOTL + 1 - MINW = LWTOTL + 1 - -* Assign array lengths that depend upon the problem dimensions. - - IF (NCLIN + NCNLN .EQ. 0) THEN - LENT = 0 - LENZY = 0 - ELSE - LENT = NROWT*NCOLT - LENZY = NQ *NQ - END IF - - IF (NCNLN .EQ. 0) THEN - LENAQP = 0 - ELSE - LENAQP = (NCLIN + NCNLN)*N - END IF - - LKACTV = MINIW - LKX = LKACTV + N - LNEEDC = LKX + N - LIPERM = LNEEDC + NCNLN - MINIW = LIPERM + NCTOTL - - LHFRWD = MINW - LHCTRL = LHFRWD + N - LANORM = LHCTRL + N - LQPGQ = LANORM + NCLIN + NCNLN - LGQ = LQPGQ + N - LRLAM = LGQ + N - LT = LRLAM + N - LZY = LT + LENT - MINW = LZY + LENZY - - LOCLS( 1) = LKACTV - LOCLS( 2) = LANORM - LOCLS( 8) = LQPGQ - LOCLS( 9) = LGQ - LOCLS(10) = LRLAM - LOCLS(11) = LT - LOCLS(12) = LZY - -* Assign the addresses for the workspace arrays used by NPIQP. - - LQPADX = MINW - LQPDX = LQPADX + NCLIN + NCNLN - LRPQ = LQPDX + N - LRPQ0 = LRPQ + N - LQPHZ = LRPQ0 + N - LWTINF = LQPHZ + N - LWRK1 = LWTINF + NCTOTL - LQPTOL = LWRK1 + NCTOTL - MINW = LQPTOL + NCTOTL - - LOCLS( 3) = LQPADX - LOCLS( 4) = LQPDX - LOCLS( 5) = LRPQ - LOCLS( 6) = LRPQ0 - LOCLS( 7) = LQPHZ - LOCLS(13) = LWTINF - LOCLS(14) = LWRK1 - LOCLS(15) = LQPTOL - -* Assign the addresses for arrays used in NPCORE. - - LAQP = MINW - LADX = LAQP + LENAQP - LBL = LADX + NCLIN + NCNLN - LBU = LBL + NCTOTL - LDX = LBU + NCTOTL - LGQ1 = LDX + N - LFEATL = LGQ1 + N - LX1 = LFEATL + NCTOTL - LWRK2 = LX1 + N - MINW = LWRK2 + NCTOTL - - LOCNP( 1) = LKX - LOCNP( 2) = LIPERM - LOCNP( 3) = LAQP - LOCNP( 4) = LADX - LOCNP( 5) = LBL - LOCNP( 6) = LBU - LOCNP( 7) = LDX - LOCNP( 8) = LGQ1 - LOCNP(10) = LFEATL - LOCNP(11) = LX1 - LOCNP(12) = LWRK2 - - LCS1 = MINW - LCS2 = LCS1 + NCNLN - LC1MUL = LCS2 + NCNLN - LCMUL = LC1MUL + NCNLN - LCJDX = LCMUL + NCNLN - LDLAM = LCJDX + NCNLN - LDSLK = LDLAM + NCNLN - LRHO = LDSLK + NCNLN - LWRK3 = LRHO + NCNLN - LSLK1 = LWRK3 + NCNLN - LSLK = LSLK1 + NCNLN - MINW = LSLK + NCNLN - - LOCNP(13) = LCS1 - LOCNP(14) = LCS2 - LOCNP(15) = LC1MUL - LOCNP(16) = LCMUL - LOCNP(17) = LCJDX - LOCNP(18) = LDLAM - LOCNP(19) = LDSLK - LOCNP(20) = LRHO - LOCNP(21) = LWRK3 - LOCNP(22) = LSLK1 - LOCNP(23) = LSLK - LOCNP(24) = LNEEDC - - LCJAC = MINW - LGRAD = LCJAC + NCNLN*N - MINW = LGRAD + N - - LOCNP(25) = LHFRWD - LOCNP(26) = LHCTRL - LOCNP(27) = LCJAC - LOCNP(28) = LGRAD - - LITOTL = MINIW - 1 - LWTOTL = MINW - 1 - - RETURN - -* End of NPLOC . - - END
deleted file mode 100644 --- a/libcruft/npsol/npmrt.f +++ /dev/null @@ -1,179 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPMRT ( FEASQP, N, NCLIN, NCNLN, - $ OBJALF, GRDALF, QPCURV, - $ ISTATE, - $ CJDX, CMUL, CS, - $ DLAM, RHO, VIOLN, - $ WORK1, WORK2 ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - - LOGICAL FEASQP - - INTEGER ISTATE(*) - - DOUBLE PRECISION CJDX(*), CMUL(*), CS(*), - $ DLAM(*), RHO(*), VIOLN(*) - DOUBLE PRECISION WORK1(*), WORK2(*) - -************************************************************************ -* NPMRT computes the value and directional derivative of the -* augmented Lagrangian merit function. The penalty parameters RHO(j) -* are boosted if the directional derivative of the resulting augmented -* Lagrangian function is not sufficiently negative. If RHO needs to -* be increased, the perturbation with minimum two-norm is found that -* gives a directional derivative equal to - p'Hp. -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version written 27-May-1985. -* This version of NPMRT dated 14-November-1985. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL BOOST , OVERFL - EXTERNAL DDIV , DDOT , DNRM2 - INTRINSIC ABS , MAX , MIN , SQRT - PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 ) - PARAMETER ( TWO = 2.0D+0 ) - - IF (NCNLN .EQ. 0) RETURN - - RTMIN = WMACH(6) - - OBJALF = OBJALF - DDOT ( NCNLN, CMUL, 1, CS, 1 ) - GRDALF = GRDALF - DDOT ( NCNLN, DLAM, 1, CS, 1 ) - - CALL DCOPY ( NCNLN, CS, 1, WORK1, 1 ) - - IF (.NOT. FEASQP) THEN - NPLIN = N + NCLIN - - DO 100 I = 1, NCNLN - IF (ISTATE(NPLIN+I) .LT. 0 .OR. VIOLN(I) .NE. ZERO) - $ WORK1(I) = - CJDX(I) - 100 CONTINUE - END IF - - GRDALF = GRDALF + DDOT ( NCNLN, WORK1, 1, CMUL, 1 ) - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) QPCURV, GRDALF - - IF (FEASQP) THEN - -* Find the quantities that define rhomin, the vector of minimum -* two-norm such that the directional derivative is one half of -* approximate curvature - (dx)'H(dx). - - DO 350 I = 1, NCNLN - IF (ABS( CS(I) ) .LE. RTMIN) THEN - WORK2(I) = ZERO - ELSE - WORK2(I) = CS(I)**2 - END IF - 350 CONTINUE - - QNORM = DNRM2 ( NCNLN, WORK2, 1 ) - TSCL = DDIV ( GRDALF + HALF*QPCURV, QNORM, OVERFL ) - IF (ABS( TSCL ) .LE. RHOMAX .AND. .NOT. OVERFL) THEN -* ------------------------------------------------------------ -* Bounded RHOMIN found. The final value of RHO(J) will -* never be less than RHOMIN(j). If the QP was feasible, a -* trial value RHONEW is computed that is equal to the -* geometric mean of the previous RHO and a damped value of -* RHOMIN. The new RHO is defined as RHONEW if it is less -* than half the previous RHO and greater than RHOMIN. -* ------------------------------------------------------------ - SCALE = ONE - DO 400 I = 1, NCNLN - RHOMIN = MAX( (WORK2(I)/QNORM)*TSCL, ZERO ) - RHOI = RHO(I) - - RHONEW = SQRT( RHOI*(RHODMP + RHOMIN) ) - IF (RHONEW .LT. HALF*RHOI ) RHOI = RHONEW - IF (RHOI .LT. RHOMIN) RHOI = RHOMIN - RHO(I) = RHOI - 400 CONTINUE - - RHO1 = RHONRM - RHONRM = DNRM2 ( NCNLN, RHO, 1 ) - -* ------------------------------------------------------------ -* If INCRUN = true, there has been a run of iterations in -* which the norm of RHO has not decreased. Conversely, -* INCRUN = false implies that there has been a run of -* iterations in which the norm of RHO has not increased. If -* INCRUN changes during this iteration the damping parameter -* RHODMP is increased by a factor of two. This ensures that -* RHO(j) will oscillate only a finite number of times. -* ------------------------------------------------------------ - BOOST = .FALSE. - IF ( INCRUN .AND. RHONRM .LT. RHO1) BOOST = .TRUE. - IF (.NOT. INCRUN .AND. RHONRM .GT. RHO1) BOOST = .TRUE. - IF (BOOST) THEN - RHODMP = TWO*RHODMP - INCRUN = .NOT. INCRUN - END IF - END IF - - IF (NPDBG .AND. INPDBG(2) .GT. 0) - $ WRITE (NOUT, 1200) (RHO(L), L=1,NCNLN) - - ELSE - -* The QP was infeasible. Do not alter the penalty parameters, -* but compute the scale factor so that the constraint violations -* are reduced. - - CALL DDSCL ( NCNLN, RHO, 1, WORK1, 1 ) - PTERM2 = DDOT ( NCNLN, WORK1, 1, CS, 1 ) - - SCALE = RHOMAX - TSCL = DDIV ( GRDALF, PTERM2, OVERFL ) - IF (TSCL .GT. SCALE .AND. TSCL .LE. RHOMAX/(ONE+RHONRM) - $ .AND. .NOT. OVERFL) - $ SCALE = TSCL - - CALL DCOPY ( NCNLN, CS, 1, WORK1, 1 ) - END IF - -* ------------------------------------------------------------------ -* Compute the new value and directional derivative of the -* merit function. -* ------------------------------------------------------------------ - CALL DDSCL ( NCNLN, RHO, 1, WORK1, 1 ) - - PTERM = DDOT ( NCNLN, WORK1, 1, CS, 1 ) - OBJALF = OBJALF + HALF*SCALE*PTERM - - IF (FEASQP) - $ PTERM2 = PTERM - - GRDALF = GRDALF - SCALE*PTERM2 - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1100) SCALE, RHONRM, GRDALF - - RETURN - - 1000 FORMAT(/ ' //NPMRT // QPCURV GRDALF ' - $ / ' //NPMRT //', 1P2E14.2 ) - 1100 FORMAT(/ ' //NPMRT // SCALE RHONRM GRDALF ' - $ / ' //NPMRT //', 1P3E14.2 ) - 1200 FORMAT(/ ' //NPMRT // Penalty parameters = '/ (1P5E15.6)) - -* End of NPMRT . - - END
deleted file mode 100644 --- a/libcruft/npsol/npoptn.f +++ /dev/null @@ -1,68 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPOPTN( STRING ) - CHARACTER*(*) STRING - -************************************************************************ -* NPOPTN loads the option supplied in STRING into the relevant -* element of IPRMLS, RPRMLS, IPRMNP or RPRMNP. -************************************************************************ - - LOGICAL NEWOPT - COMMON /SOL7NP/ NEWOPT - SAVE /SOL7NP/ - - DOUBLE PRECISION WMACH(15) - COMMON /SOLMCH/ WMACH - SAVE /SOLMCH/ - - EXTERNAL MCHPAR - CHARACTER*16 KEY - CHARACTER*72 BUFFER - LOGICAL FIRST , PRNT - SAVE FIRST , NOUT , PRNT - DATA FIRST /.TRUE./ - -* If first time in, set NOUT. -* NEWOPT is true first time into NPFILE or NPOPTN -* and just after a call to an optimization routine. -* PRNT is set to true whenever NEWOPT is true. - - IF (FIRST) THEN - FIRST = .FALSE. - NEWOPT = .TRUE. - CALL MCHPAR() - NOUT = WMACH(11) - END IF - BUFFER = STRING - -* Call NPKEY to decode the option and set the parameter value. -* If NEWOPT is true, reset PRNT and test specially for NOLIST. - - IF (NEWOPT) THEN - NEWOPT = .FALSE. - PRNT = .TRUE. - CALL NPKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'NOLIST') THEN - PRNT = .FALSE. - ELSE - WRITE (NOUT, '(// A / A /)') - $ ' Calls to NPOPTN', - $ ' ---------------' - WRITE (NOUT, '( 6X, A )') BUFFER - END IF - ELSE - IF (PRNT) - $ WRITE (NOUT, '( 6X, A )') BUFFER - CALL NPKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'LIST') PRNT = .TRUE. - IF (KEY .EQ. 'NOLIST') PRNT = .FALSE. - END IF - - RETURN - -* End of NPOPTN. - - END
deleted file mode 100644 --- a/libcruft/npsol/npprt.f +++ /dev/null @@ -1,158 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPPRT ( KTCOND, CONVRG, LSUMRY, MSGNP, MSGQP, - $ NROWR, NROWT, N, NCLIN, NCNLN, - $ NCTOTL, NACTIV, LINACT, NLNACT, NZ, NFREE, - $ MAJITS, MINITS, ISTATE, ALFA, NFUN, - $ CONDHZ, CONDH, CONDT, OBJALF, OBJF, - $ GFNORM, GZNORM, CVNORM, - $ AX, C, R, T, VIOLN, X, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*4 LSUMRY - LOGICAL KTCOND(2), CONVRG - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION AX(*), C(*), R(NROWR,*), T(NROWT,*), VIOLN(*) - DOUBLE PRECISION X(N) - DOUBLE PRECISION WORK(N) -************************************************************************ -* NPPRT prints various levels of output for NPCORE. -* -* Msg Cumulative result -* --- ----------------- -* -* le 0 no output. -* -* eq 1 nothing now (but full output later). -* -* eq 5 one terse line of output. -* -* ge 10 same as 5 (but full output later). -* -* ge 20 objective function, x, Ax and c. -* -* ge 30 diagonals of T and R. -* -* Debug print is performed depending on the logical variable NPDBG. -* NPDBG is set true when IDBG major iterations have been performed. -* At this point, printing is done according to a string of binary -* digits of the form CLSVT (stored in the integer array INPDBG). -* -* C set 'on' gives detailed information from the checking routines. -* L set 'on' gives information from the linesearch. -* S set 'on' gives information from the maximum step routine NPALF. -* V set 'on' gives various vectors in NPCORE and its auxiliaries. -* T set 'on' gives a trace of which routine was called and an -* indication of the progress of the run. -* -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 66 version written November-1982. -* This version of NPPRT dated 14-November-1985. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL PHEAD - EXTERNAL DNRM2 - - IF (MSGNP .GE. 20) WRITE (NOUT, 1000) MAJITS - - IF (MSGNP .GE. 5) THEN -* --------------------------------------------------------------- -* Print heading and terse line. -* --------------------------------------------------------------- - PHEAD = MSGQP .GT. 0 .OR. MAJITS .EQ. 0 - - IF (NCNLN .EQ. 0) THEN - IF (PHEAD) WRITE (NOUT, 1100) - WRITE (NOUT, 1300) MAJITS, MINITS, ALFA, NFUN, OBJALF, - $ N-NFREE, LINACT, NZ, - $ GFNORM, GZNORM, CONDH, CONDHZ, CONDT, - $ CONVRG, KTCOND(1), KTCOND(2), LSUMRY - - ELSE - IF (PHEAD) WRITE (NOUT, 1110) - WRITE (NOUT, 1310) MAJITS, MINITS, ALFA, NFUN, OBJALF, - $ N-NFREE, LINACT, NLNACT, NZ, - $ GFNORM, GZNORM, CONDH, CONDHZ, CONDT, - $ CVNORM, SCALE*RHONRM, - $ CONVRG, KTCOND(1), KTCOND(2), LSUMRY - END IF - - IF (MSGNP .GE. 20) THEN - IF (NCNLN .EQ. 0) THEN - WRITE (NOUT, 1400) OBJF - ELSE - CVIOLS = DNRM2 ( NCNLN, VIOLN, 1 ) - WRITE (NOUT, 1410) OBJF, CVIOLS - END IF - -* ------------------------------------------------------------ -* Print the constraint values. -* ------------------------------------------------------------ - WRITE (NOUT, 2000) - WRITE (NOUT, 2100) (X(J), ISTATE(J), J=1,N) - IF (NCLIN .GT. 0) - $ WRITE (NOUT, 2200) (AX(K), ISTATE(N+K), K=1,NCLIN ) - IF (NCNLN .GT. 0) - $ WRITE (NOUT, 2300) (C(K) , ISTATE(N+NCLIN+K), K=1,NCNLN ) - - IF (MSGNP .GE. 30) THEN -* --------------------------------------------------------- -* Print the diagonals of T and R. -* --------------------------------------------------------- - INCT = NROWT - 1 - IF (NACTIV .GT. 0) THEN - CALL DCOPY( NACTIV, T(NACTIV,NZ+1), INCT, WORK, 1 ) - WRITE (NOUT, 3000) (WORK(J), J=1,NACTIV) - END IF - WRITE (NOUT, 3100) (R(J,J), J=1,N) - END IF - END IF - END IF - - IF (MSGNP .GE. 20) WRITE (NOUT, 5000) - - LSUMRY(1:2) = ' ' - LSUMRY(4:4) = ' ' - - RETURN - - 1000 FORMAT(/// ' Major iteration', I5 - $ / ' ====================' ) - 1100 FORMAT(// ' Itn', ' ItQP', ' Step', - $ ' Nfun', ' Objective', ' Bnd', ' Lin', ' Nz', - $ ' Norm Gf', ' Norm Gz', ' Cond H', ' Cond Hz', - $ ' Cond T', ' Conv' ) - 1110 FORMAT(// ' Itn', ' ItQP', ' Step', - $ ' Nfun', ' Merit', ' Bnd', ' Lin', - $ ' Nln', ' Nz', - $ ' Norm Gf', ' Norm Gz', ' Cond H', ' Cond Hz', - $ ' Cond T' , ' Norm C', ' Penalty', ' Conv' ) - 1300 FORMAT(2I5, 1PE9.1, I6, 1PE14.6, 3I4, 1P2E9.1, 1P3E8.0, - $ 1X, L1, 1X, 2L1, A4 ) - 1310 FORMAT(2I5, 1PE9.1, I6, 1PE14.6, 4I4, 1P2E9.1, 1P3E8.0, - $ 1P2E9.1, 1X, L1, 1X, 2L1, A4 ) - 1400 FORMAT(/ ' Nonlinear objective value = ', 1PE15.6 ) - 1410 FORMAT(/ ' Nonlinear objective value = ', 1PE15.6, ' Norm of', - $ ' the nonlinear constraint violations = ', 1PE15.6 ) - 2000 FORMAT(/ ' Values of the constraints and their predicted status' - $ / ' ----------------------------------------------------') - 2100 FORMAT(/ ' Variables '/ (1X, 5(1PE15.6, I4))) - 2200 FORMAT(/ ' General linear constraints '/ (1X, 5(1PE15.6, I4))) - 2300 FORMAT(/ ' Nonlinear constraints '/ (1X, 5(1PE15.6, I4))) - 3000 FORMAT(/ ' Diagonals of T = '/ (1P5E15.6)) - 3100 FORMAT(/ ' Diagonals of R = '/ (1P5E15.6)) - 5000 FORMAT( ' ==================================================', - $ '======================================='///) - -* End of NPPRT . - - END
deleted file mode 100644 --- a/libcruft/npsol/nprset.f +++ /dev/null @@ -1,111 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPRSET( UNITQ, - $ N, NFREE, NZ, NQ, NROWR, - $ IPERM, KX, - $ GQ, R, ZY, WORK, QRWORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER IPERM(N), KX(N) - DOUBLE PRECISION GQ(N), R(NROWR,*), ZY(NQ,*) - DOUBLE PRECISION WORK(N), QRWORK(2*N) - -************************************************************************ -* NPRSET bounds the condition estimator of the transformed Hessian. -* On exit, R is of the form -* ( DRz 0 ) -* ( 0 sigma*I ) -* where D is a diagonal matrix such that DRz has a bounded condition -* number, I is the identity matrix and sigma is the geometric mean -* of the largest and smallest elements of DRz. The QR factorization -* with interchanges is used to give diagonals of DRz that are -* decreasing in modulus. -* -* Systems Optimization Laboratory, Stanford University. -* This version of NPRSET dated 4-August-1986. -************************************************************************ - - COMMON /SOL1CM/ NOUT - COMMON /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL OVERFL - INTRINSIC MAX , MIN , LOG , REAL , SQRT - EXTERNAL DDIV , DDOT , DNORM , DNRM2 - PARAMETER ( ZERO =0.0D+0, HALF =0.5D+0, ONE =1.0D+0 ) - -* ================================================================== -* Bound the condition estimator of Q'HQ. -* The scheme used here reduces the modulus of the larger -* diagonals while increasing the modulus of the smaller ones. -* ================================================================== - IF (NZ .GT. 1) THEN -* --------------------------------------------------------------- -* Refactorize Rz. Interchanges are used to give diagonals -* of decreasing magnitude. -* --------------------------------------------------------------- - CALL DGEQRP( 'Column iterchanges', NZ, NZ, R, NROWR, - $ WORK, IPERM, QRWORK, INFO ) - - DO 110 J = 1, NZ - JMAX = IPERM(J) - IF (JMAX .GT. J) THEN - IF (UNITQ) THEN - JSAVE = KX(JMAX) - KX(JMAX) = KX(J) - KX(J) = JSAVE - ELSE - CALL DSWAP ( NFREE, ZY(1,JMAX), 1, ZY(1,J), 1 ) - END IF - - GJMAX = GQ(JMAX) - GQ(JMAX) = GQ(J) - GQ(J) = GJMAX - END IF - 110 CONTINUE - END IF - - IF (NZ .EQ. 0) THEN - DRGM = ONE - ELSE - COND = DDIV ( ABS(R(1,1)), ABS(R(NZ,NZ)), OVERFL ) - - IF (COND .GT. RCNDBD) THEN - IF (N .GT. 1) THEN - PWR = LOG(RCNDBD)/LOG(COND) - ONE - DO 120 K = 1, NZ - ROWSCL = ABS( R(K,K) )**PWR - CALL DSCAL ( NZ-K+1, ROWSCL, R(K,K), NROWR ) - 120 CONTINUE - END IF - END IF - DRGM = HALF*SQRT(ABS( R(1,1)*R(NZ,NZ) )) - END IF - -* Reset the range-space partition of the Hessian. - - IF (NZ .LT. N) THEN - DO 130 J = NZ+1, N - CALL DLOAD ( J, ZERO, R(1,J), 1 ) - 130 CONTINUE - CALL DLOAD ( N-NZ, DRGM, R(NZ+1,NZ+1), NROWR+1 ) - END IF - -* Recompute the Frobenius norm of R. - - SCLE = SQRT(REAL(N - NZ))*DRGM - SUMSQ = ONE - DO 140 J = 1, NZ - CALL DSSQ ( J, R(1,J), 1, SCLE, SUMSQ ) - 140 CONTINUE - RFROBN = DNORM( SCLE, SUMSQ ) - - RETURN - -* End of NPRSET. - - END
deleted file mode 100644 --- a/libcruft/npsol/npsetx.f +++ /dev/null @@ -1,122 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPSETX( UNITQ, - $ NCQP, NACTIV, NFREE, NZ, - $ N, NLNX, NCTOTL, NQ, NROWQP, NROWR, NROWT, - $ ISTATE, KACTIV, KX, - $ DXNORM, GDX, - $ AQP, ADX, BL, BU, RPQ, RPQ0, DX, GQ, - $ R, T, ZY, WORK ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL UNITQ - INTEGER ISTATE(NCTOTL), KACTIV(N), KX(N) - DOUBLE PRECISION AQP(NROWQP,*), ADX(*), BL(NCTOTL), BU(NCTOTL), - $ RPQ(NLNX), RPQ0(NLNX), GQ(N), R(NROWR,*), - $ T(NROWT,*), ZY(NQ,*), DX(N), WORK(N) -************************************************************************ -* NPSETX defines a point which lies on the initial working set for -* the QP subproblem. This routine is a similar to LSSETX except that -* advantage is taken of the fact that the initial estimate of the -* solution of the least-squares subproblem is zero. -* -* Systems Optimization Laboratory, Stanford University. -* Original version written 31-October-1984. -* Level 2 BLAS added 12-June-1986. -* This version of NPSETX dated 11-June-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - EXTERNAL DDOT, DNRM2 - INTRINSIC ABS , MIN - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - - NFIXED = N - NFREE - - GDX = ZERO - CALL DLOAD ( N , ZERO, DX , 1 ) - CALL DLOAD ( NLNX, ZERO, RPQ , 1 ) - CALL DLOAD ( NLNX, ZERO, RPQ0, 1 ) - - IF (NACTIV + NFIXED .GT. 0) THEN - -* Set work = residuals for constraints in the working set. -* Solve for dx, the smallest correction to x that gives a -* point on the constraints in the working set. -* Set the fixed variables on their bounds, solve the triangular -* system T*(dxy) = residuals, and define dx = Y*(dxy). -* Use (dxy) to update d(=Pr) as d = d - R'( 0 ). -* ( dxy ) - - DO 100 I = 1, NFIXED - J = KX(NFREE+I) - IF (ISTATE(J) .LE. 3) THEN - BND = BL(J) - IF (ISTATE(J) .EQ. 2) BND = BU(J) - DX(J) = BND - WORK(NFREE+I) = BND - ELSE - WORK(NFREE+I) = ZERO - END IF - 100 CONTINUE - - DO 110 I = 1, NACTIV - K = KACTIV(I) - J = N + K - BND = BL(J) - IF (ISTATE(J) .EQ. 2) BND = BU(J) - WORK(NZ+I) = BND - DDOT ( N, AQP(K,1), NROWQP, DX, 1 ) - 110 CONTINUE - - IF (NACTIV .GT. 0) - $ CALL CMTSOL( 1, NROWT, NACTIV, T(1,NZ+1), WORK(NZ+1) ) - CALL DCOPY ( NACTIV+NFIXED, WORK(NZ+1), 1, DX(NZ+1), 1 ) - IF (NZ .GT. 0) - $ CALL DLOAD ( NZ, ZERO, DX, 1 ) - - GDX = DDOT ( NACTIV+NFIXED, GQ(NZ+1), 1, DX(NZ+1), 1 ) - - IF (NZ .LT. N) THEN - CALL DGEMV ('N', NZ, N-NZ, -ONE, R(1,NZ+1), NROWR, - $ DX(NZ+1), 1, ONE, RPQ, 1 ) - IF (NZ .LT. NLNX) THEN - NR = NROWR - IF (NZ+1 .EQ. N) NR = 1 - CALL DCOPY ( NLNX-NZ, DX(NZ+1), 1, RPQ(NZ+1), 1 ) - CALL DSCAL ( NLNX-NZ, (-ONE), RPQ(NZ+1), 1 ) - CALL DTRMV ( 'U', 'N', 'N', NLNX-NZ, R(NZ+1,NZ+1), NR, - $ RPQ(NZ+1), 1 ) - IF (NLNX .LT. N) THEN - NR = NROWR - IF (NLNX+1 .EQ. N) NR = N - NZ - CALL DGEMV( 'N', NLNX-NZ, N-NLNX, -ONE,R(NZ+1,NLNX+1), - $ NR, DX(NLNX+1), 1, ONE, RPQ(NZ+1), 1 ) - END IF - END IF - END IF - - CALL CMQMUL( 2, N, NZ, NFREE, NQ, UNITQ, KX, DX, ZY, WORK ) - END IF - -* ------------------------------------------------------------------ -* Compute the 2-norm of DX. -* Initialize A*DX. -* ------------------------------------------------------------------ - DXNORM = DNRM2 ( N, DX, 1 ) - IF (NCQP .GT. 0) - $ CALL DGEMV ( 'N', NCQP, N, ONE, AQP, NROWQP, DX, 1, ZERO,ADX,1) - - IF (NPDBG .AND. INPDBG(2) .GT. 0) - $ WRITE (NOUT, 1200) (DX(J), J = 1, N) - - RETURN - - 1200 FORMAT(/ ' //NPSETX// Variables after NPSETX ... '/ (5G12.3)) - -* End of NPSETX. - - END
deleted file mode 100644 --- a/libcruft/npsol/npsol.f +++ /dev/null @@ -1,628 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPSOL ( N, NCLIN, NCNLN, NROWA, NROWUJ, NROWR, - $ A, BL, BU, - $ CONFUN, OBJFUN, - $ INFORM, ITER, ISTATE, - $ C, UJAC, CLAMDA, OBJF, UGRAD, R, X, - $ IW, LENIW, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - EXTERNAL CONFUN, OBJFUN - INTEGER ISTATE(N+NCLIN+NCNLN) - INTEGER IW(LENIW) - DOUBLE PRECISION A(NROWA,*), BL(N+NCLIN+NCNLN), - $ BU(N+NCLIN+NCNLN) - DOUBLE PRECISION C(*), UJAC(NROWUJ,*), CLAMDA(N+NCLIN+NCNLN) - DOUBLE PRECISION UGRAD(N), R(NROWR,*), X(N) - DOUBLE PRECISION W(LENW) - -*----------------------------------------------------------------------- -* -* NPSOL solves the nonlinear programming problem -* -* minimize F(x) -* -* ( x ) -* subject to bl .le. ( A*x ) .le. bu -* ( c(x) ) -* -* where F(x) is a smooth scalar function, A is a constant matrix -* and c(x) is a vector of smooth nonlinear functions. The feasible -* region is defined by a mixture of linear and nonlinear equality or -* inequality constraints on x. -* -* The dimensions of the problem are... -* -* N the number of variables (dimension of x), -* -* NCLIN the number of linear constraints (rows of the matrix A), -* -* NCNLN the number of nonlinear constraints (dimension of c(x)), -* -* -* NPSOL uses a sequential quadratic programming algorithm, with a -* positive-definite quasi-Newton approximation to the transformed -* Hessian Q'HQ of the Lagrangian function (which will be stored in -* the array R). -* -* -* Complete documentation for NPSOL is contained in Report -* SOL 86-2, Users guide for NPSOL (Version 4.0), by P.E. Gill, -* W. Murray, M.A. Saunders and M.H. Wright, Department of Operations -* Research, Stanford University, Stanford, California 94305. -* -* Systems Optimization Laboratory, Stanford University. -* Version 1.1, April 12, 1983. (The less said about this one.....) -* Version 2.0, April 30, 1984. -* Version 3.0, March 20, 1985. (First Fortran 77 version). -* Version 3.2, August 20, 1985. -* Version 4.0, April 16, 1986. (First version with differences). -* Version 4.01, June 30, 1986. (Level 2 Blas + F77 linesearch). -* Version 4.02, August 5, 1986. (Reset SSBFGS. One call to CHFD). -* -* Copyright 1983 Stanford University. -* -* This material may be reproduced by or for the U.S. Government pursu- -* ant to the copyright license under DAR Clause 7-104.9(a) (1979 Mar). -* -* This material is based upon work partially supported by the National -* Science Foundation under Grants MCS-7926009 and ECS-8312142; the -* Department of Energy Contract AM03-76SF00326, PA No. DE-AT03- -* 76ER72018; the Army Research Office Contract DAA29-84-K-0156; -* and the Office of Naval Research Grant N00014-75-C-0267. -* --------------------------------------------------------------------- - -* Common blocks. - -*----------------------------------------------------------------------- - PARAMETER (MXPARM = 30) - INTEGER IPRMLS(MXPARM), IPSVLS - DOUBLE PRECISION RPRMLS(MXPARM), RPSVLS - - COMMON /LSPAR1/ IPSVLS(MXPARM), - $ IDBGLS, ITMAX1, ITMAX2, LCRASH, LDBGLS, LPROB , - $ MSGLS , NN , NNCLIN, NPROB , IPADLS(20) - - COMMON /LSPAR2/ RPSVLS(MXPARM), - $ BIGBND, BIGDX , BNDLOW, BNDUPP, TOLACT, TOLFEA, - $ TOLRNK, RPADLS(23) - - EQUIVALENCE (IPRMLS(1), IDBGLS), (RPRMLS(1), BIGBND) - - SAVE /LSPAR1/, /LSPAR2/ -*----------------------------------------------------------------------- -*----------------------------------------------------------------------- - INTEGER IPRMNP(MXPARM), IPSVNP - DOUBLE PRECISION RPRMNP(MXPARM), RPSVNP - - COMMON /NPPAR1/ IPSVNP(MXPARM), - $ IDBGNP, ITMXNP, JVRFY1, JVRFY2, JVRFY3, JVRFY4, - $ LDBGNP, LFORMH, LVLDER, LVERFY, MSGNP , NLNF , - $ NLNJ , NLNX , NNCNLN, IPADNP(15) - - COMMON /NPPAR2/ RPSVNP(MXPARM), - $ CDINT , CTOL , EPSRF , ETA , FDINT , FTOL , - $ RPADNP(24) - - EQUIVALENCE (IPRMNP(1), IDBGNP), (RPRMNP(1), CDINT) - - SAVE /NPPAR1/, /NPPAR2/ -*----------------------------------------------------------------------- - EQUIVALENCE (IDBGNP, IDBG ), (ITMXNP, NMAJOR), (ITMAX2, NMINOR) - EQUIVALENCE (LDBGLS, MNRDBG), (LDBGNP, MJRDBG), (MSGLS , MSGQP ) - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - COMMON /SOL3CM/ LENNAM, NROWT , NCOLT , NQ - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - COMMON /SOL5CM/ ASIZE , DTMAX , DTMIN - COMMON /SOL6CM/ RCNDBD, RFROBN, DRMAX , DRMIN - - LOGICAL UNITQ - COMMON /SOL1SV/ NACTIV, NFREE , NZ , UNITQ - SAVE /SOL1SV/ - - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - PARAMETER (LENNP = 35) - COMMON /SOL1NP/ LOCNP(LENNP) - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - COMMON /SOL5NP/ LVRFYC, JVERFY(4) - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL CMDBG, LSDBG, NPDBG - PARAMETER (LDBG = 5) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - COMMON /LSDEBG/ ILSDBG(LDBG), LSDBG - COMMON /CMDEBG/ ICMDBG(LDBG), CMDBG - - INTRINSIC ABS , MAX , MIN , MOD , SQRT , REAL - -* Local variables. - - EXTERNAL DDIV , DDOT , DNORM , DNRM2 - CHARACTER*8 NAMES(1) - LOGICAL COLD , LINOBJ, NAMED , OVERFL, ROWERR, VERTEX - PARAMETER (ZERO =0.0D+0, POINT1 =0.1D+0, POINT3 =3.3D-1) - PARAMETER (POINT8 =0.8D+0, POINT9 =0.9D+0, ONE =1.0D+0) - PARAMETER (GROWTH =1.0D+2 ) - - CHARACTER*40 TITLE - DATA TITLE - $ / 'SOL/NPSOL --- Version 4.02 Aug 1986' / - -* Set the machine-dependent constants. - - CALL MCHPAR() - - EPSMCH = WMACH( 3) - RTEPS = WMACH( 4) - NOUT = WMACH(11) - - EPSPT3 = EPSMCH**POINT3 - EPSPT5 = RTEPS - EPSPT8 = EPSMCH**POINT8 - EPSPT9 = EPSMCH**POINT9 - - RHOMAX = ONE/EPSMCH - ROOTN = SQRT(REAL(N)) - -* Default names will be provided for variables during printing. - - NAMED = .FALSE. - INFORM = 0 - ITER = 0 - -* Set the default values for the parameters. - - CALL NPDFLT( N, NCLIN, NCNLN, LENIW, LENW, TITLE ) - - COLD = LCRASH .EQ. 0 - - NPLIN = N + NCLIN - NCTOTL = NPLIN + NCNLN - -* Assign the dimensions of arrays in the parameter list of NPCORE. -* Economies of storage are possible if the minimum number of active -* constraints and the minimum number of fixed variables are known in -* advance. The expert user should alter MINACT and MINFXD -* accordingly. - - MINACT = 0 - MINFXD = 0 - - MXFREE = N - MINFXD - MAXACT = MAX( 1, MIN( N, NCLIN ) ) - MAXNZ = N - ( MINFXD + MINACT ) - - IF (NCLIN + NCNLN .EQ. 0) THEN - NQ = 1 - NROWT = 1 - NCOLT = 1 - ELSE - NQ = MAX( 1, MXFREE ) - NROWT = MAX( MAXNZ, MAXACT ) - NCOLT = MXFREE - END IF - - LENNAM = 1 - - NROWQP = MAX( NCLIN+NCNLN, 1 ) - IF (NCNLN .EQ. 0 .AND. NCLIN .GT. 0) NROWQP = NROWA - -* NPLOC defines the arrays that contain the locations of various -* work arrays within W and IW. - - LITOTL = 0 - LWTOTL = 0 - CALL NPLOC( N, NCLIN, NCNLN, NCTOTL, LITOTL, LWTOTL) - -* Allocate certain addresses that are not allocated in NPLOC. - - LAX = LWTOTL + 1 - LWTOTL = LAX + NCLIN - 1 - LAX = MIN( LAX, LWTOTL ) - -* Check input parameters and storage limits. - - CALL CMCHK ( NERROR, MSGNP, COLD, .FALSE., - $ LENIW, LENW, LITOTL, LWTOTL, - $ N, NCLIN, NCNLN, - $ ISTATE, IW, NAMED, NAMES, LENNAM, - $ BL, BU, X ) - - IF (NERROR .GT. 0) THEN - INFORM = 9 - GO TO 800 - END IF - - LKACTV = LOCLS( 1) - LANORM = LOCLS( 2) - LCJDX = LOCLS( 3) - LRES = LOCLS( 5) - LRES0 = LOCLS( 6) - LGQ = LOCLS( 9) - LT = LOCLS(11) - LZY = LOCLS(12) - LWTINF = LOCLS(13) - LWRK1 = LOCLS(14) - - LKX = LOCNP( 1) - LIPERM = LOCNP( 2) - LAQP = LOCNP( 3) - LDX = LOCNP( 7) - LFEATL = LOCNP(10) - LWRK2 = LOCNP(12) - - LCMUL = LOCNP(16) - LWRK3 = LOCNP(21) - LNEEDC = LOCNP(24) - LHFRWD = LOCNP(25) - LHCTRL = LOCNP(26) - LCJAC = LOCNP(27) - LGRAD = LOCNP(28) - - NROWJ = MAX ( NCNLN, 1 ) - - TOLRNK = ZERO - RCNDBD = ONE/SQRT(EPSPT5) - - IF (TOLFEA .GT. ZERO) - $ CALL DLOAD ( NPLIN, TOLFEA, W(LFEATL), 1 ) - - IF (NCNLN .GT. 0 .AND. CTOL .GT. ZERO) - $ CALL DLOAD ( NCNLN, CTOL, W(LFEATL+NPLIN), 1 ) - - IF (LFDSET .EQ. 0) THEN - FDCHK = SQRT( EPSRF ) - ELSE IF (LFDSET .EQ. 1) THEN - FDCHK = FDINT - ELSE - FDCHK = W(LHFRWD) - END IF - - NFUN = 0 - NGRAD = 0 - NSTATE = 1 - -* ------------------------------------------------------------------ -* If required, compute the problem functions. -* If the constraints are nonlinear, the first call of CONFUN -* sets up any constant elements in the Jacobian matrix. A copy of -* the Jacobian (with constant elements set) is placed in UJAC. -* ------------------------------------------------------------------ - IF (LVERFY .GE. 10) THEN - XNORM = DNRM2 ( N, X, 1 ) - LVRFYC = LVERFY - 10 - - CALL NPCHKD( INFO, MSGNP, NSTATE, LVLDER, NFUN, NGRAD, - $ NROWJ, NROWUJ, N, NCNLN, - $ CONFUN, OBJFUN, IW(LNEEDC), - $ BIGBND, EPSRF, CDINT, FDINT, - $ FDCHK, FDNORM, OBJF, XNORM, - $ BL, BU, C, W(LWRK3), W(LCJAC), UJAC, W(LCJDX), - $ W(LDX), W(LGRAD), UGRAD, W(LHFRWD), W(LHCTRL), - $ X, W(LWRK1), W(LWRK2), W, LENW ) - - IF (INFO .NE. 0) THEN - IF (INFO .GT. 0) INFORM = 7 - IF (INFO .LT. 0) INFORM = INFO - GO TO 800 - END IF - NSTATE = 0 - END IF - - IF (LCRASH .LT. 2) THEN -* =============================================================== -* Cold or warm start. Use LSCORE to obtain a point that -* satisfies the linear constraints. -* =============================================================== - CALL ICOPY ( LDBG, ILSDBG, 1, ICMDBG, 1 ) - - IF (NCLIN .GT. 0) THEN - IANRMJ = LANORM - DO 110 J = 1, NCLIN - W(IANRMJ) = DNRM2 ( N, A(J,1), NROWA ) - IANRMJ = IANRMJ + 1 - 110 CONTINUE - CALL DCOND ( NCLIN, W(LANORM), 1, ASIZE, AMIN ) - END IF - - CALL DCOND ( NPLIN, W(LFEATL), 1, FEAMAX, FEAMIN ) - CALL DCOPY ( NPLIN, W(LFEATL), 1, W(LWTINF), 1 ) - CALL DSCAL ( NPLIN, (ONE/FEAMIN), W(LWTINF), 1 ) - -* =============================================================== -* The input values of X and (optionally) ISTATE are used by -* LSCRSH to define an initial working set. -* =============================================================== - VERTEX = .FALSE. - CALL LSCRSH( COLD, VERTEX, - $ NCLIN, NPLIN, NACTIV, NARTIF, - $ NFREE, N, NROWA, - $ ISTATE, IW(LKACTV), - $ BIGBND, TOLACT, - $ A, W(LAX), BL, BU, X, W(LWRK1), W(LWRK2) ) - - UNITQ = .TRUE. - NRES = 0 - NGQ = 0 - CONDMX = ONE / EPSPT5 - - IKX = LKX - DO 120 I = 1, N - IW(IKX) = I - IKX = IKX + 1 - 120 CONTINUE - - IF (COLD) THEN - NRANK = 0 - ELSE - NRANK = NLNX - CALL DLOAD ( NLNX, (ZERO), W(LRES0), 1 ) - END IF - -* --------------------------------------------------------------- -* Re-order KX so that the free variables come first. -* If a warm start is required, NRANK will be nonzero and the -* factor R will be updated. -* --------------------------------------------------------------- - CALL LSBNDS( UNITQ, - $ INFORM, NZ, NFREE, NRANK, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, IW(LKX), - $ CONDMX, - $ A, R, W(LT), W(LRES0), W(LGQ), - $ W(LZY), W(LWRK1), W(LWRK2) ) - -* --------------------------------------------------------------- -* Factorize the initial working set. -* --------------------------------------------------------------- - IF (NACTIV .GT. 0) THEN - NACT1 = NACTIV - NACTIV = 0 - - CALL LSADDS( UNITQ, VERTEX, - $ INFORM, 1, NACT1, NACTIV, NARTIF, NZ, NFREE, - $ NRANK, NREJTD, NRES, NGQ, - $ N, NQ, NROWA, NROWR, NROWT, - $ ISTATE, IW(LKACTV), IW(LKX), - $ CONDMX, - $ A, R, W(LT), W(LRES0), W(LGQ), - $ W(LZY), W(LWRK1), W(LWRK2) ) - END IF - - SSQ1 = ZERO - - LINOBJ = .FALSE. - CALL LSSETX( LINOBJ, ROWERR, UNITQ, - $ NCLIN, NACTIV, NFREE, NRANK, NZ, - $ N, NPLIN, NQ, NROWA, NROWR, NROWT, - $ ISTATE, IW(LKACTV), IW(LKX), - $ JMAX, ERRMAX, CTX, XNORM, - $ A, W(LAX), BL, BU, W(LGQ), W(LRES), W(LRES0), - $ W(LFEATL), R, W(LT), X, W(LZY),W(LWRK1),W(LWRK2) ) - -* --------------------------------------------------------------- -* Call LSCORE to find a feasible x. -* --------------------------------------------------------------- -* Use WORK2 as the multiplier vector. - - JINF = 0 - LCLAM = LWRK2 - - IDBGSV = IDBG - IF (IDBG .GT. 0) THEN - IDBG = NMINOR + 1 - END IF - - CALL LSCORE( 'FP problem', NAMED, NAMES, LINOBJ, UNITQ, - $ NLPERR, ITER, JINF, NCLIN, NPLIN, - $ NACTIV, NFREE, NRANK, NZ, NZ1, - $ N, NROWA, NROWR, - $ ISTATE, IW(LKACTV), IW(LKX), - $ CTX, OBJ, SSQ1, SUMINF, NUMINF, XNORM, - $ BL, BU, A, W(LCLAM), W(LAX), - $ W(LFEATL), R, X, IW, W ) - - IF (NLPERR .GT. 0) THEN - INFORM = 2 - GO TO 800 - END IF - END IF - - IDBG = IDBGSV - CALL ICOPY ( LDBG, INPDBG, 1, ICMDBG, 1 ) - - LVRFYC = LVERFY - IF (LVERFY .GE. 10) LVRFYC = -1 - - CALL NPCHKD( INFO, MSGNP, NSTATE, LVLDER, NFUN, NGRAD, - $ NROWJ, NROWUJ, N, NCNLN, - $ CONFUN, OBJFUN, IW(LNEEDC), - $ BIGBND, EPSRF, CDINT, FDINT, - $ FDCHK, FDNORM, OBJF, XNORM, - $ BL, BU, C, W(LWRK3), W(LCJAC), UJAC, W(LCJDX), - $ W(LDX), W(LGRAD), UGRAD, W(LHFRWD), W(LHCTRL), - $ X, W(LWRK1), W(LWRK2), W, LENW ) - - IF (INFO .NE. 0) THEN - IF (INFO .GT. 0) INFORM = 7 - IF (INFO .LT. 0) INFORM = INFO - GO TO 800 - END IF - - CALL DCOPY ( N, W(LGRAD), 1, W(LGQ), 1 ) - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, - $ IW(LKX), W(LGQ), W(LZY), W(LWRK1) ) - - IF (COLD) THEN -* --------------------------------------------------------------- -* Cold start. Initialize R as the identity matrix. -* --------------------------------------------------------------- - DO 210 J = 1, N - CALL DLOAD ( N, ZERO, R(1,J), 1 ) - 210 CONTINUE - CALL DLOAD ( N, ONE, R, NROWR+1 ) - RFROBN = ROOTN - - IF (NCNLN .GT. 0) CALL DLOAD ( NCNLN, (ZERO), W(LCMUL), 1 ) - ELSE -* --------------------------------------------------------------- -* Warm start. -* Set the multipliers for the nonlinear constraints. -* Check the condition of the initial factor R. -* --------------------------------------------------------------- - IF (NCNLN .GT. 0) - $ CALL DCOPY ( NCNLN, CLAMDA(NPLIN+1), 1, W(LCMUL), 1 ) - - SCLE = ZERO - SUMSQ = ONE - DO 220 J = 1, N - CALL DSSQ ( J, R(1,J), 1, SCLE, SUMSQ ) - 220 CONTINUE - RFROBN = DNORM( SCLE, SUMSQ ) - - CALL DCOND ( N, R, NROWR+1, DRMAX, DRMIN ) - COND = DDIV ( DRMAX, DRMIN, OVERFL ) - - IF ( COND .GT. RCNDBD - $ .OR. RFROBN .GT. ROOTN*GROWTH*DRMAX) THEN -* ------------------------------------------------------------ -* Refactorize the Hessian and bound the condition estimator. -* ------------------------------------------------------------ - CALL NPRSET( UNITQ, - $ N, NFREE, NZ, NQ, NROWR, - $ IW(LIPERM), IW(LKX), - $ W(LGQ), R, W(LZY), W(LWRK1), W(LRES0) ) - END IF - END IF - -* ================================================================== -* Solve the problem. -* ================================================================== - IF (NCNLN .EQ. 0) THEN -* --------------------------------------------------------------- -* The problem has only linear constraints and bounds. -* --------------------------------------------------------------- - CALL NPCORE( NAMED, NAMES, UNITQ, INFORM, ITER, - $ N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ, - $ NROWA, NROWJ, NROWUJ, NROWQP, NROWR, - $ NFUN, NGRAD, ISTATE, IW(LKACTV), IW(LKX), - $ OBJF, FDNORM, XNORM, OBJFUN, CONFUN, - $ A, W(LAX), BL, BU, C, W(LCJAC), UJAC, CLAMDA, - $ W(LFEATL), W(LGRAD), UGRAD, R, X, IW, W, LENW ) - ELSE -* --------------------------------------------------------------- -* The problem has some nonlinear constraints. -* --------------------------------------------------------------- - IF (NCLIN .GT. 0) THEN - LA1J = LAQP - DO 520 J = 1, N - CALL DCOPY ( NCLIN, A(1,J), 1, W(LA1J), 1 ) - LA1J = LA1J + NROWQP - 520 CONTINUE - END IF - -* Try and add some nonlinear constraint indices to KACTIV. -* - CALL NPCRSH( COLD, N, NCLIN, NCNLN, - $ NCTOTL, NACTIV, NFREE, NZ, - $ ISTATE, IW(LKACTV), BIGBND, TOLACT, - $ BL, BU, C ) - - CALL NPCORE( NAMED, NAMES, UNITQ, INFORM, ITER, - $ N, NCLIN, NCNLN, NCTOTL, NACTIV, NFREE, NZ, - $ NROWA, NROWJ, NROWUJ, NROWQP, NROWR, - $ NFUN, NGRAD, ISTATE, IW(LKACTV),IW(LKX), - $ OBJF, FDNORM, XNORM, OBJFUN, CONFUN, - $ W(LAQP), W(LAX), BL, BU, C, W(LCJAC),UJAC,CLAMDA, - $ W(LFEATL), W(LGRAD), UGRAD, R, X, IW, W, LENW ) - - END IF - -* ------------------------------------------------------------------ -* If required, form the triangular factor of the Hessian. -* ------------------------------------------------------------------ -* First, form the square matrix R such that H = R'R. -* Compute the QR factorization of R. - - IF (LFORMH .GT. 0) THEN - LV = LWRK2 - DO 400 J = 1, N - IF (J .GT. 1) - $ CALL DLOAD ( J-1, ZERO, W(LV), 1 ) - - LVJ = LV + J - 1 - CALL DCOPY ( N-J+1, R(J,J), NROWR, W(LVJ), 1 ) - CALL CMQMUL( 3, N, NZ, NFREE, NQ, UNITQ, - $ IW(LKX), W(LV), W(LZY), W(LWRK1) ) - CALL DCOPY ( N , W(LV) , 1 , R(J,1), NROWR ) - 400 CONTINUE - - CALL DGEQR ( N, N, R, NROWR, W(LWRK1), INFO ) - END IF - -* Print messages if required. - - 800 IF (MSGNP .GT. 0) THEN - IF (INFORM .LT. 0) WRITE (NOUT, 3000) - IF (INFORM .EQ. 0) WRITE (NOUT, 4000) - IF (INFORM .EQ. 1) WRITE (NOUT, 4100) - IF (INFORM .EQ. 2) WRITE (NOUT, 4200) - IF (INFORM .EQ. 3) WRITE (NOUT, 4300) - IF (INFORM .EQ. 4) WRITE (NOUT, 4400) - IF (INFORM .EQ. 5) WRITE (NOUT, 4500) - IF (INFORM .EQ. 6) WRITE (NOUT, 4600) - IF (INFORM .EQ. 7) WRITE (NOUT, 4700) - IF (INFORM .EQ. 9) WRITE (NOUT, 4900) NERROR - - IF (INFORM .GE. 0 .AND. INFORM .NE. 9) THEN - IF (NLPERR .EQ. 0) THEN - WRITE (NOUT, 5000) OBJF - ELSE - IF (NLPERR .EQ. 3) THEN - WRITE (NOUT, 5010) SUMINF - ELSE - WRITE (NOUT, 5020) SUMINF - END IF - END IF - END IF - END IF - -* Recover the optional parameters set by the user. - - CALL ICOPY ( MXPARM, IPSVLS, 1, IPRMLS, 1 ) - CALL DCOPY ( MXPARM, RPSVLS, 1, RPRMLS, 1 ) - CALL ICOPY ( MXPARM, IPSVNP, 1, IPRMNP, 1 ) - CALL DCOPY ( MXPARM, RPSVNP, 1, RPRMNP, 1 ) - - RETURN - - 3000 FORMAT(/ ' Exit NPSOL - User requested termination.' ) - 4000 FORMAT(/ ' Exit NPSOL - Optimal solution found.' ) - 4100 FORMAT(/ ' Exit NPSOL - Optimal solution found, ', - $ ' but the requested accuracy could not be achieved.' ) - 4200 FORMAT(/ ' Exit NPSOL - No feasible point for the linear', - $ ' constraints.') - 4300 FORMAT(/ ' Exit NPSOL - No feasible point for the nonlinear', - $ ' constraints.') - 4400 FORMAT(/ ' Exit NPSOL - Too many major iterations. ') - 4500 FORMAT(/ ' Exit NPSOL - Problem is unbounded (or badly scaled).') - 4600 FORMAT(/ ' Exit NPSOL - Current point cannot be improved upon. ') - 4700 FORMAT(/ ' Exit NPSOL - Large errors found in the derivatives. ') - - 4900 FORMAT(/ ' Exit NPSOL - ', I10, ' errors found in the input', - $ ' parameters. Problem abandoned.') - 5000 FORMAT(/ ' Final nonlinear objective value =', G16.7 ) - 5010 FORMAT(/ ' Minimum sum of infeasibilities =', G16.7 ) - 5020 FORMAT(/ ' Final sum of infeasibilities =', G16.7 ) - -* End of NPSOL . - - END
deleted file mode 100644 --- a/libcruft/npsol/npsrch.f +++ /dev/null @@ -1,309 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPSRCH( NEEDFD, INFORM, N, NCNLN, - $ NROWJ, NROWUJ, NFUN, NGRAD, - $ NEEDC, CONFUN, OBJFUN, - $ ALFA, ALFBND, ALFMAX, ALFSML, DXNORM, - $ EPSRF, ETA, GDX, GRDALF, GLF1, GLF, - $ OBJF, OBJALF, QPCURV, XNORM, - $ C, CJAC, UJAC, CJDX, CMUL1, CMUL, CS1, CS, - $ DX, DLAM, DSLK, GRAD, UGRAD, QPMUL, RHO, - $ SLK1, SLK, X1, X, W, LENW ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL NEEDFD - INTEGER NEEDC(*) - DOUBLE PRECISION DX(N), GRAD(N), UGRAD(N), X1(N), X(N) - DOUBLE PRECISION C(*), CJAC(NROWJ,*), UJAC(NROWUJ,*), CJDX(*), - $ CMUL1(*), CMUL(*), CS1(*), CS(*) - DOUBLE PRECISION DLAM(*), DSLK(*), QPMUL(*), - $ RHO(*), SLK1(*), SLK(*) - DOUBLE PRECISION W(LENW) - EXTERNAL OBJFUN, CONFUN - -************************************************************************ -* NPSRCH finds the steplength ALFA that gives sufficient decrease in -* the augmented Lagrangian merit function. -* -* On exit, if INFORM = 1, 2 or 3, ALFA will be a nonzero steplength -* with an associated merit function value OBJALF which is lower than -* that at the base point. If INFORM = 4, 5, 6 or 7, ALFA is zero -* and OBJALF will be the merit value at the base point. -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version written 27-May-1985. -* Level 2 BLAS added 12-June-1986. -* This version of NPSRCH dated 12-July-1986. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - - COMMON /SOL1CM/ NOUT - COMMON /SOL4CM/ EPSPT3, EPSPT5, EPSPT8, EPSPT9 - - PARAMETER (LENLS = 20) - COMMON /SOL1LS/ LOCLS(LENLS) - - PARAMETER (LENNP = 35) - COMMON /SOL1NP/ LOCNP(LENNP) - COMMON /SOL4NP/ LVLDIF, NCDIFF, NFDIFF, LFDSET - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL DEBUG , DONE , FIRST , IMPRVD - EXTERNAL DDOT , DNRM2 - INTRINSIC ABS , MAX , MIN , SQRT - PARAMETER ( ZERO =0.0D+0, HALF =0.5D+0, ONE =1.0D+0 ) - PARAMETER ( TWO =2.0D+0 ) - PARAMETER ( TOLG =1.0D-1 ) - - EPSMCH = WMACH(3) - - LC = LOCLS(14) - LWORK = LOCNP(12) - LCJDX = LOCNP(21) - - IF (.NOT. NEEDFD .AND. NCNLN .GT. 0) - $ CS1JDX = DDOT( NCNLN, CS1, 1, CJDX, 1 ) - -* ------------------------------------------------------------------ -* Set the input parameters and tolerances for SRCHC and SRCHQ. -* -* TOLRX is the tolerance on relative changes in DX resulting from -* changes in ALFA. -* -* TOLAX is the tolerance on absolute changes in DX resulting from -* changes in ALFA. -* -* TOLABS is the tolerance on absolute changes in ALFA. -* -* TOLREL is the tolerance on relative changes in ALFA. -* -* TOLTNY is the magnitude of the smallest allowable value of ALFA. -* If M(TOLABS) - M(0) .gt. EPSAF, the linesearch tries -* steps in the range TOLTNY .LE. ALFA .LE. TOLABS. -* ------------------------------------------------------------------ - NSTATE = 0 - DEBUG = NPDBG .AND. INPDBG(4) .GT. 0 - - EPSAF = EPSRF*(ONE + ABS( OBJALF )) - - TOLAX = EPSPT8 - TOLRX = EPSPT8 - - TOLABS = ALFMAX - IF (TOLRX*XNORM + TOLAX .LT. DXNORM*ALFBND) - $ TOLABS = (TOLRX*XNORM + TOLAX) / DXNORM - TOLREL = MAX( TOLRX , EPSMCH ) - - T = ZERO - DO 10 J = 1, N - S = ABS( DX(J) ) - Q = ABS( X(J) )*TOLRX + TOLAX - IF (S .GT. T*Q) T = S / Q - 10 CONTINUE - - TOLTNY = TOLABS - IF (T*TOLABS .GT. ONE) TOLTNY = ONE / T - - OLDF = OBJALF - OLDG = GRDALF - - IF (NCNLN .GT. 0) CALL ILOAD ( NCNLN, (1), NEEDC, 1 ) - - MODE = 2 - IF (NEEDFD) MODE = 0 - - FIRST = .TRUE. - -* ------------------------------------------------------------------ -* Commence main loop, entering SRCHC or SRCHQ two or more times. -* FIRST = true for the first entry, false for subsequent entries. -* DONE = true indicates termination, in which case the value of -* INFORM gives the result of the search. -* ------------------------------------------------------------------ -*+ REPEAT - 100 IF (NEEDFD) THEN - CALL SRCHQ ( DEBUG, DONE, FIRST, IMPRVD, INFORM, - $ ALFMAX, ALFSML, EPSAF, ETA, - $ XTRY, FTRY, OLDF, OLDG, - $ TOLABS, TOLREL, TOLTNY, - $ ALFA, ALFBST, FBEST ) - ELSE - CALL SRCHC ( DEBUG, DONE, FIRST, IMPRVD, INFORM, - $ ALFMAX, EPSAF, ETA, - $ XTRY, FTRY, GTRY, OLDF, OLDG, - $ TOLABS, TOLREL, TOLTNY, - $ ALFA, ALFBST, FBEST, GBEST ) - END IF - - IF (IMPRVD) THEN - OBJF = TOBJ - OBJALF = FTRY - - IF (NCNLN .GT. 0) - $ CALL DCOPY ( NCNLN, W(LC), 1, C, 1 ) - - IF (.NOT. NEEDFD) THEN - CALL DCOPY ( N, UGRAD, 1, GRAD, 1 ) - GDX = TGDX - GLF = TGLF - - IF (NCNLN .GT. 0) THEN - CALL DCOPY ( NCNLN, W(LCJDX), 1, CJDX, 1 ) - DO 120 J = 1, N - CALL DCOPY ( NCNLN, UJAC(1,J), 1, CJAC(1,J), 1 ) - 120 CONTINUE - END IF - END IF - END IF - -* --------------------------------------------------------------- -* If DONE = FALSE, the problem functions must be computed for -* the next entry to SRCHC or SRCHQ. -* If DONE = TRUE, this is the last time through. -* --------------------------------------------------------------- - IF (.NOT. DONE) THEN - - NFUN = NFUN + 1 - IF (.NOT. NEEDFD) NGRAD = NGRAD + 1 - - CALL DCOPY ( N, X1, 1, X, 1 ) - CALL DAXPY ( N, ALFA, DX, 1, X, 1 ) - IF (NCNLN .GT. 0) THEN - -* Compute the new estimates of the multipliers and slacks. -* If the step length is greater than one, the multipliers -* are fixed as the QP-multipliers. - - IF (ALFA .LE. ONE) THEN - CALL DCOPY ( NCNLN, CMUL1, 1, CMUL, 1 ) - CALL DAXPY ( NCNLN, ALFA, DLAM , 1, CMUL, 1 ) - END IF - CALL DCOPY ( NCNLN, SLK1, 1, SLK, 1 ) - CALL DAXPY ( NCNLN, ALFA, DSLK, 1, SLK, 1 ) - -* --------------------------------------------------------- -* Compute the new constraint vector and Jacobian. -* --------------------------------------------------------- - CALL CONFUN( MODE, NCNLN, N, NROWUJ, - $ NEEDC, X, W(LC), UJAC, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - CALL DCOPY ( NCNLN, W(LC), 1, CS, 1 ) - CALL DAXPY ( NCNLN, (-ONE), SLK , 1, CS, 1 ) - - CALL DCOPY ( NCNLN, CS , 1, W(LWORK), 1 ) - CALL DDSCL ( NCNLN, RHO, 1, W(LWORK), 1 ) - - FTERM = DDOT( NCNLN, CMUL , 1, CS, 1 ) - - $ HALF*SCALE*DDOT( NCNLN, W(LWORK), 1, CS, 1 ) - - END IF - -* ------------------------------------------------------------ -* Compute the value and gradient of the objective function. -* ------------------------------------------------------------ - CALL OBJFUN( MODE, N, X, TOBJ, UGRAD, NSTATE ) - IF (MODE .LT. 0) GO TO 999 - - FTRY = TOBJ - IF (NCNLN .GT. 0) FTRY = TOBJ - FTERM - -* ------------------------------------------------------------ -* Compute auxiliary gradient information. -* ------------------------------------------------------------ - IF (.NOT. NEEDFD) THEN - GTRY = DDOT( N, UGRAD, 1, DX, 1 ) - TGDX = GTRY - TGLF = GTRY - IF (NCNLN .GT. 0) THEN - -* Compute the Jacobian times the search direction. - - CALL DGEMV ( 'N', NCNLN, N, ONE, UJAC, NROWUJ, DX, 1, - $ ZERO, W(LCJDX), 1 ) - - CALL DCOPY ( NCNLN, W(LCJDX), 1, W(LWORK), 1 ) - CALL DAXPY ( NCNLN, (-ONE), DSLK , 1, W(LWORK), 1 ) - - GTRY = GTRY - DDOT( NCNLN, CMUL, 1, W(LWORK), 1 ) - IF (ALFA .LE. ONE) - $ GTRY = GTRY - DDOT( NCNLN, DLAM, 1, CS , 1 ) - - CALL DDSCL ( NCNLN, RHO , 1, W(LWORK), 1 ) - GTRY = GTRY + - $ SCALE*DDOT( NCNLN, W(LWORK), 1, CS , 1 ) - - TGLF = TGDX - DDOT( NCNLN, W(LCJDX), 1, QPMUL, 1 ) - -* ------------------------------------------------------ -* If ALFBND .LE. ALFA .LT. ALFMAX and the norm of the -* quasi-Newton update is bounded, set ALFMAX to be ALFA. -* This will cause the linesearch to stop if the merit -* function is decreasing at the boundary. -* ------------------------------------------------------ - IF (ALFBND .LE. ALFA .AND. ALFA .LT. ALFMAX) THEN - - CSJDX = DDOT ( NCNLN, CS, 1, W(LCJDX), 1 ) - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1400) CSJDX, CS1JDX, CURVLF - - CURVLF = TGLF - GLF1 - CURVC = ABS( CSJDX - CS1JDX ) - RHOBFS = MAX( QPCURV*TOLG - CURVLF, ZERO ) - IF (RHOBFS .LE. CURVC*RHOMAX) THEN - ALFMAX = ALFA - ELSE - ALFBND = MIN( TWO*ALFA, ALFMAX ) - END IF - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE(NOUT,1300) ALFBND, ALFA, ALFMAX - END IF - END IF - END IF - END IF -*+ UNTIL ( DONE) - IF (.NOT. DONE) GO TO 100 - - ALFA = ALFBST - IF (.NOT. IMPRVD) THEN - CALL DCOPY ( N, X1, 1, X, 1 ) - CALL DAXPY ( N, ALFA, DX, 1, X, 1 ) - IF (NCNLN .GT. 0) THEN - IF (ALFA .LE. ONE) THEN - CALL DCOPY ( NCNLN, CMUL1, 1, CMUL, 1 ) - CALL DAXPY ( NCNLN, ALFA, DLAM , 1, CMUL, 1 ) - END IF - CALL DCOPY ( NCNLN, SLK1 , 1, SLK, 1 ) - CALL DAXPY ( NCNLN, ALFA, DSLK , 1, SLK, 1 ) - CALL DCOPY ( NCNLN, C , 1, CS , 1 ) - CALL DAXPY ( NCNLN, (-ONE), SLK , 1, CS , 1 ) - END IF - END IF - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1200) INFORM - - RETURN - -* The user wants to stop. - - 999 INFORM = MODE - RETURN - - 1200 FORMAT(/ ' //NPSRCH// INFORM = ', I4 ) - 1300 FORMAT(/ ' //NPSRCH// ALFBND ALFA ALFMAX' - $ / ' //NPSRCH//', 1P3E14.2 ) - 1400 FORMAT(/ ' //NPSRCH// CSJDX CS1JDX CURVLF' - $ / ' //NPSRCH//', 1P3E14.2 ) - -* End of NPSRCH. - - END
deleted file mode 100644 --- a/libcruft/npsol/npupdt.f +++ /dev/null @@ -1,194 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE NPUPDT( LSUMRY, UNITQ, - $ N, NCNLN, NFREE, NZ, - $ NROWJ1, NROWJ2, NQ, NROWR, KX, - $ ALFA, GLF1, GLF2, QPCURV, - $ CJAC1, CJAC2, CJDX1, CJDX2, - $ CS1, CS2, GQ1, GQ2, HPQ, RPQ, - $ QPMUL, R, OMEGA, ZY, WRK1, WRK2 ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - CHARACTER*4 LSUMRY - LOGICAL UNITQ - INTEGER KX(N) - DOUBLE PRECISION CJAC1(NROWJ1,*), CJAC2(NROWJ2,*), - $ CJDX1(*), CJDX2(*), CS1(*), CS2(*), - $ GQ1(N), GQ2(N), HPQ(N), RPQ(N), QPMUL(*), - $ R(NROWR,*), OMEGA(*), ZY(NQ,*) - DOUBLE PRECISION WRK1(N+NCNLN), WRK2(N) - -************************************************************************ -* NPUPDT computes the BFGS update for the approximate Hessian of the -* Lagrangian. If the approximate curvature of the Lagrangian function -* is negative, a nonnegative penalty vector OMEGA(i) of minimum two -* norm is computed such that the approximate curvature of the augmented -* Lagrangian will be positive. If no finite penalty vector exists, the -* BFGS update is performed with the approximate curvature modified to -* be a small positive value. -* -* On entry, GQ1 and GQ2 contain the transformed objective gradients at -* X1 and X2, HPQ contains R'R(pq), the transformed Hessian times the -* transformed search direction. The vectors GQ1 and HPQ are not saved. -* If the regular BFGS quasi-Newton update could not be performed, the -* first character of LSUMRY is loaded with 'M'. -* -* Systems Optimization Laboratory, Stanford University. -* Original Fortran 66 version written April 1984. -* Level 2 BLAS added 12-June-1986. -* This version of NPUPTD dated 4-August-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - COMMON /SOL6CM/ RCNDBD, RFROBN, DRMAX, DRMIN - - LOGICAL INCRUN - COMMON /SOL6NP/ RHOMAX, RHONRM, RHODMP, SCALE, INCRUN - - LOGICAL NPDBG - PARAMETER ( LDBG = 5 ) - COMMON /NPDEBG/ INPDBG(LDBG), NPDBG - - LOGICAL OVERFL, SSBFGS - INTRINSIC MAX , MIN , SQRT - EXTERNAL IDAMAX, DDIV , DDOT , DNRM2 - PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) - PARAMETER ( TOLG = 1.0D-1 ) - - IF (NCNLN .GT. 0) CALL DLOAD ( NCNLN, ZERO, OMEGA, 1 ) - -* ------------------------------------------------------------------ -* Set CURVL = (G2 - G1)'DX, the approximate curvature along DX of -* the (augmented) Lagrangian. At first, the curvature is not scaled -* by the steplength ALFA. -* ------------------------------------------------------------------ - CURVL = GLF2 - GLF1 - TINYCL = QPCURV * TOLG - SSBFGS = CURVL .LE. ALFA*TINYCL - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1000) SSBFGS, TINYCL, CURVL - -* ------------------------------------------------------------------ -* Test if CURVL is sufficiently positive. If there are no nonlinear -* constraints, no update can be performed. -* ------------------------------------------------------------------ - IF (CURVL .LT. TINYCL) THEN - LSUMRY(1:1) = 'Modified BFGS' - IF (NCNLN .GT. 0) THEN - QMAX = ZERO - DO 200 I = 1, NCNLN - QI = CJDX2(I)*CS2(I) - CJDX1(I)*CS1(I) - QMAX = MAX( QMAX, QI ) - IF (QI .LE. ZERO) WRK1(I) = ZERO - IF (QI .GT. ZERO) WRK1(I) = QI - 200 CONTINUE - - QNORM = DNRM2 ( NCNLN, WRK1, 1 ) - - TEST = MAX( TINYCL - CURVL, ZERO ) - BETA = DDIV ( QMAX*TEST, QNORM*QNORM, OVERFL ) - IF (BETA .LT. RHOMAX .AND. .NOT. OVERFL) THEN - LSUMRY(1:1) = ' ' - BETA = TEST/(QNORM*QNORM) - DO 210 I = 1, NCNLN - QI = WRK1(I) - OMEGA(I) = BETA*QI - CURVL = CURVL + BETA*QI*QI - 210 CONTINUE - - IF (NPDBG) THEN - IMAX = IDAMAX( NCNLN, OMEGA, 1 ) - IF (INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1250) OMEGA(IMAX) - - IF (INPDBG(2) .GT. 0) - $ WRITE (NOUT, 1300) (OMEGA(I), I=1,NCNLN) - END IF - END IF - END IF - END IF - -* ------------------------------------------------------------------ -* Compute the difference in the augmented Lagrangian gradient. -* ------------------------------------------------------------------ -* Update GQ1 to include the augmented Lagrangian terms. - - IF (NCNLN .GT. 0) THEN - - DO 310 I = 1, NCNLN - WRK1(I) = - QPMUL(I) + OMEGA(I) * CS1(I) - 310 CONTINUE - CALL DGEMV ( 'T', NCNLN, N, ONE, CJAC1, NROWJ1, WRK1, 1, - $ ZERO, WRK2, 1 ) - - DO 320 I = 1, NCNLN - WRK1(I) = QPMUL(I) - OMEGA(I) * CS2(I) - 320 CONTINUE - CALL DGEMV ( 'T', NCNLN, N, ONE, CJAC2, NROWJ2, WRK1, 1, - $ ONE, WRK2, 1 ) - - CALL CMQMUL( 6, N, NZ, NFREE, NQ, UNITQ, KX, WRK2, ZY, WRK1 ) - CALL DAXPY ( N, ONE, WRK2, 1, GQ1, 1 ) - END IF - - IF (NPDBG .AND. INPDBG(1) .GT. 0) - $ WRITE (NOUT, 1100) ALFA , CURVL - - IF (CURVL .LT. TINYCL) CURVL = TINYCL - - DO 330 J = 1, N - WRK2(J) = GQ2(J) - GQ1(J) - 330 CONTINUE - - RTGTP = SQRT(QPCURV) - RTYTS = SQRT(ALFA*CURVL) - ETA = ONE - IF (SSBFGS) - $ ETA = RTYTS / (RTGTP*ALFA) - - TRACE1 = DNRM2 ( N, HPQ, 1 ) / RTGTP - TRACE2 = DNRM2 ( N, WRK2, 1 ) / (RTYTS*ETA) - RFROBN = ETA*SQRT( ABS( (RFROBN - TRACE1)*(RFROBN + TRACE1) - $ + TRACE2**2) ) - -* ================================================================== -* Update the Cholesky factor of Q'HQ. -* ================================================================== -* Normalize the vector RPQ ( = R(pq) ). - - CALL DSCAL ( N, (ONE / RTGTP), RPQ, 1 ) - -* Do the self-scaled or regular BFGS update. -* Form the vector WRK1 = gamma * (GQ2 - GQ1) - beta * R'R*PQ, -* where gamma = 1/SQRT( CURV ) = 1/SQRT( (GQ2 - GQ1)'SQ ) - - CALL DSCAL ( N, (ONE / RTGTP), HPQ, 1 ) - - IF (SSBFGS) THEN - DO 410 J = 1, N - CALL DSCAL ( J, ETA, R(1,J), 1 ) - WRK1(J) = WRK2(J)/RTYTS - ETA * HPQ(J) - 410 CONTINUE - ELSE - DO 420 J = 1, N - WRK1(J) = WRK2(J)/RTYTS - HPQ(J) - 420 CONTINUE - END IF - -* Perform the update to R = R + RPQ*WRK1'. -* RPQ is overwritten and HPQ is used as workspace. - - CALL CMR1MD( N, 0, N, NROWR, N, N, R, HPQ, RPQ, WRK1 ) - - RETURN - - 1000 FORMAT(/ ' //NPUPDT// SSBFGS min. CURVL CURVL ' - $ / ' //NPUPDT// ', L4, 1P2E14.2 ) - 1100 FORMAT(/ ' //NPUPDT// ALFA CURVL ' - $ / ' //NPUPDT//', 1P2E14.2 ) - 1250 FORMAT(/ ' //NPUPDT// OMEGA(IMAX)' - $ / ' //NPUPDT//', 1PE14.2 ) - 1300 FORMAT(/ ' //NPUPDT// Penalty parameters = ' / (1P5E15.6)) - -* End of NPUPDT. - - END
deleted file mode 100644 --- a/libcruft/npsol/opfile.f +++ /dev/null @@ -1,115 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File OPSUBS FORTRAN -* -* OPFILE OPLOOK OPNUMB OPSCAN OPTOKN OPUPPR -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE OPFILE( IOPTNS, NOUT, INFORM, OPKEY ) - INTEGER IOPTNS, NOUT, INFORM - EXTERNAL OPKEY - -************************************************************************ -* OPFILE reads the options file from unit IOPTNS and loads the -* options into the relevant elements of the integer and real -* parameter arrays. -* -* Systems Optimization Laboratory, Stanford University. -* This version dated December 18, 1985. -************************************************************************ - LOGICAL PRNT - CHARACTER*16 KEY , TOKEN(1) - CHARACTER*72 BUFFER, OLDBUF - - PRNT = .TRUE. - -* Return if the unit number is out of range. - - IF (IOPTNS .LT. 0 .OR. IOPTNS .GT. 99) THEN - INFORM = 1 - RETURN - END IF - -* ------------------------------------------------------------------ -* Look for BEGIN, ENDRUN or SKIP. -* ------------------------------------------------------------------ - NREAD = 0 - 50 READ (IOPTNS, '(A)', END = 930) BUFFER - NREAD = NREAD + 1 - NKEY = 1 - CALL OPTOKN( BUFFER, NKEY, TOKEN ) - KEY = TOKEN(1) - IF (KEY .EQ. 'ENDRUN') GO TO 940 - IF (KEY .NE. 'BEGIN' ) THEN - IF (NREAD .EQ. 1 .AND. KEY .NE. 'SKIP') THEN - WRITE (NOUT, 2000) IOPTNS, BUFFER - END IF - GO TO 50 - END IF - -* ------------------------------------------------------------------ -* BEGIN found. -* This is taken to be the first line of an OPTIONS file. -* Read the second line to see if it is NOLIST. -* ------------------------------------------------------------------ - OLDBUF = BUFFER - READ (IOPTNS, '(A)', END = 920) BUFFER - - CALL OPKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'NOLIST') THEN - PRNT = .FALSE. - END IF - - IF (PRNT) THEN - WRITE (NOUT, '(// A / A /)') - $ ' OPTIONS file', - $ ' ------------' - WRITE (NOUT, '(6X, A )') OLDBUF, BUFFER - END IF - -* ------------------------------------------------------------------ -* Read the rest of the file. -* ------------------------------------------------------------------ -*+ while (key .ne. 'end') loop - 100 IF (KEY .NE. 'END') THEN - READ (IOPTNS, '(A)', END = 920) BUFFER - IF (PRNT) - $ WRITE (NOUT, '( 6X, A )') BUFFER - - CALL OPKEY ( NOUT, BUFFER, KEY ) - - IF (KEY .EQ. 'LIST') PRNT = .TRUE. - IF (KEY .EQ. 'NOLIST') PRNT = .FALSE. - GO TO 100 - END IF -*+ end while - - INFORM = 0 - RETURN - - 920 WRITE (NOUT, 2200) IOPTNS - INFORM = 2 - RETURN - - 930 WRITE (NOUT, 2300) IOPTNS - INFORM = 3 - RETURN - - 940 WRITE (NOUT, '(// 6X, A)') BUFFER - INFORM = 4 - RETURN - - 2000 FORMAT( - $ //' XXX Error while looking for an OPTIONS file on unit', I7 - $ / ' XXX The file should start with BEGIN, SKIP or ENDRUN' - $ / ' XXX but the first record found was the following:' - $ //' ---->', A - $ //' XXX Continuing to look for OPTIONS file...') - 2200 FORMAT(//' XXX End-of-file encountered while processing', - $ ' an OPTIONS file on unit', I6) - 2300 FORMAT(//' XXX End-of-file encountered while looking for', - $ ' an OPTIONS file on unit', I6) - -* End of OPFILE. - - END
deleted file mode 100644 --- a/libcruft/npsol/oplook.f +++ /dev/null @@ -1,314 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C - SUBROUTINE OPLOOK (NDICT, DICTRY, ALPHA, KEY, ENTRY) -C -C -C Description and usage: -C -C Performs dictionary lookups. A pointer is returned if a -C match is found between the input key and the corresponding -C initial characters of one of the elements of the dictionary. -C If a "synonym" has been provided for an entry, the search is -C continued until a match to a primary dictionary entry is found. -C Cases of no match, or multiple matches, are also provided for. -C -C Dictionary entries must be left-justified, and may be alphabetized -C for faster searches. Secondary entries, if any, are composed of -C two words separated by one or more characters such as blank, tab, -C comma, colon, or equal sign which are treated as non-significant -C by OPSCAN. The first entry of each such pair serves as a synonym -C for the second, more fundamental keyword. -C -C The ordered search stops after the section of the dictionary -C having the same first letters as the key has been checked, or -C after a specified number of entries have been examined. A special -C dictionary entry, the vertical bar '|', will also terminate the -C search. This will speed things up if an appropriate dictionary -C length parameter cannot be determined. Both types of search are -C sequential. See "Notes" below for some suggestions if efficiency -C is an issue. -C -C -C Parameters: -C -C Name Dimension Type I/O/S Description -C NDICT I I Number of dictionary entries to be -C examined. -C DICTRY NDICT C I Array of dictionary entries, -C left-justified in their fields. -C May be alphabetized for efficiency, -C in which case ALPHA should be -C .TRUE. Entries with synonyms are -C of the form -C 'ENTRY : SYNONYM', where 'SYNONYM' -C is a more fundamental entry in the -C same dictionary. NOTE: Don't build -C "circular" dictionaries! -C ALPHA L I Indicates whether the dictionary -C is in alphabetical order, in which -C case the search can be terminated -C sooner. -C KEY C I/O String to be compared against the -C dictionary. Abbreviations are OK -C if they correspond to a unique -C entry in the dictionary. KEY is -C replaced on termination by its most -C fundamental equivalent dictionary -C entry (uppercase, left-justified) -C if a match was found. -C ENTRY I O Dictionary pointer. If > 0, it -C indicates which entry matched KEY. -C In case of trouble, a negative -C value means that a UNIQUE match -C was not found - the absolute value -C of ENTRY points to the second -C dictionary entry that matched KEY. -C Zero means that NO match could be -C found. ENTRY always refers to the -C last search performed - -C in searching a chain of synonyms, -C a non-positive value will be -C returned if there is any break, -C even if the original input key -C was found. -C -C -C External references: -C -C Name Description -C OPSCAN Finds first and last significant characters. -C -C -C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77). -C Appears to satisfy the ANSI Fortran 77 standard. -C -C -C Notes: -C -C (1) IMPLICIT NONE is non-standard. (Has been commented out.) -C -C (2) We have assumed that the dictionary is not too big. If -C many searches are to be done or if the dictionary has more -C than a dozen or so entries, it may be advantageous to build -C an index array of pointers to the beginning of the section -C of the dictionary containing each letter, then pass in the -C portion of the dictionary beginning with DICTRY (INDEX). -C (This won't generally work for dictionaries with synonyms.) -C For very large problems, a completely different approach may -C be advisable, e.g. a binary search for ordered dictionaries. -C -C (3) OPLOOK is case sensitive. In most applications it will be -C necessary to use an uppercase dictionary, and to convert the -C input key to uppercase before calling OPLOOK. Companion -C routines OPTOKN and PAIRS, available from the author, already -C take care of this. -C -C (4) The key need not be left-justified. Any leading (or -C trailing) characters which are "non-significant" to OPSCAN -C will be ignored. These include blanks, horizontal tabs, -C commas, colons, and equal signs. See OPSCAN for details. -C -C (5) The ASCII collating sequence for character data is assumed. -C (N.B. This means the numerals precede the alphabet, unlike -C common practice!) This should not cause trouble on EBCDIC -C machines if DICTRY just contains alphabetic keywords. -C Otherwise it may be necessary to use the FORTRAN lexical -C library routines to force use of the ASCII sequence. -C -C (6) Parameter NUMSIG sets a limit on the length of significant -C dictionary entries. Special applications may require that -C this be increased. (It is 16 in the present version.) -C -C (7) No protection against "circular" dictionaries is provided: -C don't claim that A is B, and that B is A. All synonym chains -C must terminate! Other potential errors not checked for -C include duplicate or mis-ordered entries. -C -C (8) The handling of ambiguities introduces some ambiguity: -C -C ALPHA = .TRUE. A potential problem, when one entry -C looks like an abbreviation for another -C (eg. does 'A' match 'A' or 'AB'?) was -C resolved by dropping out of the search -C immediately when an "exact" match is found. -C -C ALPHA = .FALSE. The programmer must ensure that the above -C situation does not arise: each dictionary -C entry must be recognizable, at least when -C specified to full length. Otherwise, the -C result of a search will depend on the -C order of entries. -C -C -C Author: Robert Kennelly, Informatics General Corporation. -C -C -C Development history: -C -C 24 Feb. 1984 RAK/DAS Initial design and coding. -C 25 Feb. 1984 RAK Combined the two searches by suitable -C choice of terminator FLAG. -C 28 Feb. 1984 RAK Optional synonyms in dictionary, no -C longer update KEY. -C 29 Mar. 1984 RAK Put back replacement of KEY by its -C corresponding entry. -C 21 June 1984 RAK Corrected bug in error handling for cases -C where no match was found. -C 23 Apr. 1985 RAK Introduced test for exact matches, which -C permits use of dictionary entries which -C would appear to be ambiguous (for ordered -C case). Return -I to point to the entry -C which appeared ambiguous (had been -1). -C Repaired loop termination - had to use -C equal length strings or risk quitting too -C soon when one entry is an abbreviation -C for another. Eliminated HIT, reduced -C NUMSIG to 16. -C 15 Nov. 1985 MAS Loop 20 now tests .LT. FLAG, not .LE. FLAG. -C If ALPHA is false, FLAG is now '|', not '{'. -C 26 Jan. 1986 PEG Declaration of FLAG and TARGET modified to -C conform to ANSI-77 standard. -C----------------------------------------------------------------------- - - -C Variable declarations. -C ---------------------- - -* IMPLICIT NONE - -C Parameters. - - INTEGER - $ NUMSIG - CHARACTER - $ BLANK, VBAR - PARAMETER - $ (BLANK = ' ', VBAR = '|', NUMSIG = 16) - -C Variables. - - LOGICAL - $ ALPHA - INTEGER - $ ENTRY, FIRST, I, LAST, LENGTH, MARK, NDICT -* CHARACTER -* $ DICTRY (NDICT) * (*), FLAG * (NUMSIG), -* $ KEY * (*), TARGET * (NUMSIG) - CHARACTER - $ DICTRY (NDICT) * (*), FLAG * 16, - $ KEY * (*), TARGET * 16 - -C Procedures. - - EXTERNAL - $ OPSCAN - - -C Executable statements. -C ---------------------- - - ENTRY = 0 - -C Isolate the significant portion of the input key (if any). - - FIRST = 1 - LAST = MIN( LEN(KEY), NUMSIG ) - CALL OPSCAN (KEY, FIRST, LAST, MARK) - - IF (MARK .GT. 0) THEN - TARGET = KEY (FIRST:MARK) - -C Look up TARGET in the dictionary. - - 10 CONTINUE - LENGTH = MARK - FIRST + 1 - -C Select search strategy by cunning choice of termination test -C flag. The vertical bar is just about last in both the -C ASCII and EBCDIC collating sequences. - - IF (ALPHA) THEN - FLAG = TARGET - ELSE - FLAG = VBAR - END IF - - -C Perform search. -C --------------- - - I = 0 - 20 CONTINUE - I = I + 1 - IF (TARGET (1:LENGTH) .EQ. DICTRY (I) (1:LENGTH)) THEN - IF (ENTRY .EQ. 0) THEN - -C First "hit" - must still guard against ambiguities -C by searching until we've gone beyond the key -C (ordered dictionary) or until the end-of-dictionary -C mark is reached (exhaustive search). - - ENTRY = I - -C Special handling if match is exact - terminate -C search. We thus avoid confusion if one dictionary -C entry looks like an abbreviation of another. -C This fix won't generally work for un-ordered -C dictionaries! - - FIRST = 1 - LAST = NUMSIG - CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK) - IF (MARK .EQ. LENGTH) I = NDICT - ELSE - - -C Oops - two hits! Abnormal termination. -C --------------------------------------- - - ENTRY = -I - RETURN - END IF - END IF - -C Check whether we've gone past the appropriate section of the -C dictionary. The test on the index provides insurance and an -C optional means for limiting the extent of the search. - - IF (DICTRY (I) (1:LENGTH) .LT. FLAG .AND. I .LT. NDICT) - $ GO TO 20 - - -C Check for a synonym. -C -------------------- - - IF (ENTRY .GT. 0) THEN - -C Look for a second entry "behind" the first entry. FIRST -C and MARK were determined above when the hit was detected. - - FIRST = MARK + 2 - CALL OPSCAN (DICTRY (ENTRY), FIRST, LAST, MARK) - IF (MARK .GT. 0) THEN - -C Re-set target and dictionary pointer, then repeat the -C search for the synonym instead of the original key. - - TARGET = DICTRY (ENTRY) (FIRST:MARK) - ENTRY = 0 - GO TO 10 - - END IF - END IF - - END IF - IF (ENTRY .GT. 0) KEY = DICTRY (ENTRY) - - -C Normal termination. -C ------------------- - - RETURN - -C End of OPLOOK - END
deleted file mode 100644 --- a/libcruft/npsol/opnumb.f +++ /dev/null @@ -1,102 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - FUNCTION OPNUMB( STRING ) - - LOGICAL OPNUMB - CHARACTER*(*) STRING - -************************************************************************ -* Description and usage: -* -* A simple(-minded) test for numeric data is implemented by -* searching an input string for legitimate characters: -* digits 0 to 9, D, E, -, + and . -* Insurance is provided by requiring that a numeric string -* have at least one digit, at most one D, E or . -* and at most two -s or +s. Note that a few ambiguities remain: -* -* (a) A string might have the form of numeric data but be -* intended as text. No general test can hope to detect -* such cases. -* -* (b) There is no check for correctness of the data format. -* For example a meaningless string such as 'E1.+2-' -* will be accepted as numeric. -* -* Despite these weaknesses, the method should work in the -* majority of cases. -* -* -* Parameters: -* -* Name Dimension Type I/O/S Description -* OPNUMB L O Set .TRUE. if STRING appears -* to be numerical data. -* STRING C I Input data to be tested. -* -* -* Environment: ANSI FORTRAN 77. -* -* -* Notes: -* -* (1) It is assumed that STRING is a token extracted by -* OPTOKN, which will have converted any lower-case -* characters to upper-case. -* -* (2) OPTOKN pads STRING with blanks, so that a genuine -* number is of the form '1234 '. -* Hence, the scan of STRING stops at the first blank. -* -* (3) COMPLEX data with parentheses will not look numeric. -* -* -* Systems Optimization Laboratory, Stanford University. -* 12 Nov 1985 Initial design and coding, starting from the -* routine ALPHA from Informatics General, Inc. -************************************************************************ - - LOGICAL NUMBER - INTEGER J, LENGTH, NDIGIT, NEXP, NMINUS, NPLUS, NPOINT - CHARACTER*1 ATOM - - NDIGIT = 0 - NEXP = 0 - NMINUS = 0 - NPLUS = 0 - NPOINT = 0 - NUMBER = .TRUE. - LENGTH = LEN (STRING) - J = 0 - - 10 J = J + 1 - ATOM = STRING (J:J) - IF (ATOM .GE. '0' .AND. ATOM .LE. '9') THEN - NDIGIT = NDIGIT + 1 - ELSE IF (ATOM .EQ. 'D' .OR. ATOM .EQ. 'E') THEN - NEXP = NEXP + 1 - ELSE IF (ATOM .EQ. '-') THEN - NMINUS = NMINUS + 1 - ELSE IF (ATOM .EQ. '+') THEN - NPLUS = NPLUS + 1 - ELSE IF (ATOM .EQ. '.') THEN - NPOINT = NPOINT + 1 - ELSE IF (ATOM .EQ. ' ') THEN - J = LENGTH - ELSE - NUMBER = .FALSE. - END IF - - IF (NUMBER .AND. J .LT. LENGTH) GO TO 10 - - OPNUMB = NUMBER - $ .AND. NDIGIT .GE. 1 - $ .AND. NEXP .LE. 1 - $ .AND. NMINUS .LE. 2 - $ .AND. NPLUS .LE. 2 - $ .AND. NPOINT .LE. 1 - - RETURN - -* End of OPNUMB - END
deleted file mode 100644 --- a/libcruft/npsol/opscan.f +++ /dev/null @@ -1,158 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C - SUBROUTINE OPSCAN (STRING, FIRST, LAST, MARK) -C -C -C Description and usage: -C -C Looks for non-blank fields ("tokens") in a string, where the -C fields are of arbitrary length, separated by blanks, tabs, commas, -C colons, or equal signs. The position of the end of the 1st token -C is also returned, so this routine may be conveniently used within -C a loop to process an entire line of text. -C -C The procedure examines a substring, STRING (FIRST : LAST), which -C may of course be the entire string (in which case just call OPSCAN -C with FIRST <= 1 and LAST >= LEN (STRING) ). The indices returned -C are relative to STRING itself, not the substring. -C -C -C Parameters: -C -C Name Dimension Type I/O/S Description -C STRING C I Text string containing data to be -C scanned. -C FIRST I I/O Index of beginning of substring. -C If <= 1, the search begins with 1. -C Output is index of beginning of -C first non-blank field, or 0 if no -C token was found. -C LAST I I/O Index of end of substring. -C If >= LEN (STRING), the search -C begins with LEN (STRING). Output -C is index of end of last non-blank -C field, or 0 if no token was found. -C MARK I O Points to end of first non-blank -C field in the specified substring. -C Set to 0 if no token was found. -C -C -C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77). -C ANSI Fortran 77, except for the tab character HT. -C -C Notes: -C -C (1) IMPLICIT NONE is non-standard. Constant HT (Tab) is defined -C in a non-standard way: the CHAR function is not permitted -C in a PARAMETER declaration (OK on VAX, though). For Absoft -C FORTRAN 77 on 68000 machines, use HT = 9. In other cases, it -C may be best to declare HT as a variable and assign -C HT = CHAR(9) on ASCII machines, or CHAR(5) for EBCDIC. -C -C (2) The pseudo-recursive structure was chosen for fun. It is -C equivalent to three DO loops with embedded GO TOs in sequence. -C -C (3) The variety of separators recognized limits the usefulness of -C this routine somewhat. The intent is to facilitate handling -C such tokens as keywords or numerical values. In other -C applications, it may be necessary for ALL printing characters -C to be significant. A simple modification to statement -C function SOLID will do the trick. -C -C -C Author: Robert Kennelly, Informatics General Corporation. -C -C -C Development history: -C -C 29 Dec. 1984 RAK Initial design and coding, (very) loosely -C based on SCAN_STRING by Ralph Carmichael. -C 25 Feb. 1984 RAK Added ':' and '=' to list of separators. -C 16 Apr. 1985 RAK Defined SOLID in terms of variable DUMMY -C (previous re-use of STRING was ambiguous). -C -C----------------------------------------------------------------------- - - -C Variable declarations. -C ---------------------- - -* IMPLICIT NONE - -C Parameters. - - CHARACTER - $ BLANK, EQUAL, COLON, COMMA, HT - PARAMETER - $ (BLANK = ' ', EQUAL = '=', COLON = ':', COMMA = ',') - -C Variables. - - LOGICAL - $ SOLID - INTEGER - $ BEGIN, END, FIRST, LAST, LENGTH, MARK - CHARACTER - $ DUMMY, STRING * (*) - -C Statement functions. - - SOLID (DUMMY) = (DUMMY .NE. BLANK) .AND. - $ (DUMMY .NE. COLON) .AND. - $ (DUMMY .NE. COMMA) .AND. - $ (DUMMY .NE. EQUAL) .AND. - $ (DUMMY .NE. HT) - - -C Executable statements. -C ---------------------- - -**** HT = CHAR(9) for ASCII machines, CHAR(5) for EBCDIC. - HT = CHAR(9) - MARK = 0 - LENGTH = LEN (STRING) - BEGIN = MAX (FIRST, 1) - END = MIN (LENGTH, LAST) - -C Find the first significant character ... - - DO 30 FIRST = BEGIN, END, +1 - IF (SOLID (STRING (FIRST : FIRST))) THEN - -C ... then the end of the first token ... - - DO 20 MARK = FIRST, END - 1, +1 - IF (.NOT.SOLID (STRING (MARK + 1 : MARK + 1))) THEN - -C ... and finally the last significant character. - - DO 10 LAST = END, MARK, -1 - IF (SOLID (STRING (LAST : LAST))) THEN - RETURN - END IF - 10 CONTINUE - -C Everything past the first token was a separator. - - LAST = LAST + 1 - RETURN - END IF - 20 CONTINUE - -C There was nothing past the first token. - - LAST = MARK - RETURN - END IF - 30 CONTINUE - -C Whoops - the entire substring STRING (BEGIN : END) was composed of -C separators ! - - FIRST = 0 - MARK = 0 - LAST = 0 - RETURN - -C End of OPSCAN - END
deleted file mode 100644 --- a/libcruft/npsol/optokn.f +++ /dev/null @@ -1,126 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C - SUBROUTINE OPTOKN (STRING, NUMBER, LIST) -C -C -C Description and usage: -C -C An aid to parsing input data. The individual "tokens" in a -C character string are isolated, converted to uppercase, and stored -C in an array. Here, a token is a group of significant, contiguous -C characters. The following are NON-significant, and hence may -C serve as separators: blanks, horizontal tabs, commas, colons, -C and equal signs. See OPSCAN for details. Processing continues -C until the requested number of tokens have been found or the end -C of the input string is reached. -C -C -C Parameters: -C -C Name Dimension Type I/O/S Description -C STRING C I Input string to be analyzed. -C NUMBER I I/O Number of tokens requested (input) -C and found (output). -C LIST NUMBER C O Array of tokens, changed to upper -C case. -C -C -C External references: -C -C Name Description -C OPSCAN Finds positions of first and last significant characters. -C OPUPPR Converts a string to uppercase. -C -C -C Environment: Digital VAX-11/780 VMS FORTRAN (FORTRAN 77). -C Appears to satisfy the ANSI Fortran 77 standard. -C -C -C Notes: -C -C (1) IMPLICIT NONE is non-standard. (Has been commented out.) -C -C -C Author: Robert Kennelly, Informatics General Corporation. -C -C -C Development history: -C -C 16 Jan. 1984 RAK Initial design and coding. -C 16 Mar. 1984 RAK Revised header to reflect full list of -C separators, repaired faulty WHILE clause -C in "10" loop. -C 18 Sep. 1984 RAK Change elements of LIST to uppercase one -C at a time, leaving STRING unchanged. -C -C----------------------------------------------------------------------- - - -C Variable declarations. -C ---------------------- - -* IMPLICIT NONE - -C Parameters. - - CHARACTER - $ BLANK - PARAMETER - $ (BLANK = ' ') - -C Variables. - - INTEGER - $ COUNT, FIRST, I, LAST, MARK, NUMBER - CHARACTER - $ STRING * (*), LIST (NUMBER) * (*) - -C Procedures. - - EXTERNAL - $ OPUPPR, OPSCAN - - -C Executable statements. -C ---------------------- - -C WHILE there are tokens to find, loop UNTIL enough have been found. - - FIRST = 1 - LAST = LEN (STRING) - - COUNT = 0 - 10 CONTINUE - -C Get delimiting indices of next token, if any. - - CALL OPSCAN (STRING, FIRST, LAST, MARK) - IF (LAST .GT. 0) THEN - COUNT = COUNT + 1 - -C Pass token to output string array, then change case. - - LIST (COUNT) = STRING (FIRST : MARK) - CALL OPUPPR (LIST (COUNT)) - FIRST = MARK + 2 - IF (COUNT .LT. NUMBER) GO TO 10 - - END IF - - -C Fill the rest of LIST with blanks and set NUMBER for output. - - DO 20 I = COUNT + 1, NUMBER - LIST (I) = BLANK - 20 CONTINUE - - NUMBER = COUNT - - -C Termination. -C ------------ - - RETURN - -C End of OPTOKN - END
deleted file mode 100644 --- a/libcruft/npsol/opuppr.f +++ /dev/null @@ -1,58 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C - SUBROUTINE OPUPPR(STRING) -C -C ACRONYM: UPper CASE -C -C PURPOSE: This subroutine changes all lower case letters in the -C character string to upper case. -C -C METHOD: Each character in STRING is treated in turn. The intrinsic -C function INDEX effectively allows a table lookup, with -C the local strings LOW and UPP acting as two tables. -C This method avoids the use of CHAR and ICHAR, which appear -C be different on ASCII and EBCDIC machines. -C -C ARGUMENTS -C ARG DIM TYPE I/O/S DESCRIPTION -C STRING * C I/O Character string possibly containing -C some lower-case letters on input; -C strictly upper-case letters on output -C with no change to any non-alphabetic -C characters. -C -C EXTERNAL REFERENCES: -C LEN - Returns the declared length of a CHARACTER variable. -C INDEX - Returns the position of second string within first. -C -C ENVIRONMENT: ANSI FORTRAN 77 -C -C DEVELOPMENT HISTORY: -C DATE INITIALS DESCRIPTION -C 06/28/83 CLH Initial design. -C 01/03/84 RAK Eliminated NCHAR input. -C 06/14/84 RAK Used integer PARAMETERs in comparison. -C 04/21/85 RAK Eliminated DO/END DO in favor of standard code. -C 09/10/85 MAS Eliminated CHAR,ICHAR in favor of LOW, UPP, INDEX. -C -C AUTHOR: Charles Hooper, Informatics General, Palo Alto, CA. -C -C----------------------------------------------------------------------- - - CHARACTER STRING * (*) - INTEGER I, J - CHARACTER C*1, LOW*26, UPP*26 - DATA LOW /'abcdefghijklmnopqrstuvwxyz'/, - $ UPP /'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/ - - DO 10 J = 1, LEN(STRING) - C = STRING(J:J) - IF (C .GE. 'a' .AND. C .LE. 'z') THEN - I = INDEX( LOW, C ) - IF (I .GT. 0) STRING(J:J) = UPP(I:I) - END IF - 10 CONTINUE - RETURN - -* End of OPUPPR - END
deleted file mode 100644 --- a/libcruft/npsol/srchc.f +++ /dev/null @@ -1,621 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -* File SRSUBS FORTRAN -* -* SRCHC SRCHQ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE SRCHC ( DEBUG, DONE, FIRST, IMPRVD, INFORM, - $ ALFMAX, EPSAF, ETA, - $ XTRY, FTRY, GTRY, OLDF, OLDG, - $ TOLABS, TOLREL, TOLTNY, - $ ALFA, ALFBST, FBEST, GBEST ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DEBUG , DONE , FIRST , IMPRVD - -************************************************************************ -* SRCHC is a step-length algorithm for minimizing a function of one -* variable. It will be called repeatedly by a search routine whose -* purpose is to estimate a point ALFA = ALFBST that minimizes some -* function F(alfa) over the closed interval (0, ALFMAX). -* -* SRCHC requires both the function F(alfa) and its gradient G(alfa) -* to be evaluated at various points within the interval. New step- -* length estimates are computed using cubic interpolation with -* safeguards. -* -* Reverse communication is used to allow the calling program to -* evaluate F and G. Some of the parameters must be set or tested -* by the calling program. the remainder would ordinarily be local -* variables. -* -* -* Input parameters (relevant to the calling program) -* -------------------------------------------------- -* -* DEBUG specifies whether detailed output is wanted. -* -* FIRST must be .TRUE. on the first entry. It is subsequently -* altered by SRCHC. -* -* MFSRCH is an upper limit on the number of times SRCHC is to be -* entered consecutively with DONE = .FALSE. (following -* an initial entry with FIRST = .TRUE.. -* -* ALFA is the first estimate of the step length. ALFA is -* subsequently altered by SRCHC (see below). -* -* ALFMAX is the upper limit of the interval to be searched. -* -* EPSAF is an estimate of the absolute precision in the -* computed value of F. -* -* ETA controls the accuracy of the search. It must lie -* in the range 0.0 le ETA lt 1.0. Decreasing -* ETA tends to increase the accuracy of the search. -* -* FTRY, GTRY are the values of F, G at the new point -* ALFA = ALFBST + XTRY. -* -* OLDF, OLDG are the values of F(0) and G(0). OLDG must be negative. -* -* TOLABS,TOLREL define a function TOL(ALFA) = TOLREL*ALFA + TOLABS such -* that if F has already been evaluated at step ALFA, it -* will not be evaluated closer than TOL(ALFA). These -* values may be reduced by SRCHC. -* -* TOLTNY is the smallest value that TOLABS is allowed to be -* reduced to. -* -* -* Output parameters (relevant to the calling program) -* --------------------------------------------------- -* -* IMPRVD is true if the previous step ALFA was the best point -* so far. Any related quantities should be saved by the -* calling program (e.g., gradient arrays) before paying -* attention to DONE. -* -* DONE = FALSE means the calling program should evaluate -* FTRY = F(ALFA), GTRY = G(ALFA) -* for the new trial step ALFA, and then re-enter SRCHC. -* -* DONE = TRUE means that no new steplength was calculated. The value -* of INFORM gives the result of the linesearch as follows -* -* INFORM = 1 means the search has terminated successfully -* with ALFBST less than ALFMAX. -* -* INFORM = 2 means the search has terminated successfully -* with ALFBST = ALFMAX. -* -* INFORM = 3 means that the search failed to find a point -* of sufficient decrease in MFSRCH functions, -* but an improved point was found. -* -* INFORM = 4 means ALFMAX is so small that a search -* should not have been attempted. -* -* INFORM = 5 is never set by SRCHC. -* -* INFORM = 6 means the search has failed to find a useful -* step. If the function and gradient have -* been programmed correctly, this will usually -* occur if the minimum lies very close to -* ALFA = 0 or the gradient is not sufficiently -* accurate. -* -* NFSRCH counts the number of times SRCHC has been entered -* consecutively with DONE = FALSE (i.e., with a new -* function value FTRY). -* -* ALFA is the step at which the next function FTRY and -* gradient GTRY must be computed. -* -* ALFBST should be accepted by the calling program as the -* required step-length estimate, whenever SRCHC returns -* INFORM = 1 or 2 (and possibly 3). -* -* FBEST, GBEST will be the corresponding values of F, G. -* -* -* The following parameters retain information between entries -* ----------------------------------------------------------- -* -* ALFUZZ is such that, if the final ALFA lies in the interval -* (0,ALFUZZ) and ABS( F(ALFA)-OLDF ).LE.EPSAF, ALFA -* cannot be guaranteed to be a point of sufficient -* decrease. -* -* BRAKTD is false if F and G have not been evaluated at -* the far end of the interval of uncertainty. In this -* case, the point B will be at ALFMAX + TOL(ALFMAX). -* -* CRAMPD is true if ALFMAX is very small (le TOLABS). If the -* search fails, this indicates that a zero step should be -* taken. -* -* EXTRAP is true if XW lies outside the interval of uncertainty. -* In this case, extra safeguards are applied to allow for -* instability in the polynomial fit. -* -* MOVED is true if a better point has been found (ALFBST GT 0). -* -* WSET records whether a second-best point has been determined -* It will always be true when convergence is tested. -* -* NSAMEA is the number of consecutive times that the left-hand -* end of the interval of uncertainty has remained the -* same. -* -* NSAMEB similarly for the right-hand end. -* -* A, B, ALFBST define the current interval of uncertainty. -* The required minimum lies somewhere within the -* closed interval (ALFBST + A, ALFBST + B). -* -* ALFBST is the best point so far. It is always at one end of -* the interval of uncertainty. Hence we have -* either A lt 0, B = 0 or A = 0, B gt 0. -* -* FBEST, GBEST are the values of F, G at the point ALFBST. -* -* FACTOR controls the rate at which extrapolated estimates of -* ALFA may expand into the interval of uncertainty. -* FACTOR is not used if the minimum has been bracketed -* (i.e., when the variable BRAKTD is true). -* -* FW, GW are the values of F, G at the point ALFBST + XW. -* They are not defined until WSET is true. -* -* XTRY is the trial point within the shifted interval (A, B). -* -* XW is such that ALFBST + XW is the second-best point. -* It is not defined until WSET is true. -* In some cases, XW will replace a previous XW that -* has a lower function but has just been excluded from -* the interval of uncertainty. -* -* RMU controls what is meant by a significant decrease in F. -* The final F(ALFBST) should lie on or below the line -* L(ALFA) = OLDF + ALFA*RMU*OLDG. -* RMU should be in the open interval (0, 1/2). -* The value RMU = 1.0E-4 is good for most purposes. -* -* RTMIN is used to avoid floating-point underflow. It should -* be reasonably close to the square root of the smallest -* representable positive number. -* -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version February 1982. Rev. May 1983. -* Original F77 version 22-August-1985. -* This version of SRCHC dated 29-June-1986. -************************************************************************ - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - SAVE /SOLMCH/ - COMMON /SOL1CM/ NOUT - - EXTERNAL DNORM - INTRINSIC ABS , SQRT - LOGICAL BRAKTD, CRAMPD, EXTRAP, MOVED , WSET - SAVE BRAKTD, CRAMPD, EXTRAP, MOVED , WSET - - SAVE NFSRCH, NSAMEA, NSAMEB - SAVE A , B , ALFUZZ, FACTOR, RTMIN - SAVE XW , FW , GW , TOLMAX - - LOGICAL CLOSEF, CONV1 , CONV2 , CONVRG - LOGICAL FITOK , SETXW , SIGDEC - - PARAMETER ( ZERO =0.0D+0, POINT1 =0.1D+0, HALF =0.5D+0 ) - PARAMETER ( ONE =1.0D+0, TWO =2.0D+0, THREE =3.0D+0 ) - PARAMETER ( FIVE =5.0D+0, TEN =1.0D+1, ELEVEN =1.1D+1 ) - PARAMETER ( RMU =1.0D-4, MFSRCH =15 ) - -* ------------------------------------------------------------------ -* Local variables -* =============== -* -* CLOSEF is true if the new function FTRY is within EPSAF of -* FBEST (up or down). -* -* CONVRG will be set to true if at least one of the convergence -* conditions holds at ALFBST. -* -* SIGDEC says whether FBEST represents a significant decrease in -* the function, compared to the initial value OLDF. -* --------------------------------------------------------------------- - - IMPRVD = .FALSE. - IF (FIRST) THEN -* --------------------------------------------------------------- -* First entry. Initialize various quantities, check input data -* and prepare to evaluate the function at the initial step ALFA. -* --------------------------------------------------------------- - FIRST = .FALSE. - RTMIN = WMACH(6) - - NFSRCH = 0 - ALFBST = ZERO - FBEST = OLDF - GBEST = OLDG - CRAMPD = ALFMAX .LE. TOLABS - DONE = ALFMAX .LE. TOLTNY .OR. OLDG .GE. ZERO - MOVED = .FALSE. - - IF (.NOT. DONE) THEN - BRAKTD = .FALSE. - EXTRAP = .FALSE. - WSET = .FALSE. - NSAMEA = 0 - NSAMEB = 0 - ALFUZZ = ALFMAX - IF (TWO*EPSAF .LT. - OLDG*RMU*ALFMAX) - $ ALFUZZ = - TWO*EPSAF/(RMU*OLDG) - - TOLMAX = TOLABS + TOLREL*ALFMAX - A = ZERO - B = ALFMAX + TOLMAX - FACTOR = FIVE - TOL = TOLABS - XTRY = ALFA - IF (DEBUG) - $ WRITE (NOUT, 1000) ALFMAX, OLDF , OLDG , TOLABS, - $ ALFUZZ, EPSAF, TOLREL, CRAMPD - END IF - ELSE -* --------------------------------------------------------------- -* Subsequent entries. The function has just been evaluated at -* ALFA = ALFBST + XTRY, giving FTRY and GTRY. -* --------------------------------------------------------------- - NFSRCH = NFSRCH + 1 - NSAMEA = NSAMEA + 1 - NSAMEB = NSAMEB + 1 - - IF (.NOT. BRAKTD) THEN - TOLMAX = TOLABS + TOLREL*ALFMAX - B = ALFMAX - ALFBST + TOLMAX - END IF - -* See if the new step is better. If ALFA is large enough that -* FTRY can be distinguished numerically from OLDF, the function -* is required to be sufficiently decreased. - - IF (ALFA .LE. ALFUZZ) THEN - SIGDEC = FTRY - OLDF .LE. EPSAF - ELSE - SIGDEC = FTRY - OLDF - ALFA*RMU*OLDG .LE. EPSAF - END IF - CLOSEF = ABS( FTRY - FBEST ) .LE. EPSAF - IMPRVD = ( FTRY - FBEST ) .LE. (- EPSAF) - IF (CLOSEF) IMPRVD = ABS( GTRY ) .LE. ABS( GBEST ) - IMPRVD = IMPRVD .AND. SIGDEC - - IF (DEBUG) WRITE (NOUT, 1100) - $ ALFA, FTRY, GTRY, FTRY - OLDF - ALFA*RMU*OLDG - - IF (IMPRVD) THEN - -* We seem to have an improvement. The new point becomes the -* origin and other points are shifted accordingly. - - FW = FBEST - FBEST = FTRY - GW = GBEST - GBEST = GTRY - ALFBST = ALFA - MOVED = .TRUE. - - A = A - XTRY - B = B - XTRY - XW = ZERO - XTRY - WSET = .TRUE. - EXTRAP = XW .LT. ZERO .AND. GBEST .LT. ZERO - $ .OR. XW .GT. ZERO .AND. GBEST .GT. ZERO - -* Decrease the length of the interval of uncertainty. - - IF (GTRY .LE. ZERO) THEN - A = ZERO - NSAMEA = 0 - ELSE - B = ZERO - NSAMEB = 0 - BRAKTD = .TRUE. - END IF - ELSE - -* The new function value is not better than the best point so -* far. The origin remains unchanged but the new point may -* qualify as XW. XTRY must be a new bound on the best point. - - IF (XTRY .LE. ZERO) THEN - A = XTRY - NSAMEA = 0 - ELSE - B = XTRY - NSAMEB = 0 - BRAKTD = .TRUE. - END IF - -* If XW has not been set or FTRY is better than FW, update the -* points accordingly. - - SETXW = .TRUE. - IF (WSET) - $ SETXW = FTRY .LE. FW + EPSAF .OR. .NOT. EXTRAP - - IF (SETXW) THEN - XW = XTRY - FW = FTRY - GW = GTRY - WSET = .TRUE. - EXTRAP = .FALSE. - END IF - END IF - -* --------------------------------------------------------------- -* Check the termination criteria. WSET will always be true. -* --------------------------------------------------------------- - TOL = TOLABS + TOLREL*ALFBST - - IF (ALFBST .LE. ALFUZZ) THEN - SIGDEC = FBEST - OLDF .LE. EPSAF - ELSE - SIGDEC = FBEST - OLDF - ALFBST*RMU*OLDG .LE. EPSAF - END IF - - CONV1 = (B - A) .LE. (TOL + TOL) - CONV2 = MOVED .AND. SIGDEC - $ .AND. ABS(GBEST) .LE. ETA*ABS(OLDG) - CONVRG = CONV1 .OR. CONV2 - - IF (DEBUG) WRITE (NOUT, 1200) - $ ALFBST + A, ALFBST + B, B - A, TOL, - $ NSAMEA, NSAMEB, BRAKTD, CLOSEF, - $ IMPRVD, CONV1 , CONV2 , EXTRAP, - $ ALFBST, FBEST , GBEST , FBEST - OLDF - ALFBST*RMU*OLDG, - $ ALFBST + XW, FW, GW - - IF (NFSRCH .GE. MFSRCH) THEN - DONE = .TRUE. - ELSE IF (CONVRG) THEN - IF (MOVED) THEN - DONE = .TRUE. - ELSE - -* A better point has not yet been found (the step XW is no -* better than step zero). Check that the change in F is -* consistent with an X-perturbation of TOL, the minimum -* spacing estimate. If not, the value of TOL is reduced. -* F is larger than EPSAF, the value of TOL is reduced. - - TOL = TOL/TEN - TOLABS = TOL - IF (ABS(FW - OLDF) .LE. EPSAF .OR. TOL .LE. TOLTNY) - $ DONE = .TRUE. - END IF - END IF - -* --------------------------------------------------------------- -* Proceed with the computation of a trial step length. -* The choices are... -* 1. Parabolic fit using gradients only, if the F values are -* close. -* 2. Cubic fit for a minimum, using both function and gradients. -* 3. Damped cubic or parabolic fit if the regular fit appears to -* be consistently over-estimating the distance to the minimum. -* 4. Bisection, geometric bisection, or a step of TOL if -* choices 2 or 3 are unsatisfactory. -* --------------------------------------------------------------- - IF (.NOT. DONE) THEN - XMIDPT = HALF*(A + B) - S = ZERO - Q = ZERO - - IF (CLOSEF) THEN -* --------------------------------------------------------- -* Fit a parabola to the two best gradient values. -* --------------------------------------------------------- - S = GBEST - Q = GBEST - GW - IF (DEBUG) WRITE (NOUT, 2200) - ELSE -* --------------------------------------------------------- -* Fit cubic through FBEST and FW. -* --------------------------------------------------------- - IF (DEBUG) WRITE (NOUT, 2100) - FITOK = .TRUE. - R = THREE*(FBEST - FW)/XW + GBEST + GW - ABSR = ABS( R ) - S = SQRT( ABS( GBEST ) ) * SQRT( ABS( GW ) ) - IF (S .LE. RTMIN) THEN - Q = ABSR - ELSE - -* Compute Q = the square root of R*R - GBEST*GW. -* The method avoids unnecessary underflow and overflow. - - IF ((GW .LT. ZERO .AND. GBEST .GT. ZERO) .OR. - $ (GW .GT. ZERO .AND. GBEST .LT. ZERO)) THEN - SUMSQ = ONE - IF (ABSR .LT. S) THEN - IF (ABSR .GE. S*RTMIN) SUMSQ = ONE + (ABSR/S)**2 - SCALE = S - ELSE - IF (S .GE. ABSR*RTMIN) SUMSQ = ONE + (S/ABSR)**2 - SCALE = ABSR - END IF - Q = DNORM ( SCALE, SUMSQ ) - ELSE IF (ABSR .GE. S) THEN - Q = SQRT(ABSR + S)*SQRT(ABSR - S) - ELSE - FITOK = .FALSE. - END IF - - END IF - - IF (FITOK) THEN - -* Compute the minimum of the fitted cubic. - - IF (XW .LT. ZERO) Q = - Q - S = GBEST - R - Q - Q = GBEST - GW - Q - Q - END IF - END IF - -* ------------------------------------------------------------ -* Construct an artificial interval (ARTIFA, ARTIFB) in which -* the new estimate of the step length must lie. Set a default -* value of XTRY that will be used if the polynomial fit fails. -* ------------------------------------------------------------ - ARTIFA = A - ARTIFB = B - IF (.NOT. BRAKTD) THEN - -* The minimum has not been bracketed. Set an artificial -* upper bound by expanding the interval XW by a suitable -* FACTOR. - - XTRY = - FACTOR*XW - ARTIFB = XTRY - IF (ALFBST + XTRY .LT. ALFMAX) FACTOR = FIVE*FACTOR - - ELSE IF (EXTRAP) THEN - -* The points are configured for an extrapolation. -* Set a default value of XTRY in the interval (A,B) -* that will be used if the polynomial fit is rejected. In -* the following, DTRY and DAUX denote the lengths of -* the intervals (A,B) and (0,XW) (or (XW,0), if -* appropriate). The value of XTRY is the point at which -* the exponents of DTRY and DAUX are approximately -* bisected. - - DAUX = ABS( XW ) - DTRY = B - A - IF (DAUX .GE. DTRY) THEN - XTRY = FIVE*DTRY*(POINT1 + DTRY/DAUX)/ELEVEN - ELSE - XTRY = HALF * SQRT( DAUX ) * SQRT( DTRY ) - END IF - IF (XW .GT. ZERO) XTRY = - XTRY - IF (DEBUG) WRITE (NOUT, 2400) XTRY, DAUX, DTRY - -* Reset the artificial bounds. If the point computed by -* extrapolation is rejected, XTRY will remain at the -* relevant artificial bound. - - IF (XTRY .LE. ZERO) ARTIFA = XTRY - IF (XTRY .GT. ZERO) ARTIFB = XTRY - ELSE - -* The points are configured for an interpolation. The -* default value XTRY bisects the interval of uncertainty. -* The artificial interval is just (A,B). - - XTRY = XMIDPT - IF (DEBUG) WRITE (NOUT, 2300) XTRY - IF (NSAMEA .GE. 3 .OR. NSAMEB .GE. 3) THEN - -* If the interpolation appears to be over-estimating the -* distance to the minimum, damp the interpolation step. - - FACTOR = FACTOR / FIVE - S = FACTOR * S - ELSE - FACTOR = ONE - END IF - END IF - -* ------------------------------------------------------------ -* The polynomial fits give (S/Q)*XW as the new step. -* Reject this step if it lies outside (ARTIFA, ARTIFB). -* ------------------------------------------------------------ - IF (Q .NE. ZERO) THEN - IF (Q .LT. ZERO) S = - S - IF (Q .LT. ZERO) Q = - Q - IF (S*XW .GE. Q*ARTIFA .AND. S*XW .LE. Q*ARTIFB) THEN - -* Accept the polynomial fit. - - XTRY = ZERO - IF (ABS( S*XW ) .GE. Q*TOL) XTRY = (S/Q)*XW - IF (DEBUG) WRITE (NOUT, 2500) XTRY - END IF - END IF - END IF - END IF - -* ================================================================== - - IF (.NOT. DONE) THEN - ALFA = ALFBST + XTRY - IF (BRAKTD .OR. ALFA .LT. ALFMAX - TOLMAX) THEN - -* The function must not be evaluated too close to A or B. -* (It has already been evaluated at both those points.) - - IF (XTRY .LE. A + TOL .OR. XTRY .GE. B - TOL) THEN - XTRY = TOL - IF (HALF*(A + B) .LE. ZERO) XTRY = - TOL - ALFA = ALFBST + XTRY - END IF - - ELSE - -* The step is close to or larger than ALFMAX, replace it by -* ALFMAX to force evaluation of the function at the boundary. - - BRAKTD = .TRUE. - XTRY = ALFMAX - ALFBST - ALFA = ALFMAX - - END IF - END IF - -* ------------------------------------------------------------------ -* Exit. -* ------------------------------------------------------------------ - IF (DONE) THEN - IF (MOVED) THEN - IF (CONVRG) THEN - INFORM = 1 - IF (ALFA .EQ. ALFMAX) INFORM = 2 - ELSE - INFORM = 3 - END IF - ELSE IF (OLDG .GE. ZERO .OR. ALFMAX .LT. TOLTNY) THEN - INFORM = 7 - ELSE - INFORM = 6 - IF (CRAMPD) INFORM = 4 - END IF - END IF - - - IF (DEBUG) WRITE (NOUT, 3000) - RETURN - - 1000 FORMAT(/' ALFMAX OLDF OLDG TOLABS', 1P2E22.14, 1P2E16.8 - $ /' ALFUZZ EPSAF TOLREL', 1P2E22.14,16X,1PE16.8 - $ /' CRAMPD ', L6) - 1100 FORMAT(/' ALFA FTRY GTRY CTRY ', 1P2E22.14, 1P2E16.8) - 1200 FORMAT(/' A B B - A TOL ', 1P2E22.14, 1P2E16.8 - $ /' NSAMEA NSAMEB BRAKTD CLOSEF', 2I3, 2L6 - $ /' IMPRVD CONVRG EXTRAP ', L6, 3X, 2L1, L6 - $ /' ALFBST FBEST GBEST CBEST ', 1P2E22.14, 1P2E16.8 - $ /' ALFAW FW GW ', 1P2E22.14, 1PE16.8/) - 2100 FORMAT( ' Cubic. ') - 2200 FORMAT( ' Parabola.') - 2300 FORMAT( ' Bisection. XMIDPT', 1P1E22.14) - 2400 FORMAT( ' Geo. bisection. XTRY,DAUX,DTRY', 1P3E22.14) - 2500 FORMAT( ' Polynomial fit accepted. XTRY', 1P1E22.14) - 3000 FORMAT( ' ----------------------------------------------------'/) - -* End of SRCHC . - - END
deleted file mode 100644 --- a/libcruft/npsol/srchq.f +++ /dev/null @@ -1,669 +0,0 @@ -*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - - SUBROUTINE SRCHQ ( DEBUG, DONE, FIRST, IMPRVD, INFORM, - $ ALFMAX, ALFSML, EPSAF, ETA, - $ XTRY, FTRY, OLDF, OLDG, - $ TOLABS, TOLREL, TOLTNY, - $ ALFA, ALFBST, FBEST ) - - IMPLICIT DOUBLE PRECISION(A-H,O-Z) - LOGICAL DEBUG , DONE , FIRST , IMPRVD - -************************************************************************ -* SRCHQ is a step-length algorithm for minimizing a function of one -* variable. It will be called repeatedly by a search routine whose -* purpose is to estimate a point ALFA = ALFBST that minimizes some -* function F(ALFA) over the closed interval (0, ALFMAX). -* -* SRCHQ requires the function F(ALFA) (but not its gradient) to be -* evaluated at various points within the interval. New steplength -* estimates are computed using quadratic interpolation with safeguards. -* -* Reverse communication is used to allow the calling program to -* evaluate F. Some of the parameters must be set or tested by the -* calling program. The remainder would ordinarily be local variables. -* -* -* Input parameters (relevant to the calling program) -* -------------------------------------------------- -* -* DEBUG specifies whether detailed output is wanted. -* -* FIRST must be .TRUE. on the first entry. It is subsequently -* altered by SRCHQ. -* -* MFSRCH is an upper limit on the number of times SRCHQ is to be -* entered consecutively with DONE = .FALSE. (following -* an initial entry with FIRST = .TRUE.). -* -* ALFA is the first estimate of the steplength. ALFA is -* subsequently altered by SRCHQ (see below). -* -* ALFMAX is the upper limit of the interval to be searched. -* -* ALFSML is intended to prevent inefficiency when the optimum -* step is very small, for cases where the calling program -* would prefer to re-define F(ALFA). ALFSML is allowed -* to be zero. Early termination will occur if SRCHQ -* determines that the optimum step lies somewhere in the -* interval (0, ALFSML) (but not if ALFMAX .LE. ALFSML). -* -* EPSAF is an estimate of the absolute precision in the -* computed value of F. -* -* ETA controls the accuracy of the search. It must lie -* in the range 0 .LE. ETA .LT. 1. Decreasing ETA tends -* to increase the accuracy of the search. -* -* FTRY the value of F at the new point ALFA = ALFBST + XTRY. -* -* OLDF, OLDG are the values of F(0) and G(0). OLDG must be negative. -* -* TOLABS,TOLREL define a function TOL(ALFA) = TOLREL*ALFA + TOLABS -* such that if F has already been evaluated at step ALFA, -* then it will not be evaluated at any point closer than -* TOL(ALFA). These values may be reduced by SRCHQ if -* they seem to be too large. -* -* TOLTNY is the smallest value that TOLABS is allowed to be -* reduced to. -* -* -* Output parameters (relevant to the calling program) -* --------------------------------------------------- -* -* IMPRVD is true if the previous step ALFA was the best point -* so far. Any related quantities should be saved by the -* calling program (e.g., arrays) before paying attention -* to DONE. -* -* DONE = FALSE means the calling program should evaluate FTRY for the -* new trial step ALFA, and then re-enter SRCHQ. -* -* DONE = TRUE means that no new steplength was calculated. The value -* of INFORM gives the result of the linesearch as follows -* -* INFORM = 1 means the search has terminated successfully -* with ALFBST less than ALFMAX. -* -* INFORM = 2 means the search has terminated successfully -* with ALFBST = ALFMAX. -* -* INFORM = 3 means that the search failed to find a point -* of sufficient decrease in MFSRCH functions, -* but an improved point was found. -* -* INFORM = 4 means ALFMAX is so small that a search -* should not have been attempted. -* -* INFORM = 5 means that the search was terminated because -* of ALFSML (see above). -* -* INFORM = 6 means the search has failed to find a useful -* step. If the function has been programmed -* correctly, this will usually occur if the -* minimum lies very close to ALFA = 0. -* -* NFSRCH counts the number of times SRCHQ has been entered -* consecutively with DONE = FALSE (i.e., with a new -* function value FTRY). -* -* ALFA is the step at which the next function FTRY must be -* computed. -* -* ALFBST should be accepted by the calling program as the -* required steplength estimate, whenever SRCHQ returns -* INFORM = 1, 2 or 3. -* -* FBEST will be the corresponding value of F. -* -* -* The following parameters retain information between entries -* ----------------------------------------------------------- -* -* ALFUZZ is such that, if the final ALFA lies in the interval -* (0,ALFUZZ) and ABS( F(ALFA)-OLDF ) .LE. EPSAF, ALFA -* cannot be guaranteed to be a point of sufficient -* decrease. -* -* BRAKTD is false if F has not been evaluated at the far end -* of the interval of uncertainty. In this case, the -* point B will be at ALFMAX + TOL(ALFMAX). -* -* CRAMPD is true if ALFMAX is very small (.LE. TOLABS). If the -* search fails, this indicates that a zero step should -* be taken. -* -* EXTRAP is true if ALFBST has moved at least once and XV lies -* outside the interval of uncertainty. In this case, -* extra safeguards are applied to allow for instability -* in the polynomial fit. -* -* MOVED is true if a better point has been found (ALFBST GT 0). -* -* VSET records whether a third-best point has been defined. -* -* WSET records whether a second-best point has been defined. -* It will always be true by the time the convergence -* test is applied. -* -* NSAMEA is the number of consecutive times that the left-hand -* end of the interval of uncertainty has remained the -* same. -* -* NSAMEB similarly for the right-hand end. -* -* A, B, ALFBST define the current interval of uncertainty. -* The required minimum lies somewhere within the -* closed interval (ALFBST + A, ALFBST + B). -* -* ALFBST is the best point so far. it is strictly within the -* the interval of uncertainty except when it lies at the -* left-hand end when ALFBST has not been moved. -* Hence we have A .LE. 0 and B .GT. 0. -* -* FBEST is the value of F at the point ALFBST. -* -* FA is the value of F at the point ALFBST + A. -* -* FACTOR controls the rate at which extrapolated estimates of -* ALFA may expand into the interval of uncertainty. -* FACTOR is not used if the minimum has been bracketed -* (i.e., when the variable BRAKTD is true). -* -* FV, FW are the values of F at the points ALFBST + XV, -* ALFBST + XW. They are not defined until VSET or WSET -* are true. -* -* XTRY is the trial point within the shifted interval (A, B). -* The new trial function value must be computed at the -* point ALFA = ALFBST + XTRY. -* -* XV is such that ALFBST + XV is the third-best point. It is -* not defined until VSET is true. -* -* XW is such that ALFBST + XW is the second-best point. It -* is not defined until WSET is true. In some cases, XW -* will replace a previous XW that has a lower function -* but has just been excluded from (A,B). -* -* RMU controls what is meant by a significant decrease in F. -* The final F(ALFBST) should lie on or below the line -* L(ALFA) = OLDF + ALFA*RMU*OLDG. -* RMU should be in the open interval (0, 1/2). -* The value RMU = 1.0E-4 is good for most purposes. -* -* -* Systems Optimization Laboratory, Stanford University, California. -* Original version February 1982. Rev. May 1983. -* Original F77 version 22-August-1985. -* This version of SRCHQ dated 30-July-1986. -************************************************************************ - COMMON /SOL1CM/ NOUT - - LOGICAL BRAKTD, CRAMPD, EXTRAP, MOVED , VSET , WSET - SAVE BRAKTD, CRAMPD, EXTRAP, MOVED , VSET , WSET - - SAVE NFSRCH, NSAMEA, NSAMEB - SAVE A , B , FA , ALFUZZ, FACTOR - SAVE XW , FW , XV , FV , TOLMAX - - LOGICAL CLOSEF, CONV1 , CONV2 , CONV3 , CONVRG - LOGICAL SETXV , SIGDEC, XINXW - INTRINSIC ABS , SQRT - - PARAMETER ( ZERO =0.0D+0, POINT1 =0.1D+0, HALF =0.5D+0 ) - PARAMETER ( ONE =1.0D+0, TWO =2.0D+0, FIVE =5.0D+0 ) - PARAMETER ( TEN =1.0D+1, ELEVEN =1.1D+1 ) - PARAMETER ( RMU =1.0D-4, MFSRCH =15 ) - -* ------------------------------------------------------------------ -* Local variables -* =============== -* -* CLOSEF is true if the worst function FV is within EPSAF of -* FBEST (up or down). -* -* CONVRG will be set to true if at least one of the convergence -* conditions holds at ALFBST. -* -* SIGDEC says whether FBEST represents a significant decrease -* in the function, compared to the initial value OLDF. -* -* XINXW is true if XTRY is in (XW,0) or (0,XW). -* ------------------------------------------------------------------ - - IMPRVD = .FALSE. - IF (FIRST) THEN -* --------------------------------------------------------------- -* First entry. Initialize various quantities, check input data -* and prepare to evaluate the function at the initial step ALFA. -* --------------------------------------------------------------- - FIRST = .FALSE. - NFSRCH = 0 - ALFBST = ZERO - FBEST = OLDF - CRAMPD = ALFMAX .LE. TOLABS - DONE = ALFMAX .LE. TOLTNY .OR. OLDG .GE. ZERO - MOVED = .FALSE. - - IF (.NOT. DONE) THEN - BRAKTD = .FALSE. - CRAMPD = ALFMAX .LE. TOLABS - EXTRAP = .FALSE. - VSET = .FALSE. - WSET = .FALSE. - NSAMEA = 0 - NSAMEB = 0 - ALFUZZ = ALFMAX - IF (TWO*EPSAF .LT. - OLDG*RMU*ALFMAX) - $ ALFUZZ = - TWO*EPSAF/(RMU*OLDG) - - TOLMAX = TOLREL*ALFMAX + TOLABS - A = ZERO - B = ALFMAX + TOLMAX - FA = OLDF - FACTOR = FIVE - TOL = TOLABS - XTRY = ALFA - IF (DEBUG) - $ WRITE (NOUT, 1000) ALFMAX, OLDF , OLDG , TOLABS, - $ ALFUZZ, EPSAF, TOLREL, - $ CRAMPD - END IF - ELSE -* --------------------------------------------------------------- -* Subsequent entries. The function has just been evaluated at -* ALFA = ALFBST + XTRY, giving FTRY. -* --------------------------------------------------------------- - NFSRCH = NFSRCH + 1 - NSAMEA = NSAMEA + 1 - NSAMEB = NSAMEB + 1 - - IF (.NOT. BRAKTD) THEN - TOLMAX = TOLABS + TOLREL*ALFMAX - B = ALFMAX - ALFBST + TOLMAX - END IF - -* Check if XTRY is in the interval (XW,0) or (0,XW). - - XINXW = .FALSE. - IF (WSET) XINXW = ZERO .LT. XTRY .AND. XTRY .LE. XW - $ .OR. XW .LE. XTRY .AND. XTRY .LT. ZERO - -* See if the new step is better. - - IF (ALFA .LE. ALFUZZ) THEN - SIGDEC = FTRY - OLDF .LE. (- EPSAF) - ELSE - SIGDEC = FTRY - OLDF - ALFA*RMU*OLDG .LE. EPSAF - END IF - IMPRVD = SIGDEC .AND. (FTRY .LE. FBEST - EPSAF) - - IF (DEBUG) WRITE (NOUT, 1100) - $ ALFA, FTRY, FTRY - OLDF - ALFA*RMU*OLDG - - IF (IMPRVD) THEN - -* We seem to have an improvement. The new point becomes the -* origin and other points are shifted accordingly. - - IF (WSET) THEN - XV = XW - XTRY - FV = FW - VSET = .TRUE. - END IF - - XW = ZERO - XTRY - FW = FBEST - WSET = .TRUE. - FBEST = FTRY - ALFBST = ALFA - MOVED = .TRUE. - - A = A - XTRY - B = B - XTRY - EXTRAP = .NOT. XINXW - -* Decrease the length of (A,B). - - IF (XTRY .GE. ZERO) THEN - A = XW - FA = FW - NSAMEA = 0 - ELSE - B = XW - NSAMEB = 0 - BRAKTD = .TRUE. - END IF - ELSE - -* The new function value is no better than the current best -* point. XTRY must an end point of the new (A,B). - - IF (XTRY .LT. ZERO) THEN - A = XTRY - FA = FTRY - NSAMEA = 0 - ELSE - B = XTRY - NSAMEB = 0 - BRAKTD = .TRUE. - END IF - -* The origin remains unchanged but XTRY may qualify as XW. - - IF (WSET) THEN - IF (FTRY .LE. FW + EPSAF) THEN - XV = XW - FV = FW - VSET = .TRUE. - - XW = XTRY - FW = FTRY - IF (MOVED) EXTRAP = XINXW - ELSE IF (MOVED) THEN - SETXV = .TRUE. - IF (VSET) - $ SETXV = FTRY .LE. FV + EPSAF .OR. .NOT. EXTRAP - - IF (SETXV) THEN - IF (VSET .AND. XINXW) THEN - XW = XV - FW = FV - END IF - XV = XTRY - FV = FTRY - VSET = .TRUE. - END IF - ELSE - XW = XTRY - FW = FTRY - END IF - ELSE - XW = XTRY - FW = FTRY - WSET = .TRUE. - END IF - END IF - -* --------------------------------------------------------------- -* Check the termination criteria. -* --------------------------------------------------------------- - TOL = TOLABS + TOLREL*ALFBST - - IF (ALFBST .LE. ALFUZZ) THEN - SIGDEC = FBEST - OLDF .LE. (- EPSAF) - ELSE - SIGDEC = FBEST - OLDF - ALFBST*RMU*OLDG .LE. EPSAF - END IF - CLOSEF = .FALSE. - IF (VSET) CLOSEF = ABS( FBEST - FV ) .LE. EPSAF - - CONV1 = MAX( ABS( A ), B ) .LE. (TOL + TOL) - CONV2 = MOVED .AND. SIGDEC - $ .AND. ABS( FA - FBEST ) .LE. A*ETA*OLDG - CONV3 = CLOSEF .AND. (SIGDEC .OR. - $ (.NOT. MOVED) .AND. (B .LE. ALFUZZ)) - CONVRG = CONV1 .OR. CONV2 .OR. CONV3 - - IF (DEBUG) THEN - WRITE (NOUT, 1200) ALFBST + A, ALFBST + B, B - A, TOL, - $ NSAMEA, NSAMEB, BRAKTD, CLOSEF, - $ IMPRVD, CONV1, CONV2, CONV3, EXTRAP, - $ ALFBST, FBEST, FBEST - OLDF - ALFBST*RMU*OLDG, - $ ALFBST + XW, FW - IF (VSET) - $ WRITE (NOUT, 1300) ALFBST + XV, FV - END IF - - IF (NFSRCH .GE. MFSRCH .OR. ALFBST + B .LE. ALFSML) THEN - DONE = .TRUE. - ELSE IF (CONVRG) THEN - IF (MOVED) THEN - DONE = .TRUE. - ELSE - -* A better point has not yet been found (the step XW is no -* better than step zero). Check that the change in F is -* consistent with an X-perturbation of TOL, the minimum -* spacing estimate. If not, the value of TOL is reduced. - - TOL = TOL/TEN - TOLABS = TOL - IF (ABS(FW - OLDF) .LE. EPSAF .OR. TOL .LE. TOLTNY) - $ DONE = .TRUE. - END IF - END IF - -* --------------------------------------------------------------- -* Proceed with the computation of a trial step length. -* The choices are... -* 1. Parabolic fit using function values only. -* 2. Damped parabolic fit if the regular fit appears to be -* consistently over-estimating the distance to the minimum. -* 3. Bisection, geometric bisection, or a step of TOL if the -* parabolic fit is unsatisfactory. -* --------------------------------------------------------------- - XMIDPT = HALF*(A + B) - S = ZERO - Q = ZERO - -* =============================================================== -* Fit a parabola. -* =============================================================== -* Check if there are two or three points for the parabolic fit. - - GW = (FW - FBEST)/XW - IF (VSET .AND. MOVED) THEN - -* Three points available. Use FBEST, FW and FV. - - GV = (FV - FBEST)/XV - S = GV - (XV/XW)*GW - Q = TWO*(GV - GW) - IF (DEBUG) WRITE (NOUT, 2200) - ELSE - -* Only two points available. Use FBEST, FW and OLDG. - - IF (MOVED) THEN - S = OLDG - TWO*GW - ELSE - S = OLDG - END IF - Q = TWO*(OLDG - GW) - IF (DEBUG) WRITE (NOUT, 2100) - END IF - -* --------------------------------------------------------------- -* Construct an artificial interval (ARTIFA, ARTIFB) in which the -* new estimate of the steplength must lie. Set a default value -* of XTRY that will be used if the polynomial fit is rejected. -* In the following, the interval (A,B) is considered the sum of -* two intervals of lengths DTRY and DAUX, with common end point -* the best point (zero). DTRY is the length of the interval into -* which the default XTRY will be placed and ENDPNT denotes its -* non-zero end point. The magnitude of XTRY is computed so that -* the exponents of DTRY and DAUX are approximately bisected. -* --------------------------------------------------------------- - ARTIFA = A - ARTIFB = B - IF (.NOT. BRAKTD) THEN - -* The minimum has not been bracketed. Set an artificial upper -* bound by expanding the interval XW by a suitable factor. - - XTRY = - FACTOR*XW - ARTIFB = XTRY - IF (ALFBST + XTRY .LT. ALFMAX) FACTOR = FIVE*FACTOR - ELSE IF (VSET .AND. MOVED) THEN - -* Three points exist in the interval of uncertainty. -* Check if the points are configured for an extrapolation -* or an interpolation. - - IF (EXTRAP) THEN - -* The points are configured for an extrapolation. - - IF (XW .LT. ZERO) ENDPNT = B - IF (XW .GT. ZERO) ENDPNT = A - ELSE - -* If the interpolation appears to be over-estimating the -* distance to the minimum, damp the interpolation step. - - IF (NSAMEA .GE. 3 .OR. NSAMEB .GE. 3) THEN - FACTOR = FACTOR / FIVE - S = FACTOR * S - ELSE - FACTOR = ONE - END IF - -* The points are configured for an interpolation. The -* artificial interval will be just (A,B). Set ENDPNT so -* that XTRY lies in the larger of the intervals (A,B) and -* (0,B). - - ENDPNT = A - IF (XMIDPT .GT. ZERO) ENDPNT = B - -* If a bound has remained the same for three iterations, -* set ENDPNT so that XTRY is likely to replace the -* offending bound. - - IF (NSAMEA .GE. 3) ENDPNT = A - IF (NSAMEB .GE. 3) ENDPNT = B - END IF - -* Compute the default value of XTRY. - - DTRY = ABS( ENDPNT ) - DAUX = B - A - DTRY - IF (DAUX .GE. DTRY) THEN - XTRY = FIVE*DTRY*(POINT1 + DTRY/DAUX)/ELEVEN - ELSE - XTRY = HALF*SQRT( DAUX )*SQRT( DTRY ) - END IF - IF (ENDPNT .LT. ZERO) XTRY = - XTRY - IF (DEBUG) WRITE (NOUT, 2500) XTRY, DAUX, DTRY - -* If the points are configured for an extrapolation set the -* artificial bounds so that the artificial interval lies -* within (A,B). If the polynomial fit is rejected, XTRY will -* remain at the relevant artificial bound. - - IF (EXTRAP) THEN - IF (XTRY .LE. ZERO) THEN - ARTIFA = XTRY - ELSE - ARTIFB = XTRY - END IF - END IF - ELSE - -* The gradient at the origin is being used for the polynomial -* fit. Set the default XTRY to one tenth XW. - - XTRY = XW/TEN - IF (EXTRAP) XTRY = - XW - IF (DEBUG) WRITE (NOUT, 2400) XTRY - END IF - -* --------------------------------------------------------------- -* The polynomial fits give (S/Q)*XW as the new step. Reject this -* step if it lies outside (ARTIFA, ARTIFB). -* --------------------------------------------------------------- - IF (Q .NE. ZERO) THEN - IF (Q .LT. ZERO) S = - S - IF (Q .LT. ZERO) Q = - Q - IF (S*XW .GE. Q*ARTIFA .AND. S*XW .LE. Q*ARTIFB) THEN - -* Accept the polynomial fit. - - XTRY = ZERO - IF (ABS( S*XW ) .GE. Q*TOL) XTRY = (S/Q)*XW - IF (DEBUG) WRITE (NOUT, 2600) XTRY - END IF - END IF - END IF - -* ================================================================== - - IF (.NOT. DONE) THEN - ALFA = ALFBST + XTRY - IF (BRAKTD .OR. ALFA .LT. ALFMAX - TOLMAX) THEN - -* The function must not be evaluated too close to A or B. -* (It has already been evaluated at both those points.) - - XMIDPT = HALF*(A + B) - IF (XTRY .LE. A + TOL .OR. XTRY .GE. B - TOL) THEN - XTRY = TOL - IF (XMIDPT .LE. ZERO) XTRY = - TOL - END IF - - IF (ABS( XTRY ) .LT. TOL) THEN - XTRY = TOL - IF (XMIDPT .LE. ZERO) XTRY = - TOL - END IF - ALFA = ALFBST + XTRY - ELSE - -* The step is close to or larger than ALFMAX, replace it by -* ALFMAX to force evaluation of the function at the boundary. - - BRAKTD = .TRUE. - XTRY = ALFMAX - ALFBST - ALFA = ALFMAX - END IF - END IF - -* ------------------------------------------------------------------ -* Exit. -* ------------------------------------------------------------------ - IF (DONE) THEN - IF (MOVED) THEN - IF (CONVRG) THEN - INFORM = 1 - IF (ALFA .EQ. ALFMAX) INFORM = 2 - ELSE IF (ALFBST + B .LT. ALFSML) THEN - INFORM = 5 - ELSE - INFORM = 3 - END IF - ELSE IF (OLDG .GE. ZERO .OR. ALFMAX .LT. TOLTNY) THEN - INFORM = 7 - ELSE IF (CRAMPD) THEN - INFORM = 4 - ELSE IF (ALFBST + B .LT. ALFSML) THEN - INFORM = 5 - ELSE - INFORM = 6 - END IF - END IF - - IF (DEBUG) WRITE (NOUT, 3000) - RETURN - - 1000 FORMAT(/' ALFMAX OLDF OLDG TOLABS', 1P2E22.14, 1P2E16.8 - $ /' ALFUZZ EPSAF TOLREL', 1P2E22.14,16X,1PE16.8 - $ /' CRAMPD ', L6) - 1100 FORMAT(/' ALFA FTRY CTRY ', 1P2E22.14, 1P1E16.8) - 1200 FORMAT(/' A B B - A TOL ', 1P2E22.14, 1P2E16.8 - $ /' NSAMEA NSAMEB BRAKTD CLOSEF', 2I3, 2L6 - $ /' IMPRVD CONVRG EXTRAP ', L6, 3X, 3L1, L6 - $ /' ALFBST FBEST CBEST ', 1P2E22.14, 1P1E16.8 - $ /' ALFAW FW ', 1P2E22.14) - 1300 FORMAT( ' ALFAV FV ', 1P2E22.14 /) - 2100 FORMAT( ' Parabolic fit, two points. ') - 2200 FORMAT( ' Parabolic fit, three points. ') - 2400 FORMAT( ' Exponent reduced. Trial point', 1P1E22.14) - 2500 FORMAT( ' Geo. bisection. XTRY,DAUX,DTRY', 1P3E22.14) - 2600 FORMAT( ' Polynomial fit accepted. XTRY', 1P1E22.14) - 3000 FORMAT( ' ----------------------------------------------------'/) - -* End of SRCHQ . - - END
deleted file mode 100644 --- a/libcruft/qpsol/Makefile.in +++ /dev/null @@ -1,19 +0,0 @@ -# -# Makefile for octave's libcruft/qpsol directory -# -# John W. Eaton -# jwe@bevo.che.wisc.edu -# University of Wisconsin-Madison -# Department of Chemical Engineering - -TOPDIR = ../.. - -srcdir = @srcdir@ -top_srcdir = @top_srcdir@ -VPATH = @srcdir@ - -EXTERNAL_DISTFILES = Makefile.in README.MISSING - -include $(TOPDIR)/Makeconf - -include ../Makerules
deleted file mode 100644 --- a/libcruft/qpsol/README.MISSING +++ /dev/null @@ -1,18 +0,0 @@ -If it were freely redistributable, the source for Gill and Murray's -quadratic programming solver QPSOL would be in this directory. - -Unfortunately, if you want octave to use QPSOL to solve quadratic -programs, you must get the source from the Stanford Office of -Technology Licensing: - - Stanford University - Office of Technology Licensing - 857 Serra Street - Stanford CA 94305-7295 - USA - - Tel: (415) 723-0651 - Fax: (415) 725-7295 - -As of April, 1992, the license fee for QPSOL was $3600 for commercial -sites and $400 for academic and US Government sites.
deleted file mode 100644 --- a/libcruft/qpsol/addcon.f +++ /dev/null @@ -1,372 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C FILE CMSUBS66 FORTRAN -C -C ADDCON ALLOC BDPERT BNDALF CHKDAT DELCON -C FINDP GETLAM PRTSOL RSOLVE TQADD TSOLVE ZYPROD -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE ADDCON( MODFYG, MODFYR, ORTHOG, UNITQ, INFORM, - * IFIX, IADD, JADD, NACTIV, NCOLR, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, KFREE, - * CONDMX, CSLAST, SNLAST, - * A, QTG, RT, ZY, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL MODFYG, MODFYR, ORTHOG, UNITQ - INTEGER INFORM, IFIX, IADD, JADD, NACTIV, NCOLR, - * NCOLZ, NFREE, N, NQ, NROWA, NROWRT, NCOLRT - INTEGER KFREE(N) - DOUBLE PRECISION CONDMX, CSLAST, SNLAST - DOUBLE PRECISION A(NROWA,N), QTG(N), RT(NROWRT,NCOLRT), - * ZY(NQ,NQ), WRK1(N), WRK2(N) -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION ASIZE, DTMAX, DTMIN - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C -C ********************************************************************* -C ADDCON UPDATES THE FACTORIZATION OF THE MATRIX OF -C CONSTRAINTS IN THE WORKING SET, A(FREE) * (Z Y) = (0 T). -C IF THE LOGICAL VARIABLE MODFYR IS TRUE, THE CHOLESKY FACTORIZATION -C OF THE PROJECTED HESSIAN, R(T)*R, IS UPDATED ALSO. -C -C THERE ARE THREE SEPARATE CASES TO CONSIDER (ALTHOUGH EACH CASE -C SHARES CODE WITH ANOTHER)... -C -C (1) A FREE VARIABLE BECOMES FIXED ON ONE OF ITS BOUNDS WHEN THERE -C ARE ALREADY SOME GENERAL CONSTRAINTS IN THE WORKING SET. -C -C (2) A FREE VARIABLE BECOMES FIXED ON ONE OF ITS BOUNDS WHEN THERE -C ARE ONLY BOUND CONSTRAINTS IN THE WORKING SET. -C -C (3) A GENERAL CONSTRAINT (CORRESPONDING TO ROW IADD OF A) IS -C ADDED TO THE WORKING SET. -C -C IN CASES (1) AND (2), WE ASSUME THAT KFREE(IFIX) = JADD. -C IN ALL CASES, JADD IS THE INDEX OF THE CONSTRAINT BEING ADDED. -C -C IF THERE ARE NO GENERAL CONSTRAINTS IN THE WORKING SET, THE -C MATRIX Q = (Z Y) IS THE IDENTITY AND WILL NOT BE TOUCHED. -C -C IF MODFYR IS TRUE AND NCOLZ IS GREATER THAN ONE ON ENTRY, -C CSLAST AND SNLAST CONTAIN THE LAST OF THE SEQUENCE OF GIVENS -C ROTATIONS USED TO REDUCE THE INTERMEDIATE UPPER-HESSENBERG MATRIX -C TO UPPER-TRIANGULAR FORM. THESE ELEMENTS ARE NEEDED BY QPCORE. -C -C IF MODFYG IS TRUE ON ENTRY, THE COLUMN TRANSFORMATIONS ARE -C APPLIED TO THE VECTOR Q(T)GRAD, STORED IN QTG. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF JANUARY 1982. REV. OCT. 1982. MARCH 1983. -C MARCH 1983. HOUSEHOLDER REFLECTION USED TO ADD GENERAL CONSTRAINT. -C APRIL 1983. ELIMINATIONS ADDED AS AN OPTION. -C ********************************************************************* -C - INTEGER I, INCT, ISWAP, ITRANS, J, K, KP1, LDIAG, LENQ, - * LENRT, LROWA, LROWR, NACT1, NCOLZ1, NELM,NFREE1 - DOUBLE PRECISION BETA, COND, CONDBD, CS, D, DELTA, DTNEW, - * EPSMCH, ONE, POINT9, SN, TDTMAX, TDTMIN, - * ZERO - DOUBLE PRECISION DOT, QUOTNT, V2NORM - DOUBLE PRECISION DMAX1, DMIN1 - DATA ZERO , POINT9, ONE - * /0.0D+0, 0.9D+0, 1.0D+0/ -C - EPSMCH = WMACH(3) -C -C IF THE CONDITION ESTIMATOR OF THE UPDATED FACTORS IS GREATER THAN -C CONDBD, A WARNING MESSAGE IS PRINTED. -C - CONDBD = EPSMCH**(- POINT9) - LENQ = NQ *(NQ - 1) + 1 - LROWA = NROWA*(N - 1) + 1 - NCOLZ1 = NCOLZ - 1 - IF (JADD .GT. N) GO TO 200 -C -C --------------------------------------------------------------------- -C A SIMPLE BOUND HAS ENTERED THE WORKING SET. IADD IS NOT USED. -C --------------------------------------------------------------------- - IF (MSG .GE. 80) - *WRITE (NOUT, 1010) NACTIV, NCOLZ, NFREE, IFIX, JADD, UNITQ -C -C SET WRK1 = APPROPRIATE ROW OF Q. -C REORDER THE ELEMENTS OF KFREE (THIS REQUIRES REORDERING THE -C CORRESPONDING ROWS OF Q). -C - NFREE1 = NFREE - 1 - NACT1 = NACTIV - IF (UNITQ) GO TO 120 -C -C Q IS STORED EXPLICITLY. INTERCHANGE COMPONENTS IFIX AND NFREE -C OF KFREE AND SWAP THE CORRESPONDING ROWS OF Q. -C - CALL COPYVC( NFREE, ZY(IFIX,1), LENQ, NQ, WRK1, N, 1 ) - IF (IFIX .EQ. NFREE) GO TO 400 - KFREE(IFIX) = KFREE(NFREE) - CALL COPYVC( NFREE, ZY(NFREE,1), LENQ, NQ, ZY(IFIX,1), LENQ, NQ ) - GO TO 400 -C -C Q IS NOT STORED, BUT KFREE DEFINES AN ORDERING OF THE COLUMNS -C OF THE IDENTITY MATRIX THAT IMPLICITLY DEFINE Z. -C REORDER KFREE SO THAT VARIABLES IFIX+1,...,NFREE ARE MOVED ONE -C POSITION TO THE LEFT. -C - 120 CALL ZEROVC( NFREE, WRK1, N, 1 ) - WRK1(IFIX) = ONE - IF (IFIX .EQ. NFREE) GO TO 400 - DO 130 I = IFIX, NFREE1 - KFREE(I) = KFREE(I+1) - 130 CONTINUE - GO TO 400 -C -C --------------------------------------------------------------------- -C A GENERAL CONSTRAINT HAS ENTERED THE WORKING SET. IFIX IS NOT USED. -C --------------------------------------------------------------------- - 200 IF (MSG .GE. 80) - *WRITE (NOUT, 1020) NACTIV, NCOLZ, NFREE, IADD, JADD, UNITQ -C - NACT1 = NACTIV + 1 -C -C TRANSFORM THE INCOMING ROW OF A BY Q(T). -C - CALL COPYVC( N, A(IADD,1), LROWA, NROWA, WRK1, N, 1 ) - CALL ZYPROD( 8, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KFREE, KFREE, WRK1, ZY, WRK2 ) -C - IF (.NOT. UNITQ) GO TO 250 -C -C THIS IS THE FIRST GENERAL CONSTRAINT TO BE ADDED -- SET Q = I. -C - DO 220 J = 1, NFREE - CALL ZEROVC( NFREE, ZY(1,J), NFREE, 1 ) - ZY(J,J) = ONE - 220 CONTINUE - UNITQ = .FALSE. -C -C CHECK THAT THE INCOMING ROW IS NOT DEPENDENT UPON THOSE -C ALREADY IN THE WORKING SET. -C - 250 DTNEW = V2NORM( NCOLZ, WRK1, NCOLZ, 1 ) - IF (NACT1 .GT. 1) GO TO 300 -C -C THIS IS THE ONLY GENERAL CONSTRAINT IN THE WORKING SET. -C - COND = QUOTNT( ASIZE, DTNEW ) - IF (COND .GE. CONDMX) GO TO 910 - IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD - DTMAX = DTNEW - DTMIN = DTNEW - GO TO 400 -C -C THERE ARE ALREADY SOME GENERAL CONSTRAINTS IN THE WORKING SET. -C UPDATE THE ESTIMATE OF THE CONDITION NUMBER. -C - 300 TDTMAX = DMAX1( DTNEW, DTMAX ) - TDTMIN = DMIN1( DTNEW, DTMIN ) - COND = QUOTNT( TDTMAX, TDTMIN ) - IF (COND .GE. CONDMX) GO TO 910 - IF (COND .GE. CONDBD) WRITE (NOUT, 2000) JADD - DTMAX = TDTMAX - DTMIN = TDTMIN -C -C --------------------------------------------------------------------- -C USE ONE OR MORE COLUMN TRANSFORMATIONS TO REDUCE THE FIRST NCOLZ1 -C ELEMENTS OF WRK1 TO ZERO. THIS AFFECTS ZY, EXCEPT IF (UNITQ). -C THE TRANSFORMATIONS MAY ALSO BE APPLIED TO QTG AND R. -C --------------------------------------------------------------------- -C - 400 IF (NCOLZ1 .EQ. 0 ) GO TO 600 - IF (MODFYR .OR. UNITQ) GO TO 500 -C -C --------------------------------------------------------------------- -C THERE IS NO R. USE A SINGLE ELIMINATION OR HOUSEHOLDER MATRIX. -C --------------------------------------------------------------------- - IF (ORTHOG) GO TO 440 -C -C ********************************************************************* -C ELIMINATION. -C WE USE ELM( ..., ZERO, ZERO ) TO PERFORM AN INTERCHANGE. -C ********************************************************************* - CALL ETAGEN( NCOLZ1, WRK1(NCOLZ), WRK1, NCOLZ1, 1, ISWAP, ITRANS ) - IF (ISWAP .GT. 0) - * CALL ELM ( ORTHOG, NFREE, ZY(1,NCOLZ), NFREE, 1, - * ZY(1,ISWAP), NFREE, 1, ZERO, ZERO ) -C - IF (ITRANS .EQ. 0) GO TO 420 -C - DO 410 J = 1, NCOLZ1 - D = WRK1(J) - IF (D .EQ. ZERO) GO TO 410 - CALL AXPY( NFREE, D, ZY(1,NCOLZ), NFREE, 1, ZY(1,J), NFREE, 1 ) - 410 CONTINUE -C - 420 IF (.NOT. MODFYG) GO TO 600 - IF (ISWAP .GT. 0) - * CALL ELM ( ORTHOG, 1, QTG(NCOLZ), 1, 1, - * QTG(ISWAP), 1, 1, ZERO, ZERO ) -C - IF (ITRANS .GT. 0) - * CALL AXPY( NCOLZ1, QTG(NCOLZ), WRK1, NCOLZ1, 1, - * QTG , NCOLZ1, 1 ) - GO TO 600 -C -C ********************************************************************* -C ORTHOGONAL TRANSFORMATION. -C WE USE A HOUSEHOLDER REFLECTION, I - 1/BETA V V(T). -C -C THERE ARE TWO WAYS OF APPLYING THE REFLECTION. THE UPDATE TO Z -C IS DONE VIA W = Z * V, Z = Z - 1/BETA W V(T), -C WHERE V = WRK1 (FROM HOUSEHOLDER), AND W = WRK2 (WORKSPACE). -C -C THE UPDATE TO QTG IS THE MORE USUAL D = - QTG(T)*V / BETA, -C QTG = QTG + D * V. -C -C NOTE THAT DELTA HAS TO BE STORED AFTER THE REFLECTION IS USED. -C ********************************************************************* - 440 CALL REFGEN( NCOLZ1, WRK1(NCOLZ), WRK1, NCOLZ1, 1, BETA, DELTA ) - IF (BETA .LE. ZERO) GO TO 600 - CALL ZEROVC( NFREE, WRK2, NFREE, 1 ) -C - DO 450 J = 1, NCOLZ - D = WRK1(J) - IF (D .EQ. ZERO) GO TO 450 - CALL AXPY( NFREE, D, ZY(1,J), NFREE, 1, WRK2, NFREE, 1 ) - 450 CONTINUE -C - DO 460 J = 1, NCOLZ - D = WRK1(J) - IF (D .EQ. ZERO) GO TO 460 - D = - D/BETA - CALL AXPY( NFREE, D, WRK2, NFREE, 1, ZY(1,J), NFREE, 1 ) - 460 CONTINUE -C - IF (.NOT. MODFYG) GO TO 470 - D = DOT( NCOLZ, WRK1, NCOLZ, 1, QTG, NCOLZ, 1 ) - D = - D/BETA - CALL AXPY( NCOLZ, D, WRK1, NCOLZ, 1, QTG, NCOLZ, 1 ) -C - 470 WRK1(NCOLZ) = DELTA - GO TO 600 -C -C --------------------------------------------------------------------- -C R HAS TO BE MODIFIED. USE A SEQUENCE OF 2*2 TRANSFORMATIONS. -C --------------------------------------------------------------------- - 500 LROWR = NCOLR -C - DO 510 K = 1, NCOLZ1 -C -C COMPUTE THE TRANSFORMATION THAT REDUCES WRK1(K) TO ZERO, -C THEN APPLY IT TO THE RELEVANT COLUMNS OF Z AND GRAD(T)Q. -C - KP1 = K + 1 - CALL ELMGEN( ORTHOG, WRK1(KP1), WRK1(K), CS, SN ) - IF (.NOT. UNITQ) - * CALL ELM ( ORTHOG, NFREE, ZY(1,KP1), NFREE, 1, - * ZY(1,K ), NFREE, 1, CS, SN ) - IF (MODFYG) - * CALL ELM ( ORTHOG, 1, QTG(KP1), 1, 1, QTG(K), 1, 1, CS, SN ) -C -C APPLY THE SAME TRANSFORMATION TO THE COLS OF R IF RELEVANT. -C THIS GENERATES A SUBDIAGONAL ELEMENT IN R WHICH MUST BE -C ELIMINATED BY A ROW ROTATION. THE LAST SUCH ROW ROTATION -C IS NEEDED BY QPCORE. -C - IF (.NOT. (MODFYR .AND. K .LT. NCOLR)) GO TO 510 - RT(KP1,K) = ZERO - CALL ELM ( ORTHOG, KP1, RT(1,KP1), KP1, 1, - * RT(1,K ), KP1, 1, CS, SN ) - CALL ROTGEN( RT(K,K), RT(KP1,K), CSLAST, SNLAST ) - LROWR = LROWR - 1 - LENRT = NROWRT*(LROWR - 1) + 1 - CALL ROT3 ( LROWR, RT(K,KP1), LENRT, NROWRT, - * RT(KP1,KP1), LENRT, NROWRT, CSLAST, SNLAST ) - 510 CONTINUE -C -C --------------------------------------------------------------------- -C IF ADDING A GENERAL CONSTRAINT, INSERT THE NEW ROW OF T AND EXIT. -C --------------------------------------------------------------------- - 600 IF (JADD .LE. N) GO TO 700 - LENRT = NROWRT*NACTIV + 1 - CALL COPYVC( NACT1, WRK1(NCOLZ), NACT1, 1, - * RT(NACT1,NCOLZ), LENRT, NROWRT ) - GO TO 900 -C -C --------------------------------------------------------------------- -C WE ARE ADDING A BOUND. CONTINUE REDUCING THE ELEMENTS OF WRK1 -C TO ZERO. THIS AFFECTS Y, T AND QTG. -C --------------------------------------------------------------------- -C FIRST, SET THE SUPER-DIAGONAL ELEMENTS OF T TO ZERO. -C - 700 IF (NACTIV .EQ. 0) GO TO 790 - LENRT = NROWRT*(NACTIV - 1) + 1 - CALL ZEROVC( NACTIV, RT(NACTIV,NCOLZ), LENRT, (NROWRT - 1) ) - NELM = 1 - LDIAG = NACTIV -C - DO 710 K = NCOLZ, NFREE1 - CALL ELMGEN( ORTHOG, WRK1(K+1), WRK1(K), CS, SN ) - CALL ELM ( ORTHOG, NFREE, ZY(1,K+1), NQ, 1, - * ZY(1,K ), NQ, 1, CS, SN ) - CALL ELM ( ORTHOG, NELM, RT(LDIAG,K+1), NROWRT, 1, - * RT(LDIAG,K ), NROWRT, 1, CS, SN ) - IF (MODFYG) - * CALL ELM ( ORTHOG, 1, QTG(K+1), 1, 1, QTG(K), 1, 1, CS, SN ) - NELM = NELM + 1 - LDIAG = LDIAG - 1 - 710 CONTINUE -C -C --------------------------------------------------------------------- -C THE DIAGONALS OF T HAVE BEEN ALTERED. RECOMPUTE THE LARGEST AND -C SMALLEST VALUES. -C --------------------------------------------------------------------- - LENRT = NROWRT*(NACTIV - 1) + 1 - INCT = NROWRT - 1 - CALL CONDVC( NACTIV, RT(NACTIV,NCOLZ1+1), LENRT, INCT, - * DTMAX, DTMIN ) - IF ((DTMIN/DTMAX)*CONDMX .LT. ONE) GO TO 910 - IF ((DTMIN/DTMAX)*CONDBD .LT. ONE) WRITE (NOUT, 2000) JADD -C -C THE LAST ROW OF ZY HAS BEEN TRANSFORMED TO A MULTIPLE OF THE -C UNIT VECTOR E(NFREE). IF ORTHOGONAL TRANSFORMATIONS HAVE BEEN -C USED THROUGHOUT, THE LAST COLUMN OF ZY IS THE SAME. WE CAN -C THEREFORE RESURRECT THE GRADIENT ELEMENT OF THE NEWLY-FIXED VARIABLE. -C - 790 IF (ORTHOG .AND. MODFYG) - *QTG(NFREE) = QTG(NFREE)/WRK1(NFREE) -C -C --------------------------------------------------------------------- -C THE FACTORIZATION HAS BEEN SUCCESSFULLY UPDATED. -C --------------------------------------------------------------------- - 900 INFORM = 0 - RETURN -C -C THE PROPOSED WORKING SET APPEARS TO BE LINEARLY DEPENDENT. -C - 910 INFORM = 1 - IF (.NOT. MSG .GE. 80) RETURN -C - WRITE (NOUT, 3000) - IF (JADD .LE. N) WRITE (NOUT, 3010) ASIZE, DTMAX, DTMIN - IF (JADD .GT. N) WRITE (NOUT, 3020) ASIZE, DTMAX, DTMIN, DTNEW - RETURN -C - 1010 FORMAT(/ 32H //ADDCON// SIMPLE BOUND ADDED. - * / 49H //ADDCON// NACTIV NCOLZ NFREE IFIX JADD UNITQ - * / 13H //ADDCON// , 5I6, L6 ) - 1020 FORMAT(/ 38H //ADDCON// GENERAL CONSTRAINT ADDED. - * / 49H //ADDCON// NACTIV NCOLZ NFREE IADD JADD UNITQ - * / 13H //ADDCON// , 5I6, L6 ) - 2000 FORMAT(/ 12H *** WARNING - * / 48H *** SERIOUS ILL-CONDITIONING IN THE WORKING SET, - * 25H AFTER ADDING CONSTRAINT , I5 - * / 48H *** OVERFLOW MAY OCCUR IN SUBSEQUENT ITERATIONS //) - 3000 FORMAT(/ 42H //ADDCON// DEPENDENT CONSTRAINT REJECTED ) - 3010 FORMAT(/ 41H //ADDCON// ASIZE DTMAX DTMIN - * / 11H //ADDCON//, 1P3E10.2 ) - 3020 FORMAT(/ 51H //ADDCON// ASIZE DTMAX DTMIN DTNEW - * / 11H //ADDCON//, 1P4E10.2 ) -C -C END OF ADDCON - END
deleted file mode 100644 --- a/libcruft/qpsol/alloc.f +++ /dev/null @@ -1,220 +0,0 @@ - SUBROUTINE ALLOC ( NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ, - * LITOTL, LWTOTL ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ, - * LITOTL, LWTOTL -C - LOGICAL SCALED - INTEGER NOUT, MSG, ISTART, LENNAM, NROWRT, - * NCOLRT, NQ, NCQP, NROWQP - DOUBLE PRECISION PARM - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ - COMMON /SOL4CM/ PARM(10) -C - INTEGER LOCLP - COMMON /SOL1LP/ LOCLP(15) -C - INTEGER LOCNP - COMMON /SOL1NP/ LOCNP(30) - COMMON /SOL2NP/ NCQP, NROWQP -C - INTEGER LOCLC - COMMON /SOL1LC/ LOCLC(15) -C -C ********************************************************************* -C ALLOC ALLOCATES THE ADDRESSES OF THE WORK ARRAYS FOR LPCORE, QPCORE -C LCCORE AND NPCORE. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION JANUARY 1983. -C VERSION 0.0 LCCORE MAY 1983. -C VERSION 2.0 NPCORE APRIL 1984. -C ********************************************************************* -C - INTEGER MAX0 -C - GO TO (100, 100, 300, 400), NALG -C -C --------------------------------------------------------------------- -C ALLOCATE THE ADDRESSES FOR LPCORE AND QPCORE. -C --------------------------------------------------------------------- - 100 LKACTV = LITOTL + 1 - LKFREE = LKACTV + N - LITOTL = LKFREE + N - 1 -C - LANORM = LWTOTL + 1 - LAP = LANORM + NCLIN - LPX = LAP + NCLIN - LQTG = LPX + N - LRLAM = LQTG + N - LRT = LRLAM + N - LZY = LRT + NROWRT*NCOLRT - LWRK = LZY + NQ*NQ - LWTOTL = LWRK + N - 1 -C - LOCLP( 2) = LKACTV - LOCLP( 3) = LKFREE - LOCLP( 4) = LANORM - LOCLP( 5) = LAP - LOCLP( 6) = LPX - LOCLP( 7) = LQTG - LOCLP( 8) = LRLAM - LOCLP( 9) = LRT - LOCLP(10) = LZY - LOCLP(11) = LWRK -C - GO TO 900 -C -C --------------------------------------------------------------------- -C ALLOCATE THE ADDRESSES FOR NPCORE. -C --------------------------------------------------------------------- - 300 LKACTV = LITOTL + 1 - LKFREE = LKACTV + N - LIQPST = LKFREE + N - LITOTL = LIQPST + NCTOTL - 1 -C -C VARIABLES USED NOT ONLY BY NPCORE, BUT ALSO LPCORE AND QPCORE. -C - LANORM = LWTOTL + 1 - LQTG = LANORM + NROWQP - LRLAM = LQTG + N - LRT = LRLAM + N - LZY = LRT + NROWRT*NCOLRT -C - LOCLP( 2) = LKACTV - LOCLP( 3) = LKFREE - LOCLP( 4) = LANORM - LOCLP( 7) = LQTG - LOCLP( 8) = LRLAM - LOCLP( 9) = LRT - LOCLP(10) = LZY -C -C ASSIGN THE ADDRESSES FOR THE WORKSPACE ARRAYS USED BY NPIQP. -C - LQPADX = LZY + NQ*NQ - LQPDX = LQPADX + NROWQP - LQPWRK = LQPDX + N -C - LOCLP( 5) = LQPADX - LOCLP( 6) = LQPDX - LOCLP(11) = LQPWRK -C -C ASSIGN THE ADDRESSES FOR ARRAYS USED IN NPCORE. -C - IF (NCNLN .EQ. 0) LENAQP = 0 - IF (NCNLN .GT. 0) LENAQP = NROWQP*N -C - LAQP = LQPWRK + N - LADX = LAQP + LENAQP - LBL = LADX + NROWQP - LBU = LBL + NCTOTL - LDX = LBU + NCTOTL - LG1 = LDX + N - LG2 = LG1 + N - LQPTOL = LG2 + N - LX1 = LQPTOL + NCTOTL - LNPWRK = LX1 + N -C - LOCNP( 1) = LIQPST - LOCNP( 2) = LAQP - LOCNP( 3) = LADX - LOCNP( 4) = LBL - LOCNP( 5) = LBU - LOCNP( 6) = LDX - LOCNP( 7) = LG1 - LOCNP( 8) = LG2 - LOCNP( 9) = LQPTOL - LOCNP(10) = LX1 - LOCNP(11) = LNPWRK -C - LCS1 = LNPWRK + NCTOTL - LCS2 = LCS1 + NCNLN - LCSL1 = LCS2 + NCNLN - LCSLAM = LCSL1 + NCNLN - LCJDX = LCSLAM + NCNLN - LDLAM = LCJDX + NCNLN - LDSLK = LDLAM + NCNLN - LRHO = LDSLK + NCNLN - LSIGMA = LRHO + NCNLN - LSLK1 = LSIGMA + NCNLN - LSLK = LSLK1 + NCNLN -C - LOCNP(12) = LCS1 - LOCNP(13) = LCS2 - LOCNP(14) = LCSL1 - LOCNP(15) = LCSLAM - LOCNP(16) = LCJDX - LOCNP(17) = LDLAM - LOCNP(18) = LDSLK - LOCNP(19) = LRHO - LOCNP(20) = LSIGMA - LOCNP(21) = LSLK1 - LOCNP(22) = LSLK -C - LWTOTL = LSLK + NCNLN - 1 -C - GO TO 900 -C -C --------------------------------------------------------------------- -C ALLOCATE THE ADDRESSES FOR LCCORE. -C --------------------------------------------------------------------- - 400 LKACTV = LITOTL + 1 - LKFREE = LKACTV + N - LITOTL = LKFREE + N - 1 -C - LZTG2 = LWTOTL + 1 -C - LOCLC( 1) = LZTG2 -C -C ARRAYS USED NOT ONLY BY LCCORE, BUT ALSO LPCORE. -C - LANORM = LZTG2 + N - LAP = LANORM + NCLIN - LPX = LAP + NCLIN - LQTG = LPX + N - LRLAM = LQTG + N - LRT = LRLAM + N - LZY = LRT + NROWRT*NCOLRT - LWRK = LZY + NQ*NQ -C - LOCLP( 2) = LKACTV - LOCLP( 3) = LKFREE - LOCLP( 4) = LANORM - LOCLP( 5) = LAP - LOCLP( 6) = LPX - LOCLP( 7) = LQTG - LOCLP( 8) = LRLAM - LOCLP( 9) = LRT - LOCLP(10) = LZY - LOCLP(11) = LWRK -C - LSHARE = LWRK + N -C -C ASSIGN THE ADDRESSES OF THE WORKSPACE USED BY LCSRCH. -C THIS WORKSPACE IS SHARED BY LCAPPG. -C - LX2 = LSHARE - LGRAD2 = LX2 + N - LMAX1 = LGRAD2 + N - 1 -C -C ASSIGN THE ADDRESSES OF THE WORKSPACE USED BY LCAPPG. -C THIS WORKSPACE IS SHARED BY LCSRCH. -C - LXFWD = LSHARE - LXBWD = LXFWD + N - LMAX2 = LXBWD + N - 1 -C - LWTOTL = MAX0( LMAX1, LMAX2 ) -C - LOCLC( 2) = LX2 - LOCLC( 3) = LGRAD2 -C - LOCLC( 4) = LXFWD - LOCLC( 5) = LXBWD -C - 900 RETURN -C -C END OF ALLOC - END
deleted file mode 100644 --- a/libcruft/qpsol/axpy.f +++ /dev/null @@ -1,74 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C FILE BLAS66 FORTRAN -C -C AXPY CONDVC COPYMX COPYVC DOT DSCALE ELM -C ELMGEN ETAGEN QUOTNT REFGEN ROTGEN ROT3 SSCALE -C V2NORM ZEROVC -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE AXPY ( N, A, X, LENX, INCX, Y, LENY, INCY ) -C - INTEGER N, LENX, INCX, LENY, INCY - DOUBLE PRECISION A, X(LENX), Y(LENY) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C AXPY REPLACES Y BY A*X + Y. -C - INTEGER I, IX, IY, NINCX - DOUBLE PRECISION FLMIN, ONE, TINY, UNDFLW, U, V, ZERO - DOUBLE PRECISION ABSA, ABSX, DU, DV - DOUBLE PRECISION DABS - DATA ZERO/0.0D+0/, ONE/1.0D+0/ -C - IF (N .LT. 1) RETURN - IF (A .EQ. ZERO) RETURN - IX = 1 - IY = 1 - UNDFLW = WMACH(9) - IF (UNDFLW .GT. ZERO) GO TO 110 -C -C NO UNDERFLOW TEST REQUIRED. -C DO THE MOST COMMON CASE SPECIALLY (INCX = INCY). -C - IF (INCX .NE. INCY) GO TO 50 - NINCX = N * INCX - DO 40 I = 1, NINCX, INCX - Y(I) = A * X(I) + Y(I) - 40 CONTINUE - RETURN -C - 50 DO 100 I = 1, N - Y(IY) = A * X(IX) + Y(IY) - IX = IX + INCX - IY = IY + INCY - 100 CONTINUE - RETURN -C -C UNDERFLOW TEST REQUIRED. -C - 110 FLMIN = WMACH(5) - ABSA = DABS( A ) - TINY = FLMIN - IF (ABSA .LT. ONE) TINY = FLMIN / ABSA - DO 160 I = 1, N - ABSX = DABS( X(IX) ) - IF (ABSX .LT. TINY) GO TO 150 - U = Y(IY) - DU = DABS( U ) - V = A * X(IX) - DV = DABS( V ) - IF (U .GE. ZERO) GO TO 120 - IF (V .LT. ZERO) GO TO 140 - GO TO 130 - 120 IF (V .GE. ZERO) GO TO 140 - 130 Y(IY) = ZERO - IF (DU .LE. FLMIN + DV .AND. DV .LE. FLMIN + DU) GO TO 150 - 140 Y(IY) = V + U - 150 IX = IX + INCX - IY = IY + INCY - 160 CONTINUE - RETURN -C -C END OF AXPY - END
deleted file mode 100644 --- a/libcruft/qpsol/bdpert.f +++ /dev/null @@ -1,146 +0,0 @@ - SUBROUTINE BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - * JADD1, JADD2, PALFA1, PALFA2, - * ISTATE, N, NCLIN0, NROWA, NCTOTL, - * ANORM, AP, AX, BL, BU, FEATOL, P, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL FIRSTV, NEGSTP - INTEGER JADD1, JADD2, N, NCLIN0, NCTOTL, NROWA - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION BIGALF, BIGBND, PALFA1, PALFA2, PNORM - DOUBLE PRECISION AP(NCLIN0), AX(NROWA), BL(NCTOTL), BU(NCTOTL), - * FEATOL(NCTOTL), P(N), X(N), ANORM(NCLIN0) -C - DOUBLE PRECISION PARM - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL4CM/ PARM(10) -C -C ********************************************************************* -C BDPERT FINDS STEPS PALFA1, PALFA2 SUCH THAT -C THE POINT X + PALFA1*P REACHES A LINEAR CONSTRAINT THAT IS -C CURRENTLY NOT IN THE WORKING SET BUT IS -C SATISFIED, -C THE POINT X + PALFA2*P REACHES A LINEAR CONSTRAINT THAT IS -C CURRENTLY NOT IN THE WORKING SET BUT IS -C VIOLATED. -C THE CONSTRAINTS ARE PERTURBED BY AN AMOUNT FEATOL, SO THAT -C PALFA1 IS SLIGHTLY LARGER THAN IT SHOULD BE, AND -C PALFA2 IS SLIGHTLY SMALLER THAN IT SHOULD BE. THIS GIVES -C SOME LEEWAY LATER WHEN THE EXACT STEPS ARE COMPUTED BY BNDALF. -C -C CONSTRAINTS IN THE WORKING SET ARE IGNORED (ISTATE(J) GE 1). -C -C IF NEGSTP IS TRUE, THE SEARCH DIRECTION WILL BE TAKEN TO BE - P. -C -C -C VALUES OF ISTATE(J).... -C -C - 2 - 1 0 1 2 3 -C A*X LT BL A*X GT BU A*X FREE A*X = BL A*X = BU BL = BU -C -C THE VALUES -2 AND -1 DO NOT OCCUR ONCE LPCORE FINDS A FEASIBLE POINT. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF MAY 1982. REV. OCT. 1982. JUNE 1986. -C ********************************************************************* -C - LOGICAL LASTV, NOLOW, NOUPP - INTEGER I, J, JS - DOUBLE PRECISION ABSATP, ATP, ATX, EPSPT9, ONE, RES, ROWNRM, - * ZERO - DOUBLE PRECISION DABS - DATA ZERO/0.0D+0/, ONE/1.0D+0/ -C - EPSPT9 = PARM(4) - IF (MSG .EQ. 99) WRITE (NOUT, 1100) - LASTV = .NOT. FIRSTV - JADD1 = 0 - JADD2 = 0 - PALFA1 = BIGALF - PALFA2 = ZERO - IF (FIRSTV) PALFA2 = BIGALF -C - DO 200 J = 1, NCTOTL - JS = ISTATE(J) - IF (JS .GT. 0) GO TO 200 - IF (J .GT. N) GO TO 120 -C -C BOUND CONSTRAINT. -C - ATX = X(J) - ATP = P(J) - ROWNRM = ONE - GO TO 130 -C -C GENERAL LINEAR CONSTRAINT. -C - 120 I = J - N - ATX = AX(I) - ATP = AP(I) - ROWNRM = ONE + ANORM(I) -C - 130 IF (NEGSTP) ATP = - ATP - IF (DABS(ATP) .GT. EPSPT9*ROWNRM*PNORM) GO TO 135 - RES = - ONE - GO TO 190 -C - 135 IF (ATP .GT. ZERO) GO TO 150 -C -C AX IS DECREASING. -C TEST FOR SMALLER PALFA1 IF LOWER BOUND IS SATISFIED. -C - IF (JS .EQ. (- 2)) GO TO 190 - ABSATP = - ATP - NOLOW = BL(J) .LE. (- BIGBND) - IF (NOLOW) GO TO 140 - RES = ATX - BL(J) + FEATOL(J) - IF (BIGALF*ABSATP .LE. DABS( RES )) GO TO 140 - IF (PALFA1*ABSATP .LE. RES ) GO TO 140 - PALFA1 = RES/ABSATP - JADD1 = J -C -C TEST FOR DIFFERENT PALFA2 IF UPPER BOUND IS VIOLATED. -C - 140 IF (JS .NE. (- 1)) GO TO 190 - RES = ATX - BU(J) - FEATOL(J) - IF (BIGALF*ABSATP .LE. DABS( RES )) GO TO 190 - IF (LASTV .AND. PALFA2*ABSATP .GE. RES) GO TO 190 - IF (FIRSTV .AND. PALFA2*ABSATP .LE. RES) GO TO 190 - PALFA2 = RES/ABSATP - JADD2 = J - GO TO 190 -C -C AX IS INCREASING. -C TEST FOR SMALLER PALFA1 IF UPPER BOUND IS SATISFIED. -C - 150 IF (JS .EQ. (- 1)) GO TO 190 - NOUPP = BU(J) .GE. BIGBND - IF (NOUPP) GO TO 160 - RES = BU(J) - ATX + FEATOL(J) - IF (BIGALF*ATP .LE. DABS( RES )) GO TO 160 - IF (PALFA1*ATP .LE. RES ) GO TO 160 - PALFA1 = RES/ATP - JADD1 = J -C -C TEST FOR DIFFERENT PALFA2 IF LOWER BOUND IS VIOLATED. -C - 160 IF (JS .NE. (- 2)) GO TO 190 - RES = BL(J) - ATX - FEATOL(J) - IF (BIGALF*ATP .LE. DABS( RES )) GO TO 190 - IF (LASTV .AND. PALFA2*ATP .GE. RES) GO TO 190 - IF (FIRSTV .AND. PALFA2*ATP .LE. RES) GO TO 190 - PALFA2 = RES/ATP - JADD2 = J -C - 190 IF (MSG .EQ. 99) WRITE (NOUT, 1200) J, JS, FEATOL(J), ATX, - * ATP, JADD1, PALFA1, JADD2, PALFA2 - 200 CONTINUE - RETURN -C - 1100 FORMAT(/ 50H J JS FEATOL AX AP, - * 46H JADD1 PALFA1 JADD2 PALFA2 /) - 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7)) -C -C END OF BDPERT - END
deleted file mode 100644 --- a/libcruft/qpsol/bndalf.f +++ /dev/null @@ -1,278 +0,0 @@ - SUBROUTINE BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD, - * N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF, - * ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM, - * ANORM, AP, AX, BL, BU, FEATOL, P, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER INFORM, JADD, N, NROWA, NCLIN, NCLIN0, NCTOTL, - * NUMINF - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM - DOUBLE PRECISION ANORM(NCLIN0), AP(NCLIN0), AX(NROWA), - * BL(NCTOTL), BU(NCTOTL), FEATOL(NCTOTL), - * P(N), X(N) - LOGICAL FIRSTV, HITLOW -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION PARM - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL4CM/ PARM(10) -C -C ********************************************************************* -C BNDALF FINDS A STEP ALFA SUCH THAT THE POINT X + ALFA*P REACHES -C ONE OF THE LINEAR CONSTRAINTS (INCLUDING BOUNDS). TWO POSSIBLE STEPS -C ARE DEFINED AS FOLLOWS... -C -C ALFA1 IS THE MAXIMUM STEP THAT CAN BE TAKEN WITHOUT VIOLATING -C ONE OF THE LINEAR CONSTRAINTS THAT IS CURRENTLY SATISFIED. -C ALFA2 REACHES A LINEAR CONSTRAINT THAT IS CURRENTLY VIOLATED. -C USUALLY THIS WILL BE THE FURTHEST SUCH CONSTRAINT ALONG P, -C BUT IF FIRSTV = .TRUE. IT WILL BE THE FIRST ONE ALONG P. -C THIS IS USED ONLY BY LPCORE WHEN THE PROBLEM HAS BEEN -C DETERMINED TO BE INFEASIBLE, AND WE ARE NOW MINIMIZING THE -C SUM OF INFEASIBILITIES. -C (ALFA2 IS NOT DEFINED IF NUMINF = 0.) -C -C ALFA WILL USUALLY BE THE MINIMUM OF ALFA1 AND ALFA2. -C ALFA COULD BE NEGATIVE (SINCE WE ALLOW INACTIVE CONSTRAINTS -C TO BE VIOLATED BY AS MUCH AS FEATOL). IN SUCH CASES, A -C THIRD POSSIBLE STEP IS COMPUTED, TO FIND THE NEAREST SATISFIED -C CONSTRAINT (PERTURBED BY FEATOL) ALONG THE DIRECTION - P. -C ALFA WILL BE RESET TO THIS STEP IF IT IS SHORTER. THIS IS THE -C ONLY CASE FOR WHICH THE FINAL STEP ALFA DOES NOT MOVE X EXACTLY -C ONTO A CONSTRAINT (THE ONE DENOTED BY JADD). -C -C CONSTRAINTS IN THE WORKING SET ARE IGNORED (ISTATE(J) GE 1). -C -C JADD DENOTES WHICH LINEAR CONSTRAINT IS REACHED. -C -C HITLOW INDICATES WHETHER IT IS THE LOWER OR UPPER BOUND THAT -C HAS RESTRICTED ALFA. -C -C VALUES OF ISTATE(J).... -C -C - 2 - 1 0 1 2 3 -C A*X LT BL A*X GT BU A*X FREE A*X = BL A*X = BU BL = BU -C -C THE VALUES -2 AND -1 DO NOT OCCUR ONCE LPCORE FINDS A FEASIBLE POINT. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF MAY 1982. REV. OCT. 1982. FEB. 1984. JUNE 1986. -C ********************************************************************* -C - INTEGER I, IADD, J, JS, JSAVE1, JSAVE2, JADD1, JADD2 - DOUBLE PRECISION ABSATP, ALFA1, ALFA2, APMAX1, APMAX2, ATP, - * ATP1, ATP2, ATX, EPSPT9, PALFA1, PALFA2, RES, - * ROWNRM - DOUBLE PRECISION ZERO, ONE - DOUBLE PRECISION DABS, DMIN1 - LOGICAL HLOW1, HLOW2, LASTV, NEGSTP, NOLOW, NOUPP, - * STEP2 - DATA ZERO, ONE /0.0D+0, 1.0D+0/ -C - EPSPT9 = PARM(4) -C - INFORM = 0 -C -C --------------------------------------------------------------------- -C FIRST PASS -- FIND STEPS TO PERTURBED CONSTRAINTS, SO THAT -C PALFA1 WILL BE SLIGHTLY LARGER THAN THE TRUE STEP, AND -C PALFA2 WILL BE SLIGHTLY SMALLER THAN IT SHOULD BE. IN DEGENERATE -C CASES, THIS STRATEGY GIVES US SOME FREEDOM IN THE SECOND PASS. -C THE GENERAL IDEA FOLLOWS THAT DESCRIBED BY P.M.J. HARRIS, P.21 OF -C MATHEMATICAL PROGRAMMING 5, 1 (1973), 1--28. -C --------------------------------------------------------------------- -C - NEGSTP = .FALSE. - CALL BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - * JADD1, JADD2, PALFA1, PALFA2, - * ISTATE, N, NCLIN0, NROWA, NCTOTL, - * ANORM, AP, AX, BL, BU, FEATOL, P, X ) -C - JSAVE1 = JADD1 - JSAVE2 = JADD2 -C -C --------------------------------------------------------------------- -C SECOND PASS -- RECOMPUTE STEP-LENGTHS WITHOUT PERTURBATION. -C AMONGST CONSTRAINTS THAT ARE CLOSE TO THE PERTURBED STEPS, -C CHOOSE THE ONE (OF EACH TYPE) THAT MAKES THE LARGEST ANGLE -C WITH THE SEARCH DIRECTION. -C --------------------------------------------------------------------- - IF (MSG .EQ. 99) WRITE (NOUT, 1000) - ALFA1 = BIGALF - ALFA2 = ZERO - IF (FIRSTV) ALFA2 = BIGALF -C - APMAX1 = ZERO - APMAX2 = ZERO - ATP1 = ZERO - ATP2 = ZERO - HLOW1 = .FALSE. - HLOW2 = .FALSE. - LASTV = .NOT. FIRSTV -C - DO 400 J = 1, NCTOTL - JS = ISTATE(J) - IF (JS .GT. 0) GO TO 400 - IF (J .GT. N) GO TO 320 -C -C BOUND CONSTRAINT. -C - ATX = X(J) - ATP = P(J) - ROWNRM = ONE - GO TO 330 -C -C GENERAL LINEAR CONSTRAINT. -C - 320 I = J - N - ATX = AX(I) - ATP = AP(I) - ROWNRM = ANORM(I) + ONE -C - 330 IF (DABS(ATP) .GT. EPSPT9*ROWNRM*PNORM) GO TO 335 - RES = - ONE - GO TO 390 -C - 335 IF (ATP .GT. ZERO) GO TO 350 -C -C ATX IS DECREASING. -C TEST FOR SMALLER ALFA1 IF LOWER BOUND IS SATISFIED. -C - IF (JS .EQ. (- 2)) GO TO 390 - ABSATP = - ATP - NOLOW = BL(J) .LE. (- BIGBND) - IF (NOLOW) GO TO 340 - RES = ATX - BL(J) - IF (PALFA1*ABSATP .LT. RES .AND. J .NE. JSAVE1) GO TO 340 - IF (APMAX1*ROWNRM*PNORM .GE. ABSATP) GO TO 340 - APMAX1 = ABSATP/(ROWNRM*PNORM) - ALFA1 = RES/ABSATP - JADD1 = J - ATP1 = ATP - HLOW1 = .TRUE. -C -C TEST FOR BIGGER ALFA2 IF UPPER BOUND IS VIOLATED. -C - 340 IF (JS .NE. (- 1)) GO TO 390 - RES = ATX - BU(J) - IF (LASTV .AND. PALFA2*ABSATP .GT. RES .AND. J .NE. JSAVE2) - * GO TO 390 - IF (FIRSTV .AND. PALFA2*ABSATP .LT. RES .AND. J .NE. JSAVE2) - * GO TO 390 - IF (APMAX2*ROWNRM*PNORM .GE. ABSATP) GO TO 390 - APMAX2 = ABSATP/(ROWNRM*PNORM) - ALFA2 = BIGALF - IF (ABSATP .LT. ONE) GO TO 342 - ALFA2 = RES/ABSATP - GO TO 345 - 342 IF (RES .LT. BIGALF*ABSATP) ALFA2 = RES/ABSATP -C - 345 JADD2 = J - ATP2 = ATP - HLOW2 = .FALSE. - GO TO 390 -C -C ATX IS INCREASING. -C TEST FOR SMALLER ALFA1 IF UPPER BOUND IS SATISFIED. -C - 350 IF (JS .EQ. (- 1)) GO TO 390 - NOUPP = BU(J) .GE. BIGBND - IF (NOUPP) GO TO 360 - RES = BU(J) - ATX - IF (PALFA1*ATP .LT. RES .AND. J .NE. JSAVE1) GO TO 360 - IF (APMAX1*ROWNRM*PNORM .GE. ATP ) GO TO 360 - APMAX1 = ATP/(ROWNRM*PNORM) - ALFA1 = RES/ATP - JADD1 = J - ATP1 = ATP - HLOW1 = .FALSE. -C -C TEST FOR BIGGER ALFA2 IF LOWER BOUND IS VIOLATED. -C - 360 IF (JS .NE. (- 2)) GO TO 390 - RES = BL(J) - ATX - IF (LASTV .AND. PALFA2*ATP .GT. RES .AND. J .NE. JSAVE2) - * GO TO 390 - IF (FIRSTV .AND. PALFA2*ATP .LT. RES .AND. J .NE. JSAVE2) - * GO TO 390 - IF (APMAX2*ROWNRM*PNORM .GE. ATP) GO TO 390 - APMAX2 = ATP/(ROWNRM*PNORM) - ALFA2 = BIGALF - IF (ATP .LT. ONE) GO TO 363 - ALFA2 = RES/ATP - GO TO 365 - 363 IF (RES .LT. BIGALF*ATP) ALFA2 = RES/ATP -C - 365 JADD2 = J - ATP2 = ATP - HLOW2 = .TRUE. -C - 390 IF (MSG .EQ. 99) WRITE (NOUT, 1200) J, JS, FEATOL(J), ATX, - * ATP, JADD1, ALFA1, JADD2, ALFA2 - 400 CONTINUE -C -C --------------------------------------------------------------------- -C IF FEASIBLE, ONLY ALFA1 WILL HAVE BEEN SET. -C --------------------------------------------------------------------- - ALFA = ALFA1 - PALFA = PALFA1 - JADD = JADD1 - ATPHIT = ATP1 - HITLOW = HLOW1 - IF (NUMINF .EQ. 0) GO TO 500 - IF (JADD2 .EQ. 0) GO TO 500 -C -C INFEASIBLE -- SEE IF WE STEP TO THE FURTHEST VIOLATED CONSTRAINT. -C BE PREPARED TO STEP IN THE RANGE (ALFA1, PALFA1) IF THE VIOLATED -C CONSTRAINT HAS A LARGER VALUE OF AP. -C - STEP2 = ALFA2 .LT. ALFA1 .OR. - * (ALFA2 .LE. PALFA1 .AND. APMAX2 .GE. APMAX1) - IF (.NOT. STEP2) GO TO 500 - ALFA = ALFA2 - JADD = JADD2 - ATPHIT = ATP2 - HITLOW = HLOW2 - GO TO 900 -C -C TEST FOR NEGATIVE STEP. -C JADD WILL RETAIN ITS CURRENT VALUE, BUT WE MAY SHORTEN ALFA -C TO BE - PALFA1, THE STEP TO THE NEAREST PERTURBED SATISFIED -C CONSTRAINT ALONG THE DIRECTION - P. -C - 500 NEGSTP = ALFA .LT. ZERO - IF (.NOT. NEGSTP) GO TO 900 -C - CALL BDPERT( FIRSTV, NEGSTP, BIGALF, BIGBND, PNORM, - * JADD1, JADD2, PALFA1, PALFA2, - * ISTATE, N, NCLIN0, NROWA, NCTOTL, - * ANORM, AP, AX, BL, BU, FEATOL, P, X ) -C - IF (MSG .GE. 80) WRITE (NOUT, 9000) ALFA, PALFA1 - ALFA = - DMIN1( DABS(ALFA), PALFA1 ) -C -C TEST FOR UNDEFINED OR INFINITE STEP. THIS SHOULD MEAN THAT THE -C SOLUTION IS UNBOUNDED. -C - 900 IF (JADD .EQ. 0) ALFA = BIGALF - IF (JADD .EQ. 0) PALFA = BIGALF - IF (JADD .EQ. 0) INFORM = 2 - IF (ALFA .GE. BIGALF) INFORM = 3 - IF (MSG .GE. 80 .AND. INFORM .GT. 0) - *WRITE (NOUT, 9010) JADD, ALFA - RETURN -C - 1000 FORMAT(/ 15H BNDALF ENTERED - * / 50H J JS FEATOL AX AP, - * 46H JADD1 ALFA1 JADD2 ALFA2 /) - 1200 FORMAT(I5, I4, 3G15.5, 2(I6, G17.7)) - 9000 FORMAT(/ 27H //BNDALF// NEGATIVE STEP. - * / 41H //BNDALF// ALFA PALFA - * / 11H //BNDALF//, 2G15.4 ) - 9010 FORMAT(/ 28H //BNDALF// UNBOUNDED STEP. - * / 32H //BNDALF// JADD ALFA - * / 13H //BNDALF// , I4, G15.4 ) -C -C END OF BNDALF - END
deleted file mode 100644 --- a/libcruft/qpsol/chkdat.f +++ /dev/null @@ -1,122 +0,0 @@ - SUBROUTINE CHKDAT( NERROR, LIWORK, LWORK, LITOTL, LWTOTL, - * NROWA, N, NCLIN, NCNLN, NCTOTL, - * ISTATE, KACTIV, - * LCRASH, NAMED, NAMES, LENNAM, - * BIGBND, A, BL, BU, FEATOL, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER NERROR, LIWORK, LWORK, LITOTL, LWTOTL, NROWA, - * N, NCLIN, NCNLN, NCTOTL, LCRASH, - * LENNAM - INTEGER ISTATE(NCTOTL), KACTIV(N), NAMES(4,LENNAM) - DOUBLE PRECISION BIGBND - DOUBLE PRECISION A(NROWA,N), BL(NCTOTL), BU(NCTOTL), - * FEATOL(NCTOTL), X(N) - LOGICAL NAMED -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C CHKDAT CHECKS THE DATA INPUT TO THE VARIOUS OPTIMIZERS. -C -C THE FOLLOWING QUANTITIES ARE NOT CHECKED... -C NROWA, N, NCLIN, NCTOTL -C KACTIV -C A, X -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF APRIL 1982. REV. OCT. 1982. -C ********************************************************************* -C - INTEGER IS, J, K, L, L1, L2, NPLIN - INTEGER ID(9) - DOUBLE PRECISION B1, B2, FTOL, ONE, TEST, ZERO - LOGICAL OK - DATA ID(1), ID(2), ID(3), ID(4), ID(5) - * / 2HVA, 2HRB, 2HL , 2HLN, 2HCO/ - DATA ID(6), ID(7), ID(8), ID(9) - * / 2HN , 2HNL, 2HCO, 2HN / - DATA ONE/1.0D+0/, ZERO/0.0D+0/ -C - NERROR = 0 -C -C --------------------------------------------------------------------- -C CHECK THAT THERE IS ENOUGH WORKSPACE TO SOLVE THE PROBLEM. -C --------------------------------------------------------------------- - OK = LITOTL .LE. LIWORK .AND. LWTOTL .LE. LWORK - IF (OK .AND. MSG .LE. 0) GO TO 100 - WRITE (NOUT, 1000) LIWORK, LWORK, LITOTL, LWTOTL - IF (OK) GO TO 100 - NERROR = NERROR + 1 - WRITE (NOUT, 1010) -C -C --------------------------------------------------------------------- -C CHECK THE BOUNDS ON ALL VARIABLES AND CONSTRAINTS. -C --------------------------------------------------------------------- - 100 DO 200 J = 1, NCTOTL - B1 = BL(J) - B2 = BU(J) - OK = B1 .LE. B2 - IF (OK) GO TO 200 - NERROR = NERROR + 1 - K = J - L1 = 1 - IF (J .GT. N) K = J - N - IF (J .GT. N) L1 = 4 - IF (J .GT. N + NCLIN) K = K - NCLIN - IF (J .GT. N + NCLIN) L1 = 7 - L2 = L1 + 2 - IF (.NOT. NAMED) WRITE (NOUT, 1100) (ID(L), L=L1,L2), K, B1,B2 - IF ( NAMED) WRITE (NOUT, 1200) (NAMES(L,J), L=1,4), B1,B2 - 200 CONTINUE -C -C --------------------------------------------------------------------- -C CHECK BIGBND AND FEATOL. -C --------------------------------------------------------------------- - OK = BIGBND .GT. ZERO - IF (OK) GO TO 300 - NERROR = NERROR + 1 - WRITE (NOUT, 1300) BIGBND -C - 300 DO 320 J = 1, NCTOTL - FTOL = FEATOL(J) - TEST = ONE + FTOL - OK = TEST .GT. ONE - IF (OK) GO TO 320 - WRITE (NOUT, 1400) J, FTOL - 320 CONTINUE -C -C --------------------------------------------------------------------- -C IF WARM START, CHECK ISTATE. -C --------------------------------------------------------------------- - 400 IF (LCRASH .EQ. 0) GO TO 900 - NPLIN = N + NCLIN -C - DO 420 J = 1, NPLIN - IS = ISTATE(J) - OK = IS .GE. (- 2) .AND. IS .LE. 4 - IF (OK) GO TO 420 - NERROR = NERROR + 1 - WRITE (NOUT, 1500) J, IS - 420 CONTINUE -C - 900 RETURN -C - 1000 FORMAT(/ 30H WORKSPACE PROVIDED IS IW(, I6, - * 6H), W(, I6, 2H). - * / 30H TO SOLVE PROBLEM WE NEED IW(, I6, - * 6H), W(, I6, 2H).) - 1010 FORMAT(/ 44H XXX NOT ENOUGH WORKSPACE TO SOLVE PROBLEM.) - 1100 FORMAT(/ 21H XXX THE BOUNDS ON , 2A2, A1, I3, - * 26H ARE INCONSISTENT. BL =, G16.7, 7H BU =, G16.7) - 1200 FORMAT(/ 21H XXX THE BOUNDS ON , 4A2, - * 26H ARE INCONSISTENT. BL =, G16.7, 7H BU =, G16.7) - 1300 FORMAT(/ 32H XXX BIGBND IS NOT POSITIVE..., G16.6) - 1400 FORMAT(/ 24H *** WARNING -- FEATOL(, I4, 16H ) IS LESS THAN, - * 21H MACHINE PRECISION..., G16.6) - 1500 FORMAT(/ 15H XXX COMPONENT, I5, 23H OF ISTATE IS OUT OF, - * 9H RANGE..., I10) -C -C END OF CHKDAT - END
deleted file mode 100644 --- a/libcruft/qpsol/condvc.f +++ /dev/null @@ -1,27 +0,0 @@ - SUBROUTINE CONDVC( N, X, LENX, INCX, XMAX, XMIN ) -C - INTEGER N, LENX, INCX - DOUBLE PRECISION XMAX, XMIN - DOUBLE PRECISION X(LENX) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C CONDVC FINDS THE BIGGEST AND SMALLEST COMPONENTS OF N ELEMENTS OF X. -C - INTEGER I, IX - DOUBLE PRECISION DABS, DMAX1, DMIN1 -C - XMAX = 0.0D+0 - XMIN = WMACH(8) - IF (N .LT. 1) RETURN - IX = 1 - DO 100 I = 1, N - XMAX = DMAX1( XMAX, DABS(X(IX)) ) - XMIN = DMIN1( XMIN, DABS(X(IX)) ) - IX = IX + INCX - 100 CONTINUE - RETURN -C -C END OF CONDVC - END
deleted file mode 100644 --- a/libcruft/qpsol/copymx.f +++ /dev/null @@ -1,18 +0,0 @@ - SUBROUTINE COPYMX( NROWS, N, IROWX, X, LROWX, IROWY, Y, LROWY ) -C - INTEGER NROWS, N, IROWX, LROWX, IROWY, LROWY - DOUBLE PRECISION X(LROWX,N), Y(LROWY,N) -C -C LOAD NROWS FROM THE MATRIX X INTO THE MATRIX Y. -C THE ROWS CONCERNED ARE ROWS IROWX, IROWX+1,... OF X AND ROWS -C IROWY, IROWY+1,... OF THE ARRAY Y. -C - INTEGER J - DO 100 J = 1, N - CALL COPYVC( NROWS, X(IROWX,J), NROWS, 1, Y(IROWY,J), NROWS, 1) - 100 CONTINUE -C - RETURN -C -C END OF COPYMX - END
deleted file mode 100644 --- a/libcruft/qpsol/copyvc.f +++ /dev/null @@ -1,27 +0,0 @@ - SUBROUTINE COPYVC( N, X, LENX, INCX, Y, LENY, INCY ) -C - INTEGER N, LENX, INCX, LENY, INCY - DOUBLE PRECISION X(LENX), Y(LENY) -C -C COPY THE FIRST N ELEMENTS OF X INTO Y. -C - INTEGER I, IX, IY -C - IF (N .LT. 1) RETURN - IF (INCX .EQ. 1 .AND. INCY .EQ. 1) GO TO 50 - IX = 1 - IY = 1 - DO 10 I = 1, N - Y(IY) = X(IX) - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C - 50 DO 60 I = 1, N - Y(I) = X(I) - 60 CONTINUE - RETURN -C -C END OF COPYVC - END
deleted file mode 100644 --- a/libcruft/qpsol/delcon.f +++ /dev/null @@ -1,159 +0,0 @@ - SUBROUTINE DELCON( MODFYG, ORTHOG, UNITQ, - * JDEL, KDEL, NACTIV, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, - * KACTIV, KFREE, - * A, QTG, RT, ZY ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL MODFYG, ORTHOG, UNITQ - INTEGER JDEL, KDEL, NACTIV, NCOLZ, NFREE, N, NQ, - * NROWA, NROWRT, NCOLRT - INTEGER KACTIV(N), KFREE(N) - DOUBLE PRECISION ASIZE, DTMAX, DTMIN - DOUBLE PRECISION A(NROWA,N), RT(NROWRT,NCOLRT), QTG(N), - * ZY(NQ,NQ) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C -C ********************************************************************* -C DELCON UPDATES THE FACTORIZATION OF THE MATRIX OF -C CONSTRAINTS IN THE WORKING SET, A(FREE) * (Z Y) = (0 T). -C -C IF THERE ARE NO GENERAL CONSTRAINTS IN THE WORKING SET AND THE -C MATRIX Q = (Z Y) IS THE IDENTITY, Q WILL NOT BE -C TOUCHED. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF DECEMBER 1981. REV. OCT. 1982. -C ********************************************************************* -C - INTEGER I, IBEGIN, IFREED, INCT, ISTORE, K, KA, - * KB, L, LDIAG, LENQ, LENRT, NACTPI, NACTP1, - * NACTV1, NCOLZ1, NFIXD1, NFREEI, NFREE1 - DOUBLE PRECISION CS, ONE, SN, STORE - DOUBLE PRECISION DMAX1 - DATA ONE/1.0D+0/ -C - LENQ = NQ*(NQ - 1) + 1 - IF (JDEL .GT. N) GO TO 200 -C -C ------------------------------------------------------------------ -C A SIMPLE BOUND IS BEING DELETED FROM THE WORKING SET. -C ------------------------------------------------------------------ - IFREED = KDEL - NACTIV - IF (MSG .GE. 80) - *WRITE (NOUT, 1010) NACTIV, NCOLZ, NFREE,IFREED,JDEL, UNITQ - NACTV1 = NACTIV - NFREE1 = NFREE + 1 - IBEGIN = 1 - KFREE(NFREE1) = JDEL -C -C ADD THE GRADIENT CORRESPONDING TO THE NEWLY-FREED VARIABLE TO THE -C END OF Q(FREE)(T)G(FREE). THIS IS DONE BY INTERCHANGING THE -C APPROPRIATE ELEMENTS OF QTG AND KACTIV. -C - IF (.NOT. MODFYG) GO TO 120 - IF (IFREED .EQ. 1) GO TO 120 - NFREEI = NFREE + IFREED - NACTP1 = NACTIV + 1 - NACTPI = NACTIV + IFREED - STORE = QTG(NFREE1) - QTG(NFREE1) = QTG(NFREEI) - QTG(NFREEI) = STORE - ISTORE = KACTIV(NACTP1) - KACTIV(NACTP1) = KACTIV(NACTPI) - KACTIV(NACTPI) = ISTORE -C -C COPY THE INCOMING COLUMN OF A INTO THE END OF T. -C - 120 IF (UNITQ ) GO TO 400 - IF (NACTIV .EQ. 0) GO TO 150 -C - DO 130 KA = 1, NACTIV - I = KACTIV(KA) - RT(KA,NFREE1) = A(I,JDEL) - 130 CONTINUE -C -C EXPAND Q BY ADDING A UNIT ROW AND COLUMN. -C - 150 CALL ZEROVC( NFREE, ZY(NFREE1,1), LENQ, NQ ) - CALL ZEROVC( NFREE, ZY(1,NFREE1), NQ, 1 ) - ZY(NFREE1,NFREE1) = ONE - GO TO 400 -C -C ------------------------------------------------------------------ -C A GENERAL CONSTRAINT IS BEING DELETED FROM THE WORKING SET. -C ------------------------------------------------------------------ - 200 IF (MSG .GE. 80) - *WRITE (NOUT, 1020) NACTIV, NCOLZ, NFREE, KDEL, JDEL, UNITQ - NACTV1 = NACTIV - 1 - NFREE1 = NFREE - IBEGIN = KDEL - IF (KDEL .GT. NACTV1) GO TO 400 -C -C DELETE A ROW OF T AND MOVE THE ONES BELOW IT UP. -C - DO 220 I = KDEL, NACTV1 - KACTIV(I) = KACTIV(I+1) - LENRT = NROWRT*I + 1 - LDIAG = NFREE - I - CALL COPYVC( I+1, RT(I+1,LDIAG), LENRT, NROWRT, - * RT(I,LDIAG), LENRT, NROWRT ) - 220 CONTINUE -C -C ------------------------------------------------------------------ -C ELIMINATE THE SUPER-DIAGONAL ELEMENTS OF T, -C USING A BACKWARD SWEEP OF 2*2 TRANFORMATIONS. -C ------------------------------------------------------------------ - 400 IF (IBEGIN .GT. NACTV1) GO TO 800 - K = NFREE1 - IBEGIN - L = NACTV1 - IBEGIN -C - DO 420 I = IBEGIN, NACTV1 - CALL ELMGEN( ORTHOG, RT(I,K+1), RT(I,K), CS, SN ) - IF (L .GT. 0) - * CALL ELM ( ORTHOG, L, RT(I+1,K+1), L, 1, - * RT(I+1,K ), L, 1, CS, SN ) - IF (NACTV1 .GT. 0) - * CALL ELM ( ORTHOG, NFREE1, ZY(1,K+1), NQ, 1, - * ZY(1,K ), NQ, 1, CS, SN ) - IF (MODFYG) - * CALL ELM ( ORTHOG, 1, QTG(K+1), 1, 1, QTG(K), 1, 1, CS, SN ) - K = K - 1 - L = L - 1 - 420 CONTINUE -C -C ------------------------------------------------------------------ -C COMPRESS THE ELEMENTS OF KACTIV CORRESPONDING TO FIXED VARIABLES. -C ------------------------------------------------------------------ - 800 NFIXD1 = N - NFREE1 - KB = NACTV1 + 1 - IF (NFIXD1 .EQ. 0) GO TO 900 - DO 810 K = 1, NFIXD1 - KACTIV(KB) = KACTIV(KB+1) - KB = KB + 1 - 810 CONTINUE -C -C ------------------------------------------------------------------ -C ESTIMATE THE CONDITION NUMBER OF T. -C ------------------------------------------------------------------ - 900 NCOLZ1 = NCOLZ + 1 - LENRT = NROWRT*(NACTV1 - 1) + 1 - INCT = NROWRT - 1 - IF (NACTV1 .GT. 0) - * CALL CONDVC( NACTV1, RT(NACTV1,NCOLZ1+1), LENRT, INCT, - * DTMAX, DTMIN ) -C - RETURN -C - 1010 FORMAT(/ 34H //DELCON// SIMPLE BOUND DELETED. - * / 49H //DELCON// NACTIV NCOLZ NFREE IFREED JDEL UNITQ - * / 13H //DELCON// , 3I6, I7, I5, L6 ) - 1020 FORMAT(/ 40H //DELCON// GENERAL CONSTRAINT DELETED. - * / 49H //DELCON// NACTIV NCOLZ NFREE KDEL JDEL UNITQ - * / 13H //DELCON// , 5I6, L6 ) -C -C END OF DELCON - END
deleted file mode 100644 --- a/libcruft/qpsol/dot.f +++ /dev/null @@ -1,56 +0,0 @@ - DOUBLE PRECISION FUNCTION DOT( N, X, LENX, INCX, Y, LENY, INCY ) -C - INTEGER N, LENX, INCX, LENY, INCY - DOUBLE PRECISION X(LENX), Y(LENY) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C DOT RETURNS THE INNER PRODUCT OF X AND Y. -C VERSION OF FEBRUARY 1981. SIMPLE CASE ADDED MARCH 1983. -C - INTEGER I, IX, IY, NINCX - DOUBLE PRECISION ABSXI, FLMIN, ONE, UNDFLW, ZERO - DOUBLE PRECISION DABS - DATA ZERO, ONE/0.0D+0, 1.0D+0/ -C - DOT = ZERO - IF (N .LT. 1) RETURN - IX = 1 - IY = 1 - UNDFLW = WMACH(9) - IF (UNDFLW .GT. ZERO) GO TO 110 -C -C NO UNDERFLOW TEST REQUIRED. -C DO THE MOST COMMON CASE SPECIALLY (INCX = INCY). -C - IF (INCX .NE. INCY) GO TO 50 - NINCX = N * INCX - DO 40 I = 1, NINCX, INCX - DOT = DOT + X(I)*Y(I) - 40 CONTINUE - RETURN -C - 50 DO 100 I = 1, N - DOT = DOT + X(IX)*Y(IY) - IX = IX + INCX - IY = IY + INCY - 100 CONTINUE - RETURN -C -C GUARD AGAINST UNDERFLOW. -C - 110 FLMIN = WMACH(5) - DO 140 I = 1, N - ABSXI = DABS(X(IX)) - IF (ABSXI .EQ. ZERO) GO TO 130 - IF (ABSXI .GE. ONE) GO TO 120 - IF (DABS(Y(IY)) .LT. FLMIN/ABSXI) GO TO 130 - 120 DOT = DOT + X(IX)*Y(IY) - 130 IX = IX + INCX - IY = IY + INCY - 140 CONTINUE - RETURN -C -C END OF DOT - END
deleted file mode 100644 --- a/libcruft/qpsol/dscale.f +++ /dev/null @@ -1,22 +0,0 @@ - SUBROUTINE DSCALE( N, D, LEND, INCD, X, LENX, INCX ) -C - INTEGER N, LEND, INCD, LENX, INCX - DOUBLE PRECISION D(LEND), X(LENX) -C -C DSCALE PERFORMS DIAGONAL SCALING ON THE VECTOR X, -C REPLACING X(I) BY D(I)*X(I) FOR N VALUES OF I. -C - INTEGER I, ID, IX -C - IF (N .LT. 1) RETURN - ID = 1 - IX = 1 - DO 100 I = 1, N - X(IX) = D(ID)*X(IX) - ID = ID + INCD - IX = IX + INCX - 100 CONTINUE - RETURN -C -C END OF DSCALE - END
deleted file mode 100644 --- a/libcruft/qpsol/elm.f +++ /dev/null @@ -1,62 +0,0 @@ - SUBROUTINE ELM ( ORTHOG, N, X, LENX, INCX, Y, LENY, INCY, - * CS, SN ) -C - LOGICAL ORTHOG - INTEGER N, LENX, INCX, LENY, INCY - DOUBLE PRECISION CS, SN - DOUBLE PRECISION X(LENX), Y(LENY) -C -C ********************************************************************* -C IF ORTHOG IS TRUE, ELM APPLIES A PLANE ROTATION. OTHERWISE, -C ELM COMPUTES THE TRANSFORMATION (X Y)*E AND RETURNS THE RESULT -C IN (X Y), WHERE THE 2 BY 2 MATRIX E IS DEFINED BY CS AND SN -C AS FOLLOWS... -C -C E = ( 1 SN ) IF CS .GT. ZERO, E = ( 1 ) OTHERWISE. -C ( 1 ) ( 1 SN ) -C -C VERSION 1, APRIL 5 1983. -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ********************************************************************* -C - INTEGER I, IX, IY - DOUBLE PRECISION XI, YI, ZERO -C - IF (ORTHOG) GO TO 800 - ZERO = 0.0 - IF (CS .LE. ZERO) GO TO 200 - IF (SN .EQ. ZERO) RETURN - CALL AXPY ( N, SN, X, LENX, INCX, Y, LENY, INCY ) - RETURN -C - 200 IX = 1 - IY = 1 - IF (SN .EQ. ZERO) GO TO 300 -C - DO 210 I = 1, N - XI = X(IX) - YI = Y(IY) - X(IX) = YI - Y(IY) = XI + YI*SN - IX = IX + INCX - IY = IY + INCY - 210 CONTINUE - RETURN -C -C TREAT AN INTERCHANGE SPECIALLY. -C - 300 DO 310 I = 1, N - XI = X(IX) - X(IX) = Y(IY) - Y(IY) = XI - IX = IX + INCX - IY = IY + INCY - 310 CONTINUE - RETURN -C -C - 800 CALL ROT3 ( N, X, LENX, INCX, Y, LENY, INCY, CS, SN ) - RETURN -C -C END OF ELM - END
deleted file mode 100644 --- a/libcruft/qpsol/elmgen.f +++ /dev/null @@ -1,40 +0,0 @@ - SUBROUTINE ELMGEN( ORTHOG, X, Y, CS, SN ) -C - LOGICAL ORTHOG - DOUBLE PRECISION X, Y, CS, SN -C -C ********************************************************************* -C IF ORTHOG IS TRUE, ELMGEN GENERATES A PLANE ROTATION. OTHERWISE, -C ELMGEN GENERATES AN ELIMINATION TRANSFORMATION E SUCH THAT -C (X Y)*E = (X 0) OR (Y 0), DEPENDING ON THE RELATIVE -C SIZES OF X AND Y. -C -C VERSION 1, APRIL 5 1983. -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ********************************************************************* -C - DOUBLE PRECISION DABS - DOUBLE PRECISION ZERO, ONE - DATA ZERO, ONE /0.0D+0, 1.0D+0/ -C - IF (ORTHOG) GO TO 800 - CS = ONE - SN = ZERO - IF (Y .EQ. ZERO) RETURN - IF (DABS(X) .LT. DABS(Y)) GO TO 200 - SN = - Y/X - GO TO 300 -C - 200 CS = ZERO - SN = - X/Y - X = Y -C - 300 Y = ZERO - RETURN -C -C - 800 CALL ROTGEN( X, Y, CS, SN ) - RETURN -C -C END OF ELMGEN - END
deleted file mode 100644 --- a/libcruft/qpsol/etagen.f +++ /dev/null @@ -1,97 +0,0 @@ - SUBROUTINE ETAGEN( N, ALPHA, X, LENX, INCX, ISWAP, ITRANS ) -C - INTEGER N, LENX, INCX, ISWAP, ITRANS - DOUBLE PRECISION ALPHA - DOUBLE PRECISION X(LENX) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C ********************************************************************* -C ETAGEN GENERATES AN ELIMINATION TRANSFORMATION E SUCH THAT -C -C E ( ALPHA ) = ( DELTA ) , -C ( X ) ( 0 ) -C -C WHERE E HAS THE FORM -C -C E = ( 1 ) P -C ( Z I ) -C -C FOR SOME N-VECTOR Z AND PERMUTATION MATRIX P OF ORDER N + 1. -C -C IN CERTAIN CIRCUMSTANCES ( X VERY SMALL IN ABSOLUTE TERMS OR -C X VERY SMALL COMPARED TO ALPHA), E WILL BE THE IDENTITY MATRIX. -C ETAGEN WILL THEN LEAVE ALPHA AND X UNALTERED, AND WILL RETURN -C ISWAP = 0, ITRANS = 0. -C -C MORE GENERALLY, ISWAP AND ITRANS INDICATE THE VARIOUS POSSIBLE -C FORMS OF P AND Z AS FOLLOWS. -C -C IF ISWAP = 0, P = I. -C IF ISWAP GT 0, P INTERCHANGES ALPHA AND X(ISWAP). -C -C IF ITRANS = 0, Z = 0 AND THE TRANSFORMATION IS JUST E = P. -C IF ITRANS GT 0, Z IS NONZERO. ITS ELEMENTS ARE RETURNED IN X. -C -C ETAGEN GUARDS AGAINST OVERFLOW AND UNDERFLOW. -C IT IS ASSUMED THAT FLMIN .LT. EPSMCH**2 (I.E. RTMIN .LT. EPSMCH). -C -C VERSION 1, MARCH 31 1983. -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ********************************************************************* -C - INTEGER I, IMAX, NINCX, NZERO - DOUBLE PRECISION ABSALF, EPSMCH, RTMIN, TOL, XMAX, ZERO - DOUBLE PRECISION DABS - DATA ZERO/0.0D+0/ -C - ISWAP = 0 - ITRANS = 0 - IF (N .LT. 1) RETURN - EPSMCH = WMACH(3) - RTMIN = WMACH(6) - ABSALF = DABS(ALPHA) - XMAX = ZERO - NINCX = N * INCX -C - DO 10 I = 1, NINCX, INCX - IF (XMAX .GE. DABS( X(I) )) GO TO 10 - XMAX = DABS( X(I) ) - IMAX = I - 10 CONTINUE -C -C EXIT IF X IS VERY SMALL. -C - IF (XMAX .LE. RTMIN) RETURN -C -C SEE IF AN INTERCHANGE IS NEEDED FOR STABILITY. -C - IF (ABSALF .LT. XMAX) ISWAP = IMAX - IF (ISWAP .EQ. 0) GO TO 200 - XMAX = X(IMAX) - X(IMAX) = ALPHA - ALPHA = XMAX -C -C FORM THE MULTIPLIERS IN X. THEY WILL BE NO GREATER THAN ONE -C IN MAGNITUDE. CHANGE NEGLIGIBLE MULTIPLIERS TO ZERO. -C - 200 TOL = DABS( ALPHA ) * EPSMCH - NZERO = 0 -C - DO 300 I = 1, NINCX, INCX - IF (DABS( X(I) ) .LE. TOL) GO TO 250 - X(I) = - X(I) / ALPHA - GO TO 300 -C - 250 X(I) = ZERO - NZERO = NZERO + 1 - 300 CONTINUE -C -C Z IS ZERO ONLY IF NZERO = N. -C - IF (NZERO .LT. N) ITRANS = 1 - RETURN -C -C END OF ETAGEN - END
deleted file mode 100644 --- a/libcruft/qpsol/findp.f +++ /dev/null @@ -1,110 +0,0 @@ - SUBROUTINE FINDP ( NULLR, UNITPG, UNITQ, - * N, NCLIN, NCLIN0, NCTOTL, NQ, - * NROWA, NROWRT, NCOLRT, NCOLR, NCOLZ, NFREE, - * ISTATE, KFREE, - * DINKY, GTP, PNORM, RDLAST, ZTGNRM, - * A, AP, P, QTG, RT, V, ZY, WORK ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL NULLR, UNITPG, UNITQ - INTEGER N, NCLIN, NCLIN0, NCTOTL, NQ, NROWA, - * NROWRT, NCOLRT, NCOLR, NFREE - INTEGER ISTATE(NCTOTL), KFREE(N) - DOUBLE PRECISION DINKY, GTP, PNORM, RDLAST, ZTGNRM - DOUBLE PRECISION A(NROWA,N), AP(NCLIN0), QTG(N), P(N), - * RT(NROWRT,NCOLRT), V(N), ZY(NQ,NQ) - DOUBLE PRECISION WORK(N) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C FINDP COMPUTES THE FOLLOWING QUANTITIES FOR LPCORE, QPCORE AND -C LCCORE ... -C -C (1) THE SEARCH DIRECTION P (AND ITS 2-NORM). -C (2) THE VECTOR V SUCH THAT R(T)V = - Z(T)G(FREE). THIS VECTOR IS -C REQUIRED BY LCCORE ONLY. -C (3) THE VECTOR AP, WHERE A IS THE MATRIX OF LINEAR CONSTRAINTS. -C AND, IF NULLR IS FALSE, -C (4) THE (NCOLR)-TH DIAGONAL ELEMENT OF THE CHOLESKY FACTOR OF THE -C PROJECTED HESSIAN. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION OF DECEMBER 1982. REV. MAY 1983. -C ********************************************************************* -C - INTEGER I, J - DOUBLE PRECISION ONE - DOUBLE PRECISION DOT, V2NORM - DATA ONE /1.0D+0/ -C - CALL COPYVC( NCOLR, QTG, NCOLR, 1, P, NCOLR, 1 ) - CALL SSCALE( NCOLR, (- ONE), P , NCOLR, 1 ) - IF (NULLR) GO TO 200 - RDLAST = RT(NCOLR,NCOLR) -C *** -C CORRECTION INSERTED BY MHW, 22 OCT 1985. -C THIS ENSURES A NON-ZERO SEARCH DIRECTION. -C *** - IF (NCOLR .LT. NCOLZ .AND. ZTGNRM .LE. DINKY) P(NCOLR) = RDLAST -C -C --------------------------------------------------------------------- -C SOLVE THE SYSTEM R(T)R (PZ) = - Z(T)G(FREE). -C --------------------------------------------------------------------- - IF (UNITPG) GO TO 120 -C -C PERFORM THE FORWARD SUBSTITUTION R(T)V = - Z(T)G(FREE). -C - CALL RSOLVE( 2, NROWRT, NCOLR, RT, P ) - GO TO 130 -C -C THE PROJECTED GRADIENT IS A MULTIPLE OF THE UNIT VECTOR, THE FORWARD -C SUBSTITUTION MAY BE AVOIDED. -C - 120 IF (ZTGNRM .LE. DINKY) P(NCOLR) = - ONE - IF (ZTGNRM .GT. DINKY) P(NCOLR) = P(NCOLR) / RDLAST -C -C PERFORM THE BACKWARD SUBSTITUTION R(PZ) = P. -C - 130 CALL COPYVC( NCOLR, P, NCOLR, 1, V, NCOLR, 1 ) - CALL RSOLVE( 1, NROWRT, NCOLR, RT, P ) -C -C --------------------------------------------------------------------- -C THE VECTOR (PZ) HAS BEEN COMPUTED. -C --------------------------------------------------------------------- -C COMPUTE THE DIRECTIONAL DERIVATIVE G(T)P = (GZ)(T)(PZ). -C - 200 GTP = DOT( NCOLR, QTG, NCOLR, 1, P, NCOLR, 1 ) -C -C --------------------------------------------------------------------- -C COMPUTE P = Z * PZ. -C --------------------------------------------------------------------- -C NACTIV AND KACTIV ARE NOT USED IN ZYPROD. N AND KFREE SERVE -C AS ARGUMENTS FOR NACTIV AND KACTIV. -C - CALL ZYPROD( 1, N, N, NCOLR, NFREE, NQ, UNITQ, - * KFREE, KFREE, P, ZY, WORK ) -C - PNORM = V2NORM( NFREE, WORK, NFREE, 1 ) - IF (MSG .GE. 80) WRITE (NOUT, 1100) (P(J), J = 1, N) -C -C --------------------------------------------------------------------- -C COMPUTE AP. -C --------------------------------------------------------------------- - IF (NCLIN .EQ. 0) GO TO 900 - CALL ZEROVC( NCLIN, AP, NCLIN, 1 ) - DO 410 J = 1, N - IF (ISTATE(J) .GT. 0) GO TO 410 - CALL AXPY( NCLIN, P(J), A(1,J), NCLIN, 1, AP, NCLIN, 1 ) - 410 CONTINUE - IF (MSG .GE. 80 .AND. NCLIN .GT. 0) - * WRITE (NOUT, 1000) (AP(I), I = 1, NCLIN) -C - 900 RETURN -C - 1000 FORMAT(/ 20H //FINDP // AP ... / (1P5E15.5)) - 1100 FORMAT(/ 20H //FINDP // P ... / (1P5E15.5)) -C -C END OF FINDP - END
deleted file mode 100644 --- a/libcruft/qpsol/getlam.f +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE GETLAM( LPROB, N, NCLIN0, NCTOTL, - * NACTIV, NCOLZ, NFREE, NROWA, - * NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST, - * ISTATE, KACTIV, - * A, ANORM, QTG, RLAMDA, RT ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER LPROB, N, NCLIN0, NCTOTL, NACTIV, NCOLZ, NFREE, - * NROWA, NROWRT, NCOLRT, JSMLST, KSMLST - INTEGER ISTATE(NCTOTL), KACTIV(N) - DOUBLE PRECISION SMLLST - DOUBLE PRECISION A(NROWA,N), ANORM(NCLIN0), RLAMDA(N), QTG(N), - * RT(NROWRT,NCOLRT) -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C GETLAM FIRST COMPUTES THE LAGRANGE MULTIPLIER ESTIMATES FOR THE -C GIVEN WORKING SET. IT THEN DETERMINES THE VALUES AND INDICES OF -C CERTAIN SIGNIFICANT MULTIPLIERS. IN THIS PROCESS, THE MULTIPLIERS -C FOR INEQUALITIES AT THEIR UPPER BOUNDS ARE ADJUSTED SO THAT A -C NEGATIVE MULTIPLIER FOR AN INEQUALITY CONSTRAINT INDICATES -C NON-OPTIMALITY. IN THE FOLLOWING, THE TERM MINIMUM REFERS TO THE -C ORDERING OF NUMBERS ON THE REAL LINE, AND NOT TO THEIR MAGNITUDE. -C -C SMLLST IS THE MINIMUM AMONG THE INEQUALITY CONSTRAINTS OF THE -C (ADJUSTED) MULTIPLIERS SCALED BY THE 2-NORM OF THE -C ASSOCIATED CONSTRAINT ROW. -C -C JSMLST IS THE INDEX OF THE CONSTRAINT CORRESPONDING TO SMLLST. -C KSMLST MARKS ITS POSITION IN KACTIV. -C -C -C ON EXIT, ELEMENTS 1 THRU NACTIV OF RLAMDA CONTAIN THE -C (UNADJUSTED) MULTIPLIERS FOR THE GENERAL CONSTRAINTS. ELEMENTS -C NACTIV ONWARDS OF RLAMDA CONTAIN THE (UNADJUSTED) MULTIPLIERS FOR -C THE SIMPLE BOUNDS. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION OCTOBER 1982. -C ********************************************************************* -C - INTEGER I, IS, J, JGFXD, K, KA, KB, L, L1, L2, - * NFIXED, NLAM - DOUBLE PRECISION ANORMJ, BLAM, FLMAX, RLAM - DOUBLE PRECISION ONE - DOUBLE PRECISION DABS - DATA ONE / 1.0D+0 / -C - FLMAX = WMACH(7) -C -C --------------------------------------------------------------------- -C FIRST, COMPUTE THE LAGRANGE MULTIPLIERS FOR THE GENERAL CONSTRAINTS -C IN THE WORKING SET, BY SOLVING T(TRANSPOSE)*RLAMDA = Y(T)*GRAD. -C --------------------------------------------------------------------- - NFIXED = N - NFREE - NLAM = NFIXED + NACTIV - IF (NACTIV .EQ. 0) GO TO 120 - CALL COPYVC( NACTIV, QTG(NCOLZ+1), NACTIV, 1, RLAMDA, NACTIV, 1 ) - CALL TSOLVE( 2, NROWRT, NACTIV, RT(1,NCOLZ+1), RLAMDA ) -C -C --------------------------------------------------------------------- -C NOW SET ELEMENTS NACTIV, NACTIV+1,... OF RLAMDA EQUAL TO THE -C MULTIPLIERS FOR THE BOUND CONSTRAINTS IN THE WORKING SET. -C --------------------------------------------------------------------- - 120 IF (NFIXED .EQ. 0) GO TO 300 - DO 190 L = 1, NFIXED - KB = NACTIV + L - J = KACTIV(KB) - JGFXD = NFREE + L - BLAM = QTG(JGFXD) - IF (NACTIV .EQ. 0) GO TO 180 - DO 170 KA = 1, NACTIV - I = KACTIV(KA) - BLAM = BLAM - A(I,J)*RLAMDA(KA) - 170 CONTINUE - 180 RLAMDA(KB) = BLAM - 190 CONTINUE -C -C --------------------------------------------------------------------- -C FIND JSMLST, KSMLST AND SMLLST. -C --------------------------------------------------------------------- - 300 SMLLST = FLMAX - JSMLST = 0 - KSMLST = 0 - IF (NLAM .EQ. 0) GO TO 400 - DO 330 K = 1, NLAM - J = KACTIV(K) - IF (K .LE. NACTIV) J = J + N -C - IS = ISTATE(J) - IF (IS .EQ. 3) GO TO 330 -C - I = J - N - IF (J .LE. N) ANORMJ = ONE - IF (J .GT. N) ANORMJ = ANORM(I) -C - RLAM = RLAMDA(K) * ANORMJ -C -C CHANGE THE SIGN OF THE ESTIMATE IF THE CONSTRAINT IS IN THE -C WORKING SET (OR VIOLATED) AT ITS UPPER BOUND. -C - IF (IS .EQ. 2) RLAM = - RLAM - IF (IS .EQ. 4) RLAM = - DABS( RLAM ) -C -C FIND THE SMALLEST MULTIPLIER FOR THE INEQUALITIES. -C - IF (SMLLST .LE. RLAM) GO TO 330 - SMLLST = RLAM - JSMLST = J - KSMLST = K - 330 CONTINUE -C -C --------------------------------------------------------------------- -C IF REQUIRED, PRINT THE MULTIPLIERS. -C --------------------------------------------------------------------- - 400 IF (MSG .LT. 20) GO TO 900 - IF (NACTIV .GT. 0) - * WRITE (NOUT, 2000) LPROB, (KACTIV(K), RLAMDA(K), K=1,NACTIV) - L1 = NACTIV + 1 - L2 = NLAM - IF (L1 .LE. L2) - * WRITE (NOUT, 2100) LPROB, (KACTIV(K), RLAMDA(K), K=L1,L2) - IF (MSG .GE. 80) WRITE (NOUT, 2200) JSMLST, SMLLST, KSMLST -C - 900 RETURN -C - 2000 FORMAT(/ 21H MULTIPLIERS FOR THE , A2, 15H CONSTRAINTS... - * / 4(I5, 1PE11.2)) - 2100 FORMAT(/ 21H MULTIPLIERS FOR THE , A2, 21H BOUND CONSTRAINTS... - * / 4(I5, 1PE11.2)) - 2200 FORMAT(/ 51H //GETLAM// JSMLST SMLLST KSMLST (SCALED) - * / 13H //GETLAM// , I6, 1PE11.2, 5X, I6 ) -C -C END OF GETLAM - END
deleted file mode 100644 --- a/libcruft/qpsol/lpbgst.f +++ /dev/null @@ -1,62 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C FILE LPSUBS66 FORTRAN -C -C LPBGST LPCORE LPCRSH LPDUMP LPGRAD LPPRT -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE LPBGST( N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST, - * ISTATE, KACTIV, - * DINKY, FEAMIN, TRULAM, FEATOL, RLAMDA ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST - INTEGER ISTATE(NCTOTL), KACTIV(N) - DOUBLE PRECISION DINKY, FEAMIN, TRULAM - DOUBLE PRECISION FEATOL(NCTOTL), RLAMDA(N) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C FIND THE BIGGEST SCALED MULTIPLIER LARGER THAN UNITY. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION DECEMBER 1982. -C ********************************************************************* -C - INTEGER IS, J, K, NFIXED, NLAM - DOUBLE PRECISION BIGGST, RLAM - DOUBLE PRECISION ONE - DOUBLE PRECISION DABS - DATA ONE/1.0D+0/ -C - JBIGST = 0 - NFIXED = N - NFREE - NLAM = NFIXED + NACTIV - IF (NLAM .EQ. 0) GO TO 900 -C - BIGGST = ONE + DINKY - DO 110 K = 1, NLAM - J = KACTIV(K) - IF (K .LE. NACTIV) J = J + N - IS = ISTATE(J) - IF (IS .LT. 1) GO TO 110 - RLAM = RLAMDA(K) - IF (IS .EQ. 2) RLAM = - RLAM - IF (IS .EQ. 3) RLAM = DABS( RLAM ) - RLAM = (FEATOL(J)/FEAMIN)*RLAM -C - IF (BIGGST .GE. RLAM) GO TO 110 - BIGGST = RLAM - TRULAM = RLAMDA(K) - JBIGST = J - KBIGST = K - 110 CONTINUE - IF (MSG .GE. 80) WRITE (NOUT, 9000) JBIGST, BIGGST -C - 900 RETURN -C - 9000 FORMAT(/ 33H //LPBGST// JBIGST BIGGST - * / 13H //LPBGST// , I5, G15.4 ) -C -C END OF LPBGST - END
deleted file mode 100644 --- a/libcruft/qpsol/lpcore.f +++ /dev/null @@ -1,496 +0,0 @@ - SUBROUTINE LPCORE( LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX, - * INFORM, ITER, ITMAX, LCRASH, - * N, NCLIN, NCTOTL, NROWA, NACTIV, NFREE, NUMINF, - * ISTATE, KACTIV, KFREE, - * OBJ, XNORM, - * A, AX, BL, BU, CLAMDA, CVEC, FEATOL, X, - * IW, LIW, W, LW ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER INFORM, ITER, ITMAX, LCRASH, N, NCLIN, NCTOTL, - * NROWA, NACTIV, NFREE, NUMINF, LIW, LW - INTEGER ISTATE(NCTOTL), KACTIV(N), KFREE(N) - INTEGER IW(LIW) - DOUBLE PRECISION ASIZE, DTMAX, DTMIN, OBJ, XNORM - DOUBLE PRECISION A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL), - * CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL), X(N) - DOUBLE PRECISION W(LW) - LOGICAL LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX -C - INTEGER NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ - DOUBLE PRECISION WMACH, PARM - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ - COMMON /SOL4CM/ PARM(10) - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C - INTEGER LOCLP - COMMON /SOL1LP/ LOCLP(15) -C -C ********************************************************************* -C LPCORE FINDS A FEASIBLE POINT FOR THE GENERAL LINEAR CONSTRAINTS -C AND BOUNDS. THE SUM OF THE INFEASIBILITIES IS MINIMIZED USING -C A LINEAR PROGRAMMING ALGORITHM WHICH MAY PERFORM NON-SIMPLEX -C STEPS. AT EACH ITERATION THE DIRECTION OF SEARCH IS DEFINED AS -C THE PROJECTION OF THE STEEPEST-DESCENT DIRECTION. THIS -C PROJECTION IS COMPUTED USING AN ORTHOGONAL FACTORIZATION OF THE -C MATRIX OF CONSTRAINTS IN THE WORKING SET. -C -C IF LP = .TRUE., LPCORE WILL SOLVE THE LINEAR PROGRAMMING PROBLEM -C DEFINED BY THE OBJECTIVE CVEC, THE CONSTRAINT MATRIX A AND THE -C BOUNDS BL, BU. -C -C VALUES OF ISTATE(J).... -C -C - 2 - 1 0 1 2 3 -C A*X LT BL A*X GT BU A*X FREE A*X = BL A*X = BU BL = BU -C -C IF VERTEX = .TRUE., THE INITIAL POINT X WILL BE MADE INTO A -C VERTEX BY REGARDING SOME OF THE FREE VARIABLES X(J) AS BEING ON AN -C TEMPORARY BOUND. SOME OF THESE VARIABLES MAY REMAIN ON THEIR -C TEMPORARY BOUNDS. IF SO, THEIR STATE WILL BE ISTATE(J) = 4 . -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION 1.0. DECEMBER 1981. -C VERSION 2.0. JUNE 1982. -C VERSION 3.0. OCTOBER 1982. -C VERSION 3.2. APRIL 1984. -C -C COPYRIGHT 1982 STANFORD UNIVERSITY. -C -C THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU- -C ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR). -C -C THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL -C SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE -C DEPARTMENT OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03- -C 76ER72018; AND THE ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110. -C -C ********************************************************************* -C - INTEGER IADD, IDUMMY, IFIX, IS, ISDEL, JADD, JBIGST, - * JDEL, JSMLST, KB, KBIGST, KDEL, KGFIX, KSMLST, - * LANORM, LAP, LNAMES, LPROB, LPX, LQTG, LRLAM, - * LROWA, LRT, LWRK, LZY, MSGLVL, MSTALL, NCLIN0, - * NCNLN, NCOLZ, NDEL, NFIXED, NROWJ, NSTALL - INTEGER MAX0 - DOUBLE PRECISION ALFA, ANORM, ATPHIT, BIGALF, BIGBND, BIGDX, - * BND, CONDMX, CONDT, CSLAST, DINKY, EPSMCH, - * EPSPT9, FEAMAX, FEAMIN, FLMAX, GFNORM, GTP, - * OBJLP, OBJSIZ, PALFA, PNORM, RDLAST, SMLLST, - * SNLAST, SUMINF, TOLACT, TRULAM, WGFIX, ZTGNRM - DOUBLE PRECISION ZERO, ONE - DOUBLE PRECISION DOT, QUOTNT, V2NORM - DOUBLE PRECISION DABS, DMAX1 - LOGICAL ADDED, DELETE, FIRSTV, HITLOW, MODFYG, - * NULLR, PRNT, STALL, UNITPG - DATA ZERO, ONE /0.0D+0, 1.0D+0/ - DATA LPROB / 2HLP / -C -C SPECIFY MACHINE-DEPENDENT PARAMETERS. -C - EPSMCH = WMACH(3) - FLMAX = WMACH(7) -C - LNAMES = LOCLP( 1) - LANORM = LOCLP( 4) - LAP = LOCLP( 5) - LPX = LOCLP( 6) - LQTG = LOCLP( 7) - LRLAM = LOCLP( 8) - LRT = LOCLP( 9) - LZY = LOCLP(10) - LWRK = LOCLP(11) -C -C INITIALIZE -C - NCNLN = 0 - NCLIN0 = MAX0( NCLIN, 1 ) - NROWJ = 1 -C - INFORM = 0 - ITER = 0 - JADD = 0 - JDEL = 0 - LROWA = NROWA*(N - 1) + 1 - NDEL = 0 - NSTALL = 0 - NUMINF = 1 -C - MSGLVL = MSG - MSG = 0 - IF (ITER .GE. ISTART) MSG = MSGLVL -C - BIGBND = PARM(1) - BIGDX = PARM(2) - TOLACT = PARM(3) - EPSPT9 = PARM(4) -C - ALFA = ZERO - CONDMX = FLMAX - OBJLP = ZERO -C - ADDED = .TRUE. - FIRSTV = .FALSE. - MODFYG = .TRUE. - NULLR = .TRUE. - UNITPG = .FALSE. -C - CALL CONDVC( NCTOTL, FEATOL, NCTOTL, 1, FEAMAX, FEAMIN ) -C -C --------------------------------------------------------------------- -C GIVEN AN INITIAL POINT X, COMPUTE THE FOLLOWING..... -C (1) THE INITIAL WORKING SET. -C (2) THE TQ FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE -C WORKING SET. -C (3) THE VALUE AND GRADIENT OF THE SUM OF INFEASIBILITIES AT THE POINT -C X. IF X IS FEASIBLE AND THE SOLUTION OF AN LP IS REQUIRED, THE -C LINEAR OBJECTIVE FUNCTION AND GRADIENT IS COMPUTED. -C -C THE ARRAY RLAMDA IS USED AS TEMPORARY WORK SPACE. -C --------------------------------------------------------------------- - CALL LPCRSH( ORTHOG, UNITQ, VERTEX, LCRASH, N, NCLIN, NCLIN0, - * NCTOTL, NQ, NROWA, NROWRT, NCOLRT, NACTIV, - * NCOLZ, NFREE, ISTATE, KACTIV, KFREE, - * BIGBND, TOLACT, XNORM, - * A, W(LANORM), AX, BL, BU, X, - * W(LQTG), W(LRT), W(LZY), W(LPX), W(LWRK), W(LRLAM) ) -C - CALL LPGRAD( LP, N, NCTOTL, NROWA, - * BIGBND, FEAMIN, NUMINF, SUMINF, ISTATE, - * A, BL, BU, CVEC, FEATOL, W(LQTG), X ) -C - CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, W(LQTG), W(LZY), W(LWRK) ) -C - OBJ = SUMINF - IF (LP) OBJLP = DOT( N, CVEC, N, 1, X, N, 1 ) - IF (LP .AND. NUMINF .EQ. 0) OBJ = OBJLP -C - IF (NUMINF .EQ. 0 .AND. .NOT. LP) GO TO 900 -C -C .......................START OF THE MAIN LOOP........................ -C -C DEFINE SMALL QUANTITIES THAT REFLECT THE MAGNITUDE OF C, X, -C AND THE NORM OF THE CONSTRAINTS IN THE WORKING SET. -C - 100 OBJSIZ = (ONE + DABS( OBJ )) / (ONE + XNORM) - IF (NUMINF .EQ. 0) - *OBJSIZ = (EPSMCH + DABS( OBJ )) / (EPSMCH + XNORM) - ANORM = ZERO - IF (NACTIV .GT. 0) ANORM = DABS( DTMAX ) - DINKY = EPSPT9 * DMAX1( ANORM, OBJSIZ ) -C -C COMPUTE THE NORMS OF THE PROJECTED GRADIENT AND THE GRADIENT WITH -C RESPECT TO THE FREE VARIABLES. -C - ZTGNRM = ZERO - IF (NCOLZ .GT. 0) ZTGNRM = V2NORM( NCOLZ, W(LQTG), NCOLZ, 1 ) - GFNORM = ZTGNRM - IF (NFREE .GT. 0 .AND. NACTIV .GT. 0) - * GFNORM = V2NORM( NFREE, W(LQTG), NFREE, 1 ) -C - IF (MSG .GE. 80) WRITE (NOUT, 1100) ZTGNRM, DINKY - DELETE = ZTGNRM .LE. DINKY -C -C PRINT THE DETAILS OF THIS ITERATION. -C - PRNT = ADDED .OR. NDEL .GT. 1 - IF (.NOT. PRNT) GO TO 120 -C - CONDT = QUOTNT( DTMAX, DTMIN ) -C - CALL LPPRT ( LP, NROWA, NROWRT, NCOLRT, N, NCLIN, NCLIN0, NCTOTL, - * NFREE, ISDEL, NACTIV, NCOLZ, ITER, JADD, JDEL, - * ALFA, CONDT, NUMINF, SUMINF, OBJLP, - * ISTATE, KFREE, - * A, W(LRT), X, W(LWRK), W(LAP) ) -C - ADDED = .FALSE. - JADD = 0 - JDEL = 0 -C - 120 IF (NUMINF .EQ. 0 .AND. .NOT. LP) GO TO 900 - IF (.NOT. DELETE) GO TO 300 -C -C --------------------------------------------------------------------- -C THE PROJECTED GRADIENT IS NEGLIGIBLE. -C WE HAVE TO DELETE A CONSTRAINT BEFORE A MOVE CAN BE MADE. -C --------------------------------------------------------------------- - CALL GETLAM( LPROB, N, NCLIN0, NCTOTL, - * NACTIV, NCOLZ, NFREE, NROWA, - * NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST, - * ISTATE, KACTIV, - * A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) ) -C -C --------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF THE LEAST (ADJUSTED) MULTIPLIER IS GREATER -C THAN A SMALL NEGATIVE QUANTITY, AN ADEQUATE LP SOLUTION HAS BEEN -C FOUND. -C --------------------------------------------------------------------- - IF (SMLLST .GE. ( - DINKY )) JSMLST = 0 - IF (JSMLST .EQ. 0) GO TO 200 - IF (VERTEX .AND. NCOLZ .GE. 1) GO TO 200 -C -C PREPARE TO DELETE THE CONSTRAINT WITH INDEX JSMLST. -C - JDEL = JSMLST - KDEL = KSMLST - ISDEL = ISTATE(JDEL) - ISTATE(JDEL) = 0 - GO TO 220 -C -C --------------------------------------------------------------------- -C IF STILL INFEASIBLE, WE CAN REDUCE THE SUM OF INFEASIBILITIES -C IF THERE IS A MULTIPLIER GREATER THAN ONE. -C --------------------------------------------------------------------- -C INSTEAD OF LOOKING FOR THE LAST VIOLATED CONSTRAINT IN BNDALF, -C WE MUST NOW LOOK FOR THE FIRST VIOLATED CONSTRAINT ALONG P. -C THIS WILL ENSURE THAT THE WEIGHTED SUM OF INFEASIBILITIES DECREASES. -C - 200 IF (NUMINF .EQ. 0 .OR. .NOT. MINSUM) GO TO 800 -C -C FIND THE BIGGEST MULTIPLIER LARGER THAN UNITY. -C FOR THE PURPOSES OF THE TEST, THE J-TH MULTIPLIER IS SCALED -C BY FEATOL(J)/FEAMIN. THIS FORCES CONSTRAINTS WITH LARGER FEATOL -C VALUES TO BE DELETED FIRST. -C - CALL LPBGST( N, NACTIV, NCTOTL, NFREE, JBIGST, KBIGST, - * ISTATE, KACTIV, - * DINKY, FEAMIN, TRULAM, FEATOL, W(LRLAM) ) -C - IF (JBIGST .EQ. 0) GO TO 800 - JDEL = JBIGST - KDEL = KBIGST - ISDEL = ISTATE(JBIGST) - IF (TRULAM .LE. ZERO) IS = - 1 - IF (TRULAM .GT. ZERO) IS = - 2 - ISTATE(JBIGST) = IS - FIRSTV = .TRUE. -C -C --------------------------------------------------------------------- -C UPDATE THE TQ FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE -C WORKING SET. -C --------------------------------------------------------------------- - 220 NDEL = NDEL + 1 - CALL DELCON( MODFYG, ORTHOG, UNITQ, - * JDEL, KDEL, NACTIV, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, - * KACTIV, KFREE, - * A, W(LQTG), W(LRT), W(LZY) ) -C - NCOLZ = NCOLZ + 1 - IF (JDEL .LE. N) NFREE = NFREE + 1 - IF (JDEL .GT. N) NACTIV = NACTIV - 1 - GO TO 100 -C -C --------------------------------------------------------------------- -C COMPUTE THE SEARCH DIRECTION, P = - Z*(PROJECTED GRADIENT). -C --------------------------------------------------------------------- - 300 IF (ITER .GE. ITMAX) GO TO 940 - ITER = ITER + 1 - IF (ITER .GE. ISTART) MSG = MSGLVL -C - CALL FINDP ( NULLR, UNITPG, UNITQ, - * N, NCLIN, NCLIN0, NCTOTL, NQ, - * NROWA, NROWRT, NCOLRT, NCOLZ, NCOLZ, NFREE, - * ISTATE, KFREE, - * DINKY, GTP, PNORM, RDLAST, ZTGNRM, - * A, W(LAP), W(LPX), W(LQTG), W(LRT), W(LWRK), - * W(LZY), W(LWRK) ) -C -C --------------------------------------------------------------------- -C FIND THE CONSTRAINT WE BUMP INTO ALONG P. -C UPDATE X AND AX IF THE STEP ALFA IS NONZERO. -C --------------------------------------------------------------------- -C -C ALFA IS INITIALIZED TO BIGALF. IF IT REMAINS THAT WAY AFTER -C THE CALL TO BNDALF, IT WILL BE REGARDED AS INFINITE. -C - BIGALF = QUOTNT( BIGDX, PNORM ) -C - CALL BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD, - * N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF, - * ALFA, PALFA, ATPHIT, BIGALF, BIGBND, PNORM, - * W(LANORM), W(LAP), AX, BL, BU, FEATOL, W(LPX), X ) -C - IF (INFORM .NE. 0 .OR. JADD .EQ. 0) GO TO 820 -C -C TEST IF ALFA*PNORM IS NEGLIGIBLE. -C - STALL = DABS( ALFA*PNORM ) .LE. EPSPT9*XNORM - IF (.NOT. STALL) GO TO 410 -C -C TAKE A ZERO STEP. -C IF A NON-ORTHOGONAL TQ FACTORIZATION IS BEING RECURRED AND X IS -C NOT YET FEASIBLE, THE GRADIENT OF THE SUM OF INFEASIBILITIES MUST BE -C RECOMPUTED. -C - ALFA = ZERO - NSTALL = NSTALL + 1 - MSTALL = 50 - IF (NSTALL .LE. MSTALL .AND. ORTHOG) GO TO 500 - IF (NSTALL .LE. MSTALL .AND. .NOT. ORTHOG) GO TO 420 - GO TO 930 -C -C CHANGE X TO X + ALFA*P. UPDATE AX ALSO. -C - 410 NSTALL = 0 -C - CALL AXPY ( N , ALFA, W(LPX), N , 1, X , N , 1 ) - IF (NCLIN .GT. 0) - *CALL AXPY ( NCLIN, ALFA, W(LAP), NCLIN, 1, AX, NCLIN, 1 ) -C - XNORM = V2NORM( N, X, N, 1 ) -C - IF (LP) OBJLP = DOT( N, CVEC, N, 1, X, N, 1 ) -C -C IF X IS NOT YET FEASIBLE, COMPUTE OBJ AND GRAD AS THE VALUE -C AND GRADIENT OF THE SUM OF INFEASIBILITIES (IF X IS FEASIBLE, THE -C VECTOR QTG IS UPDATED AND GRAD NEED NOT BE COMPUTED). -C - 420 IF (NUMINF .EQ. 0) GO TO 500 -C - CALL LPGRAD( LP, N, NCTOTL, NROWA, - * BIGBND, FEAMIN, NUMINF, SUMINF, - * ISTATE, A, BL, BU, CVEC, FEATOL, W(LQTG), X ) -C - KGFIX = LQTG + JADD - 1 - IF (.NOT. ORTHOG .AND. JADD .LE. N) WGFIX = W(KGFIX) -C - CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, W(LQTG), W(LZY), W(LWRK) ) -C - OBJ = SUMINF -C -C --------------------------------------------------------------------- -C ADD A CONSTRAINT TO THE WORKING SET. -C --------------------------------------------------------------------- -C UPDATE ISTATE. -C - 500 IF (LP .AND. NUMINF .EQ. 0) OBJ = OBJLP - IF ( HITLOW) ISTATE(JADD) = 1 - IF (.NOT. HITLOW) ISTATE(JADD) = 2 - IF (BL(JADD) .EQ. BU(JADD)) ISTATE(JADD) = 3 -C -C IF A BOUND IS TO BE ADDED, MOVE X EXACTLY ONTO IT, EXCEPT WHEN -C A NEGATIVE STEP WAS TAKEN. (BNDALF MAY HAVE HAD TO MOVE TO SOME -C OTHER CLOSER CONSTRAINT.) -C - IADD = JADD - N - IF (JADD .GT. N) GO TO 520 - IF ( HITLOW) BND = BL(JADD) - IF (.NOT. HITLOW) BND = BU(JADD) - IF (ALFA .GE. ZERO) X(JADD) = BND -C - DO 510 IFIX = 1, NFREE - IF (KFREE(IFIX) .EQ. JADD) GO TO 520 - 510 CONTINUE -C -C UPDATE THE TQ FACTORS OF THE MATRIX OF CONSTRAINTS IN THE WORKING -C SET. USE THE ARRAY P AS WORK SPACE. -C - 520 ADDED = .TRUE. - NDEL = 0 - CALL ADDCON( MODFYG, .FALSE., ORTHOG, UNITQ, INFORM, - * IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, KFREE, - * CONDMX, CSLAST, SNLAST, - * A, W(LQTG), W(LRT), W(LZY), W(LWRK), W(LPX) ) -C - NCOLZ = NCOLZ - 1 - NFIXED = N - NFREE - IF (NFIXED .EQ. 0) GO TO 540 - KB = NACTIV + NFIXED - DO 530 IDUMMY = 1, NFIXED - KACTIV(KB+1) = KACTIV(KB) - KB = KB - 1 - 530 CONTINUE - 540 IF (JADD .GT. N) GO TO 550 -C -C ADD A BOUND. IF STABILIZED ELIMINATIONS ARE BEING USED TO UPDATE -C THE TQ FACTORIZATION, RECOMPUTE THE COMPONENT OF THE GRADIENT -C CORRESPONDING TO THE NEWLY FIXED VARIABLE. -C - NFREE = NFREE - 1 - KACTIV(NACTIV+1) = JADD - IF (ORTHOG) GO TO 100 -C - KGFIX = LQTG + NFREE - IF (LP .AND. NUMINF .EQ. 0) W(KGFIX) = CVEC(JADD) - IF ( NUMINF .GT. 0) W(KGFIX) = WGFIX - GO TO 100 -C -C ADD A GENERAL LINEAR CONSTRAINT. -C - 550 NACTIV = NACTIV + 1 - KACTIV(NACTIV) = IADD - GO TO 100 -C -C .........................END OF MAIN LOOP............................ -C -C -C NO CONSTRAINTS TO DROP. -C - 800 IF (NUMINF .GT. 0) GO TO 910 - GO TO 900 -C -C ERROR IN BNDALF -- PROBABLY UNBOUNDED LP. -C - 820 IF (NUMINF .EQ. 0) GO TO 920 - GO TO 910 -C -C FEASIBLE SOLUTION FOUND, OR OPTIMAL LP SOLUTION. -C - 900 INFORM = 0 - GO TO 950 -C -C THE LINEAR CONSTRAINTS AND BOUNDS APPEAR TO BE INFEASIBLE. -C - 910 INFORM = 1 - GO TO 950 -C -C UNBOUNDED LP. -C - 920 INFORM = 2 - GO TO 950 -C -C TOO MANY ITERATIONS WITHOUT CHANGING X. -C - 930 INFORM = 3 - GO TO 950 -C -C TOO MANY ITERATIONS. -C - 940 INFORM = 4 -C -C --------------------------------------------------------------------- -C PRINT FULL SOLUTION. IF NECESSARY, RECOMPUTE THE MULTIPLIERS. -C --------------------------------------------------------------------- - 950 MSG = MSGLVL - IF (MSG .GE. 1) WRITE (NOUT, 2000) INFORM, ITER -C - IF (INFORM .GT. 0) - *CALL GETLAM( LPROB, N, NCLIN0, NCTOTL, - * NACTIV, NCOLZ, NFREE, NROWA, - * NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST, - * ISTATE, KACTIV, - * A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) ) - IF (.NOT. LP .AND. INFORM .EQ. 0) - * CALL ZEROVC( N, W(LRLAM), N, 1 ) -C - CALL PRTSOL( NFREE, NROWA, NROWJ, - * N, NCLIN, NCNLN, NCTOTL, BIGBND, - * NAMED, IW(LNAMES), LENNAM, - * NACTIV, ISTATE, KACTIV, - * A, BL, BU, X, CLAMDA, W(LRLAM), X ) -C - RETURN -C - 1100 FORMAT(/ 34H //LPCORE// ZTGNRM DINKY - * / 11H //LPCORE//, 1P2E11.2 ) - 2000 FORMAT(/ 26H EXIT LP PHASE. INFORM =, I3, 9H ITER =, I4) -C -C END OF LPCORE - END
deleted file mode 100644 --- a/libcruft/qpsol/lpcrsh.f +++ /dev/null @@ -1,374 +0,0 @@ - SUBROUTINE LPCRSH( ORTHOG, UNITQ, VERTEX, LCRASH, N, NCLIN,NCLIN0, - * NCTOTL, NQ, NROWA, NROWRT, NCOLRT, NACTIV, - * NCOLZ, NFREE, ISTATE, KACTIV, KFREE, - * BIGBND, TOLACT, XNORM, - * A, ANORM, AX, BL, BU, X, - * QTG, RT, ZY, P, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER LCRASH, N, NCLIN, NCLIN0, NCTOTL, NQ, NROWA, - * NROWRT, NCOLRT, NACTIV, NCOLZ, NFREE - INTEGER ISTATE(NCTOTL), KACTIV(N), KFREE(N) - DOUBLE PRECISION ASIZE, DTMAX, DTMIN, BIGBND, TOLACT, XNORM - DOUBLE PRECISION A(NROWA,N), ANORM(NCLIN0), AX(NROWA), - * BL(NCTOTL), BU(NCTOTL), QTG(N), - * RT(NROWRT,NCOLRT), ZY(NQ,NQ), P(N), X(N) - DOUBLE PRECISION WRK1(N), WRK2(N) - LOGICAL ORTHOG, UNITQ, VERTEX -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C -C ********************************************************************* -C LPCRSH COMPUTES DETAILS ASSOCIATED WITH THE WORKING SET AT A POINT -C X. THE COMPUTATION DEPENDS UPON THE VALUE OF THE INPUT PARAMETER -C LCRASH. AS FOLLOWS ... -C -C LCRASH = 0 MEANS THAT LPCRSH SHOULD FIND (1) AN INITIAL WORKING -C SET, (2) THE TQ FACTORS OF THE CONSTRAINT COEFFICIENTS -C FOR THE WORKING SET, AND (3) THE POINT CLOSEST TO X -C THAT LIES ON THE WORKING SET. -C LCRASH = 1 MEANS THAT LPCRSH SHOULD COMPUTE (1) THE TQ FACTORS -C OF A WORKING SET SPECIFIED BY THE INTEGER ARRAY ISTATE, -C AND (2) THE POINT CLOSEST TO X THAT SATISFIES THE -C WORKING SET. -C LCRASH = 2 MEANS THAT LPCRSH ESSENTIALLY DOES NOTHING BUT COMPUTE -C AUXILIARY INFORMATION ABOUT THE POINT X THAT LIES ON -C THE CONSTRAINTS IN THE GIVEN WORKING SET. -C -C VALUES OF ISTATE(J).... -C -C - 2 - 1 0 1 2 3 -C A*X LT BL A*X GT BU A*X FREE A*X = BL A*X = BU BL = BU -C -C ISTATE(J) = 4 MEANS THAT X(J) IS ON A TEMPORARY BOUND. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF JANUARY 1982. REV. NOV. 1982. APR. 1984. -C ********************************************************************* -C - INTEGER I, IADD, IDUMMY, IFIX, IMIN, INFORM, IS, J, - * JADD, JMIN, K, KB, LENQ, LROWA, NACT1, NARTIF, - * NCOLZ1, NFIXED - DOUBLE PRECISION AMIN, BND, B1, B2, COLMIN, COLSIZ, CONDMX, - * CSLAST, FLMAX, RES, RESL, RESMIN, RESU, RNORM, - * ROWMAX, RTEPS, SNLAST, TOOBIG - DOUBLE PRECISION ZERO, ONE - DOUBLE PRECISION DOT, V2NORM - DOUBLE PRECISION DABS, DMIN1 - LOGICAL NOLOW, NOUPP - DATA ZERO , ONE - * /0.0D+0, 1.0D+0/ -C - RTEPS = WMACH(4) - FLMAX = WMACH(7) -C - LROWA = NROWA*(N - 1) + 1 -C -C SET THE MAXIMUM ALLOWABLE CONDITION ESTIMATOR OF THE CONSTRAINTS -C IN THE WORKING SET. NOTE THAT THE CONSERVATIVE VALUE USED IN LPCRSH -C IS SMALLER THAN THAT USED WHEN A CONSTRAINT IS ADDED TO THE WORKING -C SET DURING A TYPICAL ITERATION. -C - CONDMX = ONE/RTEPS -C - IF (MSG .GE. 80) WRITE (NOUT, 1210) LCRASH, NCLIN, NCTOTL - IF (MSG .GE. 80) WRITE (NOUT, 1010) (X(J), J = 1, N) - NFIXED = 0 - NACTIV = 0 - NARTIF = 0 -C -C IF A COLD START IS BEING MADE, INITIALIZE ISTATE. -C IF BL(J) = BU(J), SET ISTATE(J)=3 FOR ALL VARIABLES AND LINEAR -C CONSTRAINTS. -C - IF (LCRASH .GT. 0) GO TO 140 - DO 130 J = 1, NCTOTL - ISTATE(J) = 0 - IF (BL(J) .EQ. BU(J)) ISTATE(J) = 3 - 130 CONTINUE -C -C INITIALIZE NFIXED, NACTIV AND KACTIV. -C ENSURE THAT THE NUMBER OF BOUNDS AND GENERAL CONSTRAINTS IN THE -C WORKING SET DOES NOT EXCEED N. -C - 140 DO 200 J = 1, NCTOTL - IF (NFIXED + NACTIV .EQ. N) ISTATE(J) = 0 - IF (ISTATE(J) .LE. 0) GO TO 200 - IF (J .GT. N) GO TO 160 - NFIXED = NFIXED + 1 - IF (ISTATE(J) .EQ. 1) X(J) = BL(J) - IF (ISTATE(J) .GE. 2) X(J) = BU(J) - GO TO 200 - 160 NACTIV = NACTIV + 1 - IF (LCRASH .LT. 2) KACTIV(NACTIV) = J - N - 200 CONTINUE -C - NFREE = N - NFIXED - NCOLZ = NFREE - NACTIV -C -C IF A HOT START IS REQUIRED, THE TQ FACTORIZATION IS ALREADY KNOWN. -C - IF (LCRASH .GT. 1) GO TO 700 - DTMAX = ONE - DTMIN = ONE - UNITQ = .TRUE. -C -C COMPUTE THE 2-NORMS OF THE CONSTRAINT ROWS. -C - ASIZE = ONE - IF (NCLIN .EQ. 0) GO TO 215 - DO 210 J = 1, NCLIN - ANORM(J) = V2NORM( N, A(J,1), LROWA, NROWA ) - 210 CONTINUE - CALL CONDVC( NCLIN, ANORM, NCLIN, 1, ASIZE, AMIN ) -C - 215 IF (LCRASH .GT. 0) GO TO 400 -C -C --------------------------------------------------------------------- -C IF A COLD START IS REQUIRED, AN ATTEMPT IS MADE TO ADD AS MANY -C CONSTRAINTS AS POSSIBLE TO THE WORKING SET. -C --------------------------------------------------------------------- - IF (NFIXED + NACTIV .EQ. N) GO TO 500 -C -C SEE IF ANY VARIABLES ARE OUTSIDE THEIR BOUNDS. -C - DO 250 J = 1, N - IF (ISTATE(J) .NE. 0) GO TO 250 - B1 = BL(J) - B2 = BU(J) - NOLOW = B1 .LE. (- BIGBND) - NOUPP = B2 .GE. BIGBND - IS = 0 - IF (NOLOW) GO TO 220 - IF (X(J) - B1 .LE. (ONE + DABS( B1 ))*TOLACT) IS = 1 - 220 IF (NOUPP) GO TO 240 - IF (B2 - X(J) .LE. (ONE + DABS( B2 ))*TOLACT) IS = 2 - 240 IF (IS .EQ. 0) GO TO 250 -C -C SET VARIABLE EQUAL TO ITS BOUND. -C - ISTATE(J) = IS - IF (IS .EQ. 1) X(J) = B1 - IF (IS .EQ. 2) X(J) = B2 - NFIXED = NFIXED + 1 - IF (NFIXED + NACTIV .EQ. N) GO TO 500 - 250 CONTINUE -C -C --------------------------------------------------------------------- -C THE FOLLOWING LOOP FINDS THE LINEAR CONSTRAINT THAT IS CLOSEST -C TO BEING SATISFIED. IF IT IS SUFFICIENTLY CLOSE, IT WILL BE ADDED -C TO THE WORKING SET AND THE PROCESS WILL BE REPEATED. -C --------------------------------------------------------------------- -C FIRST, COMPUTE AX FOR INEQUALITY LINEAR CONSTRAINTS. -C - IF (NCLIN .EQ. 0) GO TO 400 - DO 280 I = 1, NCLIN - J = N + I - IF (ISTATE(J) .GT. 0) GO TO 280 - AX(I) = DOT(N, A(I,1), LROWA, NROWA, X, N, 1 ) - 280 CONTINUE -C - TOOBIG = TOLACT + TOLACT -C - DO 350 IDUMMY = 1, N - RESMIN = TOOBIG - IS = 0 -C - DO 340 I = 1, NCLIN - J = N + I - IF (ISTATE(J) .GT. 0) GO TO 340 - B1 = BL(J) - B2 = BU(J) - NOLOW = B1 .LE. (- BIGBND) - NOUPP = B2 .GE. BIGBND - RESL = TOOBIG - RESU = TOOBIG - IF (NOLOW) GO TO 320 - RESL = DABS( AX(I) - B1 ) / (ONE + DABS( B1 )) - 320 IF (NOUPP) GO TO 330 - RESU = DABS( AX(I) - B2 ) / (ONE + DABS( B2 )) - 330 RES = DMIN1( RESL, RESU ) - IF (RES .GE. TOLACT) GO TO 340 - IF (RES .GE. RESMIN) GO TO 340 - RESMIN = RES - IMIN = I - IS = 1 - IF (RESL .GT. RESU) IS = 2 - 340 CONTINUE -C - IF (IS .EQ. 0) GO TO 400 - NACTIV = NACTIV + 1 - KACTIV(NACTIV) = IMIN - J = N + IMIN - ISTATE(J) = IS - IF (NFIXED + NACTIV .EQ. N) GO TO 500 - 350 CONTINUE -C -C --------------------------------------------------------------------- -C IF NECESSARY, ADD TEMPORARY BOUNDS TO MAKE A VERTEX. -C --------------------------------------------------------------------- - 400 NCOLZ = N - NFIXED - NACTIV - IF (.NOT. VERTEX .OR. NCOLZ .EQ. 0) GO TO 500 -C -C COMPUTE LENGTHS OF COLUMNS OF SELECTED LINEAR CONSTRAINTS -C (JUST THE ONES CORRESPONDING TO FREE VARIABLES). -C - DO 440 J = 1, N - IF (ISTATE(J) .NE. 0) GO TO 440 - COLSIZ = ZERO - IF (NCLIN .EQ. 0) GO TO 430 - DO 420 K = 1, NCLIN - I = N + K - IF (ISTATE(I) .GT. 0) COLSIZ = COLSIZ + DABS( A(K,J) ) - 420 CONTINUE - 430 WRK1(J) = COLSIZ - 440 CONTINUE -C -C FIND THE NARTIF SMALLEST SUCH COLUMNS. -C THIS IS AN EXPENSIVE LOOP. LATER WE CAN REPLACE IT -C BY A 4-PASS PROCESS (SAY), ACCEPTING THE FIRST COL THAT -C IS WITHIN T OF COLMIN, WHERE T = 0.0, 0.001, 0.01, 0.1 (SAY). -C - DO 480 IDUMMY = 1, NCOLZ - COLMIN = FLMAX - DO 470 J = 1, N - IF (ISTATE(J) .NE. 0) GO TO 470 - IF (NCLIN .EQ. 0) GO TO 475 - COLSIZ = WRK1(J) - IF (COLMIN .LE. COLSIZ) GO TO 470 - COLMIN = COLSIZ - JMIN = J - 470 CONTINUE - J = JMIN - 475 ISTATE(J) = 4 - NARTIF = NARTIF + 1 - 480 CONTINUE -C -C --------------------------------------------------------------------- -C A TRIAL WORKING SET HAS NOW BEEN SELECTED. -C --------------------------------------------------------------------- -C SET KFREE TO POINT TO THE FREE VARIABLES. -C - 500 NFREE = 0 - DO 520 J = 1, N - IF (ISTATE(J) .NE. 0) GO TO 520 - NFREE = NFREE + 1 - KFREE(NFREE) = J - 520 CONTINUE -C -C COMPUTE THE TQ FACTORIZATION FOR THE SELECTED LINEAR CONSTRAINTS. -C FIRST, THE COLUMNS CORRESPONDING TO SIMPLE BOUNDS IN THE WORKING SET -C ARE REMOVED. THE RESULTING NACTIV BY NFREE MATRIX (NACTIV LE NFREE) -C IS FACTORIZED BY ADDING THE CONSTRAINTS ONE AT A TIME AND UPDATING -C USING PLANE ROTATIONS OR STABILIZED ELIMINATIONS. THE NACTIV BY -C NACTIV TRIANGULAR MATRIX T AND THE NFREE BY NFREE MATRIX Q -C ARE STORED IN THE ARRAYS RT AND ZY. -C - NCOLZ = NFREE - IF (NACTIV .EQ. 0) GO TO 550 - NACT1 = NACTIV - NACTIV = 0 - CALL TQADD ( ORTHOG, UNITQ, - * INFORM, 1, NACT1, NACTIV, NCOLZ, NFREE, - * N, NCTOTL, NQ, NROWA, NROWRT, NCOLRT, - * ISTATE, KACTIV, KFREE, - * CONDMX, - * A, QTG, RT, ZY, WRK1, WRK2 ) -C -C IF A VERTEX IS REQUIRED BUT TQADD WAS UNABLE TO ADD ALL OF THE -C SELECTED GENERAL CONSTRAINTS, ADD MORE TEMPORARY BOUNDS. -C - IF (.NOT. VERTEX .OR. NCOLZ .EQ. 0) GO TO 550 - LENQ = NQ*(NQ - 1) + 1 - NCOLZ1 = NCOLZ - DO 540 IDUMMY = 1, NCOLZ1 - ROWMAX = ZERO - DO 530 I = 1, NFREE - RNORM = V2NORM( NCOLZ, ZY(I,1), LENQ, NQ ) - IF (ROWMAX .GE. RNORM) GO TO 530 - ROWMAX = RNORM - IFIX = I - 530 CONTINUE - JADD = KFREE(IFIX) - CALL ADDCON( .FALSE., .FALSE., ORTHOG, UNITQ, INFORM, - * IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, KFREE, - * CONDMX, CSLAST, SNLAST, - * A, QTG, RT, ZY, WRK1, WRK2 ) -C - NFREE = NFREE - 1 - NCOLZ = NCOLZ - 1 - NARTIF = NARTIF + 1 - ISTATE(JADD) = 4 - 540 CONTINUE -C -C SET ELEMENTS NACTIV + 1, ......, NACTIV + NFIXED OF KACTIV TO -C POINT TO THE FIXED VARIABLES. -C - 550 KB = NACTIV - DO 560 J = 1, N - IF (ISTATE(J) .EQ. 0) GO TO 560 - KB = KB + 1 - KACTIV(KB) = J - 560 CONTINUE -C -C --------------------------------------------------------------------- -C THE TQ FACTORIZATION HAS BEEN COMPUTED. FIND THE POINT CLOSEST TO -C THE USER-SUPPLIED X THAT LIES ON THE INITIAL WORKING SET. -C --------------------------------------------------------------------- -C SET WRK1 = RESIDUALS FOR CONSTRAINTS IN THE WORKING SET. -C - IF (NACTIV .EQ. 0) GO TO 700 - DO 610 I = 1, NACTIV - K = KACTIV(I) - J = N + K - BND = BL(J) - IF (ISTATE(J) .GT. 1) BND = BU(J) - WRK1(I) = BND - DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - 610 CONTINUE -C -C SOLVE FOR P, THE SMALLEST CORRECTION TO X THAT GIVES A POINT -C ON THE CONSTRAINTS IN THE WORKING SET. -C FIRST SOLVE T*WRK1 = RESIDUALS, THEN GET P = Y*WRK1. -C - CALL TSOLVE( 1, NROWRT, NACTIV, RT(1,NCOLZ+1), WRK1 ) - CALL ZEROVC( N, P, N, 1 ) - CALL COPYVC( NACTIV, WRK1, NACTIV, 1, P(NCOLZ + 1), NACTIV, 1 ) - CALL ZYPROD( 2, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, P, ZY, WRK1 ) - CALL AXPY ( N, ONE, P, N, 1, X, N, 1 ) -C -C --------------------------------------------------------------------- -C COMPUTE THE 2-NORM OF X. -C INITIALIZE AX FOR ALL GENERAL CONSTRAINTS. -C --------------------------------------------------------------------- - 700 XNORM = V2NORM( N, X, N, 1 ) - IF (NCLIN .EQ. 0) GO TO 800 - CALL ZEROVC( NCLIN, AX, NCLIN, 1 ) - DO 720 J = 1, N - IF (X(J) .NE. ZERO) - * CALL AXPY( NCLIN, X(J), A(1,J), NCLIN, 1, AX, NCLIN, 1 ) - 720 CONTINUE -C -C A POINT THAT SATISFIES THE INITIAL WORKING SET HAS BEEN FOUND. -C - 800 NCOLZ = NFREE - NACTIV - NFIXED = N - NFREE - IF (MSG .GE. 80) WRITE (NOUT, 1000) NFIXED, NARTIF, NACTIV - IF (MSG .GE. 80) WRITE (NOUT, 1020) (X(J), J = 1, N) - RETURN -C - 1000 FORMAT(/ 34H LPCRSH. WORKING SET SELECTED ... - * / 9H BOUNDS =, I5, 4X, 18HTEMPORARY BOUNDS =, I5, - * 4X, 16HGENERAL LINEAR =, I5) - 1010 FORMAT(/ 29H LP VARIABLES BEFORE CRASH... / (5G12.3)) - 1020 FORMAT(/ 29H LP VARIABLES AFTER CRASH... / (5G12.3)) - 1210 FORMAT(/ 32H //LPCRSH// LCRASH NCLIN NCTOTL - * / 11H //LPCRSH//, 3I7 ) -C -C END OF LPCRSH - END
deleted file mode 100644 --- a/libcruft/qpsol/lpdump.f +++ /dev/null @@ -1,82 +0,0 @@ - SUBROUTINE LPDUMP( N, NCLIN, NCTOTL, NROWA, - * LCRASH, LP, MINSUM, NAMED, VERTEX, - * ISTATE, A, AX, BL, BU, CVEC, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL LP, MINSUM, NAMED, VERTEX - INTEGER N, NCLIN, NCTOTL, NROWA, LCRASH - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL) - DOUBLE PRECISION CVEC(N), X(N) -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C LPDUMP PRINTS A, BL, BU, CVEC, X, A*X, -C COLD, LP, MINSUM, NAMED, VERTEX, AND POSSIBLY ISTATE. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF APRIL 1982. REV. OCT. 1982. -C ********************************************************************* -C - INTEGER I, J, K, LROWA - DOUBLE PRECISION ATX, DOT -C -C PRINT WMACH AND THE LOGICALS. -C - WRITE (NOUT, 1000) - DO 10 I = 1, 11 - WRITE (NOUT, 1100) I, WMACH(I) - 10 CONTINUE - WRITE (NOUT, 1200) LCRASH, LP, MINSUM, NAMED, VERTEX -C -C PRINT A BY ROWS AND COMPUTE AX = A*X. -C - IF (NCLIN .EQ. 0) GO TO 200 - LROWA = NROWA*(N - 1) + 1 - DO 100 K = 1, NCLIN - WRITE (NOUT, 1500) K - WRITE (NOUT, 1600) (A(K,J), J=1,N) - AX(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - 100 CONTINUE -C -C PRINT BL, BU AND X OR AX. -C - 200 WRITE (NOUT, 2000) - DO 300 J = 1, NCTOTL - IF (J .GT. N) GO TO 250 - K = J - ATX = X(J) - GO TO 290 -C - 250 K = J - N - ATX = AX(K) - IF (K .EQ. 1) WRITE (NOUT, 2100) -C - 290 WRITE (NOUT, 2200) K, BL(J), BU(J), ATX - 300 CONTINUE -C -C PRINT CVEC, ISTATE. -C - IF (LP ) WRITE (NOUT, 3000) (CVEC(I) , I=1,N) - IF (LCRASH .GT. 0) WRITE (NOUT, 3100) (ISTATE(J), J=1,NCTOTL) - RETURN -C - 1000 FORMAT(1H1 / 19H OUTPUT FROM LPDUMP / 19H ******************) - 1100 FORMAT(/ 7H WMACH(, I2, 3H) =, G15.6) - 1200 FORMAT(/ 9H LCRASH =, I3, 4X, 9H LP =, L3, 4X, - * 9H MINSUM =, L3, 4X, 9H NAMED =, L3, 4X, - * 9H VERTEX =, L3) - 1500 FORMAT(/ 4H ROW, I6, 11H OF A ...) - 1600 FORMAT(5G15.6) - 2000 FORMAT(/ 14X, 42HJ BL(J) BU(J) X(J)) - 2100 FORMAT(/ 14X, 42HI BL(N+I) BU(N+I) A(I)*X) - 2200 FORMAT(I15, 3G15.6) - 3000 FORMAT(/ 9H CVEC ... / (5G15.6)) - 3100 FORMAT(/ 11H ISTATE ... / (10I4)) -C -C END OF LPDUMP - END
deleted file mode 100644 --- a/libcruft/qpsol/lpgrad.f +++ /dev/null @@ -1,93 +0,0 @@ - SUBROUTINE LPGRAD( LP, N, NCTOTL, NROWA, - * BIGBND, FEAMIN, NUMINF, SUMINF, ISTATE, - * A, BL, BU, CVEC, FEATOL, GRAD, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER N, NCTOTL, NROWA, NUMINF - INTEGER ISTATE(NCTOTL) - DOUBLE PRECISION BIGBND, FEAMIN, SUMINF - DOUBLE PRECISION A(NROWA,N), BL(NCTOTL), BU(NCTOTL), CVEC(N), - * FEATOL(NCTOTL), GRAD(N), X(N) - LOGICAL LP -C -C ********************************************************************* -C IF NUMINF .GT. 0, LPGRAD FINDS THE NUMBER AND WEIGHTED SUM OF -C INFEASIBILITIES FOR THE BOUNDS AND LINEAR CONSTRAINTS. AN -C APPROPRIATE GRADIENT VECTOR IS RETURNED IN GRAD. -C IF NUMINF = 0, AND IF AN LP PROBLEM IS BEING SOLVED, GRAD WILL BE -C LOADED WITH THE TRUE LINEAR OBJECTIVE. -C -C POSITIVE VALUES OF ISTATE(J) WILL NOT BE ALTERED. THESE MEAN -C THE FOLLOWING... -C -C 1 2 3 -C A*X = BL A*X = BU BL = BU -C -C OTHER VALUES OF ISTATE(J) WILL BE RESET AS FOLLOWS... -C A*X LT BL A*X GT BU A*X FREE -C - 2 - 1 0 -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF SEPTEMBER 1981. REV. OCT. 1982. JAN. 1983. -C ********************************************************************* -C - INTEGER J, K, LROWA - DOUBLE PRECISION ATX, FEASJ, S, WEIGHT, ZERO - DOUBLE PRECISION DOT - DOUBLE PRECISION DABS - LOGICAL NOLOW, NOUPP - DATA ZERO /0.0D+0/ -C - LROWA = NROWA*(N - 1) + 1 - IF (NUMINF .EQ. 0) GO TO 500 - NUMINF = 0 - SUMINF = ZERO - CALL ZEROVC( N, GRAD, N, 1 ) -C - DO 200 J = 1, NCTOTL -C -C DO NOTHING IF THE VARIABLE OR CONSTRAINT IS AT A BOUND. -C - IF (ISTATE(J) .GT. 0) GO TO 200 - FEASJ = FEATOL(J) - NOLOW = BL(J) .LE. (- BIGBND) - NOUPP = BU(J) .GE. BIGBND - K = J - N - IF (J .LE. N) ATX = X(J) - IF (J .GT. N) ATX = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - ISTATE(J) = 0 -C -C SEE IF THE LOWER BOUND IS VIOLATED. -C - IF (NOLOW) GO TO 150 - S = BL(J) - ATX - IF (S .LE. FEASJ) GO TO 150 - ISTATE(J) = - 2 - WEIGHT = - FEAMIN/FEASJ - GO TO 160 -C -C SEE IF THE UPPER BOUND IS VIOLATED. -C - 150 IF (NOUPP) GO TO 200 - S = ATX - BU(J) - IF (S .LE. FEASJ) GO TO 200 - ISTATE(J) = - 1 - WEIGHT = FEAMIN/FEASJ -C -C ADD THE INFEASIBILITY. -C - 160 NUMINF = NUMINF + 1 - SUMINF = SUMINF + DABS( WEIGHT ) * S - IF (J .LE. N) GRAD(J) = WEIGHT - IF (J .GT. N) - * CALL AXPY ( N, WEIGHT, A(K,1), LROWA, NROWA, GRAD, N, 1 ) - 200 CONTINUE -C -C IF FEASIBLE, INSTALL TRUE OBJECTIVE. -C - 500 IF (LP .AND. NUMINF .EQ. 0) - *CALL COPYVC( N, CVEC, N, 1, GRAD, N, 1 ) - RETURN -C -C END OF LPGRAD - END
deleted file mode 100644 --- a/libcruft/qpsol/lpprt.f +++ /dev/null @@ -1,135 +0,0 @@ - SUBROUTINE LPPRT ( LP, NROWA, NROWRT, NCOLRT, - * N, NCLIN, NCLIN0, NCTOTL, - * NFREE, ISDEL, NACTIV, NCOLZ, ITER, JADD, JDEL, - * ALFA, CONDT, NUMINF, SUMINF, OBJLP, - * ISTATE, KFREE, - * A, RT, X, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER NROWA, NROWRT, NCOLRT, N, NCLIN, NCLIN0, - * NCTOTL, NFREE, ISDEL, NACTIV, NCOLZ, ITER, - * JADD, JDEL, NUMINF - INTEGER ISTATE(NCTOTL), KFREE(N) - DOUBLE PRECISION ALFA, CONDT, SUMINF, OBJLP - DOUBLE PRECISION A(NROWA,N), RT(NROWRT,NCOLRT), X(N) - DOUBLE PRECISION WRK1(N), WRK2(NCLIN0) - LOGICAL LP -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C -C LPPRT PRINTS VARIOUS LEVELS OF OUTPUT FOR LPCORE. -C -C MSG CUMULATIVE RESULT -C --- ----------------- -C -C LE 0 NO OUTPUT. -C -C EQ 1 NOTHING NOW (BUT FULL OUTPUT LATER). -C -C EQ 5 ONE TERSE LINE OF OUTPUT. -C -C GE 10 SAME AS 5 (BUT FULL OUTPUT LATER). -C -C GE 15 NOTHING MORE IF ITER .LT. ISTART. -C OTHERWISE, X, ISTATE AND KFREE. -C -C GE 20 MULTIPLIERS (PRINTED OUTSIDE LPPRT). -C THE ARRAY AX. -C -C GE 30 DIAGONALS OF T. -C -C GE 80 DEBUG OUTPUT. -C -C EQ 99 A, BL, BU, CVEC, X (CALLED FROM LPDUMP). -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF DECEMBER 1981. REV. NOV. 1982. -C ********************************************************************* -C - INTEGER INCT, J, K, LADD, LDEL, LENT, LROWA, L1, L2 - INTEGER LSTATE(5) - DOUBLE PRECISION DOT - DATA LSTATE(1), LSTATE(2) / 1H , 1HL/ - DATA LSTATE(3), LSTATE(4) / 1HU, 1HE/ - DATA LSTATE(5) / 1HT / -C - IF (MSG .LT. 5) GO TO 900 -C - LDEL = 0 - LADD = 0 - IF (JDEL .GT. 0) LDEL = ISDEL - IF (JADD .GT. 0) LADD = ISTATE(JADD) - LDEL = LSTATE(LDEL + 1) - LADD = LSTATE(LADD + 1) - IF (MSG .GE. 15) GO TO 100 -C -C --------------------------------------------------------------------- -C PRINT HEADING (POSSIBLY) AND TERSE LINE. -C --------------------------------------------------------------------- - IF (.NOT. LP .AND. ITER .EQ. 0) WRITE (NOUT, 1100) - IF ( LP .AND. ITER .EQ. 0) WRITE (NOUT, 1110) - IF (.NOT. LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - * ALFA, CONDT, NUMINF, SUMINF - IF ( LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - * ALFA, CONDT, NUMINF, SUMINF, OBJLP - GO TO 900 -C -C --------------------------------------------------------------------- -C PRINT TERSE LINE, X, ISTATE AND KFREE. -C --------------------------------------------------------------------- - 100 WRITE (NOUT, 1000) ITER - IF (.NOT. LP) WRITE (NOUT, 1100) - IF ( LP) WRITE (NOUT, 1110) - IF (.NOT. LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - * ALFA, CONDT, NUMINF, SUMINF - IF ( LP) WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, - * ALFA, CONDT, NUMINF, SUMINF, OBJLP - WRITE (NOUT, 1300) (X(J) , J=1,N) - WRITE (NOUT, 1600) (ISTATE(J), J=1,N) - L1 = N + 1 - L2 = N + NCLIN - IF (L1 .LE. L2) WRITE (NOUT, 1610) (ISTATE(J), J=L1,L2) - IF (NFREE .GT. 0) WRITE (NOUT, 1700) (KFREE(K), K=1,NFREE) -C -C --------------------------------------------------------------------- -C COMPUTE AND PRINT AX. USE WORK = AP TO AVOID SIDE EFFECTS. -C --------------------------------------------------------------------- - IF (MSG .LT. 20) GO TO 900 - IF (NCLIN .EQ. 0) GO TO 300 - LROWA = NROWA*(N - 1) + 1 - DO 250 K = 1, NCLIN - WRK2(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - 250 CONTINUE - WRITE (NOUT, 2000) (WRK2(K), K=1,NCLIN) -C -C --------------------------------------------------------------------- -C PRINT THE DIAGONALS OF T. -C --------------------------------------------------------------------- - 300 IF (MSG .LT. 30) GO TO 900 - LENT = NROWRT*(NACTIV - 1) + 1 - INCT = NROWRT - 1 - IF (NACTIV .NE. 0) CALL COPYVC( NACTIV, RT(NACTIV,NCOLZ+1), - * LENT, INCT, WRK1, NACTIV, 1 ) - IF (NACTIV .NE. 0) WRITE (NOUT, 3000) (WRK1(J), J=1,NACTIV) -C - 900 RETURN -C - 1000 FORMAT(/// 18H ================= / 13H LP ITERATION, I5 - * / 18H ================= ) - 1100 FORMAT(// 5H ITN, 12H JDEL JADD , 6X, 4HSTEP, 10H COND T, - * 7H NUMINF, 8X, 7H SUMINF) - 1110 FORMAT(// 5H ITN, 12H JDEL JADD , 6X, 4HSTEP, 10H COND T, - * 7H NUMINF, 8X, 7H SUMINF, 9X, 6H LPOBJ) - 1200 FORMAT(I5, I5, A1, I5, A1, 1P2E10.2, I7, 1P2E15.6) - 1300 FORMAT(/ 13H LP VARIABLES / (1P5E15.6)) - 1600 FORMAT(/ 37H STATUS OF THE LP BOUND CONSTRAINTS / (1X, 10I4)) - 1610 FORMAT(/ 37H STATUS OF THE LP GENERAL CONSTRAINTS / (1X, 10I4)) - 1700 FORMAT(/ 26H LIST OF FREE LP VARIABLES / (1X, 10I4)) - 2000 FORMAT(/ 40H VALUES OF LP GENERAL LINEAR CONSTRAINTS / (1P5E15.6)) - 3000 FORMAT(/ 40H DIAGONALS OF LP WORKING SET FACTOR T / (1P5E15.6)) -C -C END OF LPPRT - END
deleted file mode 100644 --- a/libcruft/qpsol/prtsol.f +++ /dev/null @@ -1,169 +0,0 @@ - SUBROUTINE PRTSOL( NFREE, NROWA, NROWJ, - * N, NCLIN, NCNLN, NCTOTL, BIGBND, - * NAMED, NAMES, LENNAM, - * NACTIV, ISTATE, KACTIV, - * A, BL, BU, C, CLAMDA, RLAMDA, X ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL NAMED - INTEGER NFREE, NROWA, NROWJ, N, NCLIN, NCNLN, - * NCTOTL, LENNAM, NACTIV - INTEGER ISTATE(NCTOTL), KACTIV(N), NAMES(4,LENNAM) - DOUBLE PRECISION BIGBND - DOUBLE PRECISION A(NROWA,N), BL(NCTOTL), BU(NCTOTL), C(NROWJ), - * CLAMDA(NCTOTL), RLAMDA(N), X(N) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C PRTSOL EXPANDS THE LAGRANGE MULTIPLIERS INTO CLAMDA. -C IF MSG .GE. 10 OR MSG .EQ. 1, PRTSOL THEN PRINTS X, A*X, C(X), -C THEIR BOUNDS, THE MULTIPLIERS, AND THE RESIDUALS (DISTANCE TO THE -C NEAREST BOUND). -C PRTSOL IS CALLED BY LPCORE, QPCORE, LCCORE AND NPCORE JUST BEFORE -C THEY EXIT. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF MARCH 1982. REV. OCT. 1982. -C ********************************************************************* -C - INTEGER I, IP, IS, J, K, L, LROWA, LS, - * NFIXED, NLAM, NPLIN - INTEGER ID(9), ID3(3), ID4(4), LSTATE(7) - DOUBLE PRECISION B1, B2, RES, RES2, V, WLAM - DOUBLE PRECISION DOT - DOUBLE PRECISION DABS - DATA ID(1), ID(2), ID(3), ID(4), ID(5) - * / 2HVA, 2HRB, 2HL , 2HLN, 2HCO / - DATA ID(6), ID(7), ID(8), ID(9) - * / 2HN , 2HNL, 2HCO, 2HN / - DATA LSTATE(1), LSTATE(2) - * / 2H--, 2H++/ - DATA LSTATE(3), LSTATE(4) - * / 2HFR, 2HLL / - DATA LSTATE(5), LSTATE(6) - * / 2HUL, 2HEQ / - DATA LSTATE(7) - * / 2HTB / -C - NPLIN = N + NCLIN - LROWA = NROWA*(N - 1) + 1 -C -C EXPAND BOUND, LINEAR AND NONLINEAR MULTIPLIERS INTO CLAMDA. -C - CALL ZEROVC( NCTOTL, CLAMDA, NCTOTL, 1 ) - NFIXED = N - NFREE - NLAM = NACTIV + NFIXED - IF (NLAM .EQ. 0) GO TO 180 -C - DO 150 K = 1, NLAM - J = KACTIV(K) - IF (K .LE. NACTIV) J = J + N - CLAMDA(J) = RLAMDA(K) - 150 CONTINUE -C - 180 IF (MSG .LT. 10 .AND. MSG .NE. 1) RETURN -C - WRITE (NOUT, 1100) - ID3(1) = ID(1) - ID3(2) = ID(2) - ID3(3) = ID(3) -C - DO 500 J = 1, NCTOTL - B1 = BL(J) - B2 = BU(J) - WLAM = CLAMDA(J) - IS = ISTATE(J) - LS = LSTATE(IS + 3) - IF (J .LE. N ) GO TO 190 - IF (J .LE. NPLIN) GO TO 200 - GO TO 300 -C -C -C SECTION 1 -- THE VARIABLES X. -C ------------------------------ - 190 K = J - V = X(J) - GO TO 400 -C -C -C SECTION 2 -- THE LINEAR CONSTRAINTS A*X. -C ----------------------------------------- - 200 IF (J .NE. N + 1) GO TO 220 - WRITE (NOUT, 1200) - ID3(1) = ID(4) - ID3(2) = ID(5) - ID3(3) = ID(6) -C - 220 K = J - N - V = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - GO TO 400 -C -C -C SECTION 3 -- THE NONLINEAR CONSTRAINTS C(X). -C --------------------------------------------- -C - 300 IF (NCNLN .LE. 0) GO TO 500 - IF (J .NE. NPLIN + 1) GO TO 320 - WRITE (NOUT, 1300) - ID3(1) = ID(7) - ID3(2) = ID(8) - ID3(3) = ID(9) -C - 320 K = J - NPLIN - V = C(K) -C -C -C PRINT A LINE FOR THE J-TH VARIABLE OR CONSTRAINT. -C ------------------------------------------------- - 400 RES = V - B1 - RES2 = B2 - V - IF (DABS(RES) .GT. DABS(RES2)) RES = RES2 - IP = 1 - IF (B1 .LE. ( - BIGBND )) IP = 2 - IF (B2 .GE. BIGBND ) IP = IP + 2 - IF (.NOT. NAMED) GO TO 490 -C - DO 450 L = 1, 4 - ID4(L) = NAMES(L,J) - 450 CONTINUE - IF (IP .EQ. 1) WRITE (NOUT, 2100) ID4, LS, V,B1,B2,WLAM,RES - IF (IP .EQ. 2) WRITE (NOUT, 2200) ID4, LS, V, B2,WLAM,RES - IF (IP .EQ. 3) WRITE (NOUT, 2300) ID4, LS, V,B1, WLAM,RES - IF (IP .EQ. 4) WRITE (NOUT, 2400) ID4, LS, V, WLAM,RES - GO TO 500 -C - 490 IF (IP .EQ. 1) WRITE (NOUT, 3100) ID3, K, LS, V,B1,B2,WLAM,RES - IF (IP .EQ. 2) WRITE (NOUT, 3200) ID3, K, LS, V, B2,WLAM,RES - IF (IP .EQ. 3) WRITE (NOUT, 3300) ID3, K, LS, V,B1, WLAM,RES - IF (IP .EQ. 4) WRITE (NOUT, 3400) ID3, K, LS, V, WLAM,RES - 500 CONTINUE -C - RETURN -C - 1100 FORMAT(// 22H VARIABLE STATE, 5X, 6H VALUE, - * 6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND, - * 17H LAGR MULTIPLIER, 13H RESIDUAL /) - 1200 FORMAT(// 22H LINEAR CONSTR STATE, 5X, 6H VALUE, - * 6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND, - * 17H LAGR MULTIPLIER, 13H RESIDUAL /) - 1300 FORMAT(// 22H NONLNR CONSTR STATE, 5X, 6H VALUE, - * 6X, 12H LOWER BOUND, 4X, 12H UPPER BOUND, - * 17H LAGR MULTIPLIER, 13H RESIDUAL /) - 2100 FORMAT(1X, 4A2, 10X, A2, 3G16.7, G16.7, G16.4) - 2200 FORMAT(1X, 4A2, 10X, A2, G16.7, 5X, 5H NONE, 6X, G16.7, - * G16.7, G16.4) - 2300 FORMAT(1X, 4A2, 10X, A2, 2G16.7, 5X, 5H NONE, 6X, G16.7, G16.4) - 2400 FORMAT(1X, 4A2, 10X, A2, G16.7, 5X, 5H NONE, 11X, 5H NONE, - * 6X, G16.7, G16.4) - 3100 FORMAT(1X, 2A2, A1, I3, 10X, A2, 3G16.7, G16.7, G16.4) - 3200 FORMAT(1X, 2A2, A1, I3, 10X, A2, G16.7, - * 5X, 5H NONE, 6X, G16.7, G16.7, G16.4) - 3300 FORMAT(1X, 2A2, A1, I3, 10X, A2, 2G16.7, 5X, 5H NONE, 6X, - * G16.7, G16.4) - 3400 FORMAT(1X, 2A2, A1, I3, 10X, A2, G16.7, - * 5X, 5H NONE, 11X, 5H NONE, 6X, G16.7, G16.4) -C -C END OF PRTSOL - END
deleted file mode 100644 --- a/libcruft/qpsol/qpchkp.f +++ /dev/null @@ -1,55 +0,0 @@ -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -C FILE QPSUBS66 FORTRAN -C -C QPCHKP QPCOLR QPCORE QPCRSH QPDUMP QPGRAD QPPRT -C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - SUBROUTINE QPCHKP( N, NCLIN, NCLIN0, ISSAVE, JDSAVE, AP, P ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER N, NCLIN, NCLIN0, ISSAVE, JDSAVE - DOUBLE PRECISION AP(NCLIN0), P(N) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C QPCHKP IS CALLED WHEN A CONSTRAINT HAS JUST BEEN DELETED AND THE -C SIGN OF THE SEARCH DIRECTION P MAY BE INCORRECT BECAUSE OF ROUNDING -C ERRORS IN THE COMPUTATION OF THE PROJECTED GRADIENT ZTG. THE SIGN -C OF THE SEARCH DIRECTION (AND THEREFORE THE PRODUCT AP) IS FIXED BY -C FORCING P TO SATISFY THE CONSTRAINT (WITH INDEX JDSAVE) THAT WAS -C JUST DELETED. VARIABLES THAT WERE HELD TEMPORARILY FIXED (WITH -C ISTATE = 4) ARE NOT CHECKED FOR FEASIBILITY. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION DECEMBER 1982. -C ********************************************************************* -C - INTEGER IDEL - DOUBLE PRECISION ATP, ONE, ZERO - DATA ZERO, ONE /0.0D+0, 1.0D+0/ -C - IF (ISSAVE .EQ. 4) GO TO 900 -C - IDEL = JDSAVE - N - IF (JDSAVE .LE. N) ATP = P(JDSAVE) - IF (JDSAVE .GT. N) ATP = AP(IDEL) -C - IF (MSG .GE. 80) WRITE (NOUT, 1000) JDSAVE, ISSAVE, ATP -C - IF ( ISSAVE .EQ. 2 .AND. ATP .LE. ZERO - * .OR. ISSAVE .EQ. 1 .AND. ATP .GE. ZERO) GO TO 900 -C -C REVERSE THE DIRECTION OF P AND AP. -C - CALL SSCALE( N, (- ONE), P, N, 1 ) - IF (NCLIN .GT. 0) - *CALL SSCALE( NCLIN, (- ONE), AP, NCLIN, 1 ) -C - 900 RETURN -C - 1000 FORMAT(/ 42H //QPCHKP // JDSAVE ISSAVE ATP - * / 13H //QPCHKP // , 2I7, G15.5 ) -C -C END OF QPCHKP - END
deleted file mode 100644 --- a/libcruft/qpsol/qpcolr.f +++ /dev/null @@ -1,197 +0,0 @@ - SUBROUTINE QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS, - * N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH, - * NROWRT, NCOLRT, NHESS, KFREE, - * CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST, - * HESS, RT, SCALE, ZY, HZ, WRK ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH, - * NROWRT, NCOLRT, NHESS - INTEGER KFREE(N) - DOUBLE PRECISION CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST - DOUBLE PRECISION HESS(NROWH,NCOLH), RT(NROWRT,NCOLRT), HZ(N), - * SCALE(NCTOTL), ZY(NQ,NQ) - DOUBLE PRECISION WRK(N) - LOGICAL NOCURV, POSDEF, RENEWR, UNITQ - EXTERNAL QPHESS -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART -C - LOGICAL SCLDQP - COMMON /SOL2LP/ SCLDQP -C -C ********************************************************************* -C QPCOLR IS USED TO COMPUTE ELEMENTS OF THE (NCOLR)-TH COLUMN OF R, -C THE CHOLESKY FACTOR OF THE PROJECTED HESSIAN. IF RENEWR IS TRUE -C ON ENTRY, THE COMPLETE COLUMN IS TO BE COMPUTED. OTHERWISE, ONLY -C THE LAST DIAGONAL ELEMENT IS REQUIRED. -C IF THE RESULTING PROJECTED HESSIAN IS SINGULAR OR INDEFINITE, ITS -C LAST DIAGONAL ELEMENT IS INCREASED BY AN AMOUNT EMAX THAT ENSURES -C POSITIVE DEFINITENESS. THIS DIAGONAL MODIFICATION WILL ALTER THE -C SCALE OF THE QP SEARCH VECTOR P, BUT NOT ITS DIRECTION. -C -C ON EXIT, QPCOLR WILL HAVE STORED THE NCOLR ELEMENTS OF THE NEW -C COLUMN OF R IN THE ARRAY RT, AND SET THE VARIABLES NOCURV, -C POSDEF, RENEWR, DRMAX, EMAX AND HSIZE. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION MARCH 1982. REV. APRIL 1982. -C ********************************************************************* -C - INTEGER J, JTHCOL, K, NCOLR1 - DOUBLE PRECISION EPSMCH, RDSMAX, RDSMIN, RDSQ, RNORM, S, ZTHZ - DOUBLE PRECISION ZERO, ONE, TWO, TEN - DOUBLE PRECISION DSQRT, V2NORM - DOUBLE PRECISION DABS, DMAX1 - DATA ZERO , ONE , TWO , TEN - * /0.0D+0, 1.0D+0, 2.0D+0, 10.0D+0/ -C - EPSMCH = WMACH(3) -C - IF (RENEWR) GO TO 300 -C -C --------------------------------------------------------------------- -C ONLY THE LAST ELEMENT OF THE NEW COLUMN OF R NEED BE COMPUTED. -C THIS SITUATION CAN ONLY OCCUR WHEN A CONSTRAINT IS ADDED TO THE -C WORKING SET WITH ZTHZ NOT POSITIVE DEFINITE. -C --------------------------------------------------------------------- -C THE LAST DIAGONAL ELEMENT OF R IS THAT OF ZTHZ PLUS A DIAGONAL -C MODIFICATION. THE SQUARE OF THE TRUE DIAGONAL IS RECOVERED FROM THE -C ROTATIONS USED TO UPDATE R WHEN THE CONSTRAINT WAS ADDED TO THE -C WORKING SET. -C - RDLAST = RT(NCOLR,NCOLR) - S = DABS( SNLAST ) - RDSQ = ( (CSLAST - S)*RDLAST )*( (CSLAST + S)*RDLAST ) - GO TO 600 -C -C --------------------------------------------------------------------- -C THE PROJECTED HESSIAN IS EXPANDED BY A ROW AND COLUMN. COMPUTE THE -C FIRST (NCOLR - 1) ELEMENTS OF THE NEW COLUMN OF THE CHOLESKY FACTOR -C R. ALSO, COMPUTE RDSQ, THE SQUARE OF THE LAST DIAGONAL ELEMENT. -C --------------------------------------------------------------------- - 300 CALL ZEROVC( N, WRK, N, 1 ) - IF (UNITQ) GO TO 320 -C -C EXPAND THE NEW COLUMN OF Z IN TO AN N-VECTOR. -C - DO 310 K = 1, NFREE - J = KFREE(K) - WRK(J) = ZY(K,NCOLR) - 310 CONTINUE - IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK, N, 1 ) - JTHCOL = 0 - GO TO 330 -C -C ONLY BOUNDS ARE IN THE WORKING SET (NFREE IS EQUAL TO NCOLZ). THE -C (NCOLR)-TH COLUMN OF Z IS JUST A COLUMN OF THE IDENTITY MATRIX. -C - 320 JTHCOL = KFREE(NCOLR) - WRK(JTHCOL) = ONE -C -C COMPUTE THE HESSIAN TIMES THE LAST COLUMN OF Z. -C - 330 CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK, HZ ) - NHESS = NHESS + 1 -C - IF (UNITQ .AND. SCLDQP) CALL SSCALE( N, SCALE(JTHCOL), HZ, N,1 ) - IF ( SCLDQP) CALL DSCALE( N, SCALE, N, 1, HZ, N,1 ) -C -C COMPUTE THE (NCOLR)-TH COLUMN OF Z(T)H Z. -C - CALL ZYPROD( 4, N, NFREE, NCOLR, NFREE, NQ, UNITQ, - * KFREE, KFREE, HZ, ZY, WRK ) -C - CALL COPYVC( NCOLR, HZ, NCOLR, 1, RT(1,NCOLR), NCOLR, 1 ) -C -C COMPUTE THE FIRST (NCOLR - 1) ELEMENTS OF THE LAST COLUMN OF R. -C - NCOLR1 = NCOLR - 1 - ZTHZ = RT(NCOLR,NCOLR) - RDSQ = ZTHZ - IF (NCOLR1 .EQ. 0) GO TO 370 - CALL RSOLVE( 2, NROWRT, NCOLR1, RT, RT(1,NCOLR) ) - RNORM = V2NORM( NCOLR1, RT(1,NCOLR), NCOLR1, 1 ) -C -C COMPUTE THE SQUARE OF THE LAST DIAGONAL ELEMENT OF R. -C - RDSQ = ZTHZ - RNORM*RNORM -C -C UPDATE THE ESTIMATE OF THE NORM OF THE HESSIAN. -C - 370 HSIZE = DMAX1( HSIZE, DABS( ZTHZ ) ) -C -C --------------------------------------------------------------------- -C COMPUTE RDLAST, THE LAST DIAGONAL OF R. THE VARIABLES POSDEF AND -C NOCURV ARE SET HERE. THEY ARE USED TO INDICATE IF THE NEW PROJECTED -C HESSIAN IS POSITIVE DEFINITE OR SINGULAR. IF POSDEF IS SET TO -C FALSE, RDLAST WILL BE THAT OF ZTHZ PLUS A DIAGONAL MODIFICATION. -C IF THE REQUIRED DIAGONAL MODIFICATION IS LARGE, RENEWR WILL BE SET -C TO BE TRUE, INDICATING THAT THE LAST ROW AND COLUMN OF R MUST BE -C RECOMPUTED WHEN A CONSTRAINT IS ADDED TO THE WORKING SET DURING THE -C NEXT ITERATION. -C --------------------------------------------------------------------- - 600 NOCURV = .FALSE. - RENEWR = .FALSE. - EMAX = ZERO -C -C RDSMIN IS THE SQUARE OF THE SMALLEST ALLOWABLE DIAGONAL ELEMENT -C FOR A POSITIVE-DEFINITE CHOLESKY FACTOR. NOTE THAT THE TEST FOR A -C SINGULAR MATRIX IS SCALE DEPENDENT. -C - IF (NCOLR .EQ. 1) RDSMIN = EPSMCH*HSIZE - IF (NCOLR .GT. 1) RDSMIN = (EPSMCH*DRMAX) * DRMAX - POSDEF = RDSQ .GT. RDSMIN - IF (POSDEF) GO TO 900 -C - IF (RDSQ .LT. ( - RDSMIN )) GO TO 610 -C -C --------------------------------------------------------------------- -C THE PROJECTED HESSIAN IS SINGULAR. -C --------------------------------------------------------------------- -C THE QUADRATIC HAS NO CURVATURE ALONG AT LEAST ONE DIRECTION. THE -C PERTURBATION EMAX IS CHOSEN TO MAKE THE NEW EIGENVALUE OF ZTHZ -C SMALL AND POSITIVE. -C - EMAX = RDSMIN - RDSQ - RDSQ = RDSMIN - NOCURV = .TRUE. - GO TO 900 -C -C --------------------------------------------------------------------- -C THE PROJECTED HESSIAN IS INDEFINITE. THERE ARE TWO CASES. -C --------------------------------------------------------------------- -C CASE 1. THE MODULUS OF THE NEW LAST DIAGONAL OF R IS NOT TOO -C LARGE. THE MODULUS OF RDSQ IS USED FOR THE SQUARE ROOT. -C - 610 RDSMAX = TEN * HSIZE - IF (RDSQ .LT. ( - RDSMAX )) GO TO 620 - EMAX = - TWO*RDSQ - GO TO 900 -C -C CASE 2. THE MODULUS OF THE LAST DIAGONAL OF R IS JUDGED TO BE TOO -C LARGE (SOME LOSS OF PRECISION MAY HAVE OCCURRED). SET RENEWR SO -C THAT THE LAST COLUMN IS RECOMPUTED LATER. -C - 620 EMAX = RDSMAX - RDSQ - RENEWR = .TRUE. - RDSQ = RDSMAX -C -C COMPUTE THE LAST DIAGONAL ELEMENT. -C - 900 RDLAST = DSQRT( DABS( RDSQ ) ) - RT(NCOLR,NCOLR) = RDLAST -C - IF (MSG .GE. 80 .AND. (.NOT. POSDEF)) - *WRITE (NOUT, 9000) POSDEF, NOCURV, EMAX, RDLAST -C - RETURN -C - 9000 FORMAT(/ 54H //QPCOLR// POSDEF NOCURV EMAX RDLAST - * / 13H //QPCOLR// , L6, 1X, L6, 2(1PE14.4) ) -C -C END OF QPCOLR - END
deleted file mode 100644 --- a/libcruft/qpsol/qpcore.f +++ /dev/null @@ -1,590 +0,0 @@ - SUBROUTINE QPCORE( NAMED, ORTHOG, UNITQ, INFORM, ITER, ITMAX, - * N, NCLIN, NCTOTL, NROWA, NROWH, NCOLH, - * NACTIV, NFREE, QPHESS, ISTATE, KACTIV, KFREE, - * OBJQP, XNORM, - * A, AX, BL, BU, CLAMDA, CVEC, - * FEATOL, HESS, SCALE, X, IW, LIW, W, LW ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER INFORM, ITER, ITMAX, N, NCLIN, NCTOTL, NROWA, - * NROWH, NCOLH, NACTIV, NFREE, LIW, LW - INTEGER ISTATE(NCTOTL), KACTIV(N), KFREE(N) - INTEGER IW(LIW) - DOUBLE PRECISION ASIZE, DTMAX, DTMIN, OBJQP, XNORM - DOUBLE PRECISION A(NROWA,N), AX(NROWA), BL(NCTOTL), BU(NCTOTL), - * CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL), - * HESS(NROWH,NCOLH), SCALE(NCTOTL), X(N) - DOUBLE PRECISION W(LW) - LOGICAL NAMED, ORTHOG, UNITQ - EXTERNAL QPHESS -C - INTEGER NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ - DOUBLE PRECISION PARM, WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ - COMMON /SOL4CM/ PARM(10) - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C - INTEGER LOCLP - COMMON /SOL1LP/ LOCLP(15) -C -C ********************************************************************* -C QPCORE, A SUBROUTINE FOR INDEFINITE QUADRATIC PROGRAMMING. -C IT IS ASSUMED THAT A PREVIOUS CALL TO EITHER LPCORE OR QPCORE -C HAS DEFINED AN INITIAL WORKING SET OF LINEAR CONSTRAINTS AND BOUNDS. -C ISTATE, KACTIV AND KFREE WILL HAVE BEEN SET ACCORDINGLY, -C AND THE ARRAYS RT AND ZY WILL CONTAIN THE TQ FACTORIZATION -C OF THE MATRIX WHOSE ROWS ARE THE GRADIENTS OF THE ACTIVE LINEAR -C CONSTRAINTS WITH THE COLUMNS CORRESPONDING TO THE ACTIVE BOUNDS -C REMOVED. THE TQ FACTORIZATION OF THE RESULTING (NACTIV BY NFREE) -C MATRIX IS A(FREE)*Q = (0 T), WHERE Q IS (NFREE BY NFREE) AND T -C IS REVERSE-TRIANGULAR. -C -C VALUES OF ISTATE(J) FOR THE LINEAR CONSTRAINTS....... -C -C ISTATE(J) -C --------- -C 0 CONSTRAINT J IS NOT IN THE WORKING SET. -C 1 CONSTRAINT J IS IN THE WORKING SET AT ITS LOWER BOUND. -C 2 CONSTRAINT J IS IN THE WORKING SET AT ITS UPPER BOUND. -C 3 CONSTRAINT J IS IN THE WORKING SET AS AN EQUALITY. -C 4 THE J-TH VARIABLE IS TEMPORARILY FIXED AT THE VALUE X(J). -C THE CORRESPONDING ARTIFICIAL BOUND IS INCLUDED IN THE -C WORKING SET (THE TQ FACTORIZATION IS ADJUSTED -C ACCORDINGLY). -C -C CONSTRAINT J MAY BE VIOLATED BY AS MUCH AS FEATOL(J). -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION 1 OF DECEMBER 1981. -C VERSION 2 OF JUNE 1982. -C VERSION 3 OF JANUARY 1983. -C VERSION 3.1 OF APRIL 1983. -C VERSION 3.2 OF APRIL 1984. -C -C COPYRIGHT 1983 STANFORD UNIVERSITY. -C -C THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU- -C ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR). -C -C THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL -C SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE -C DEPARTMENT OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03- -C 76ER72018; AND THE ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110. -C -C ********************************************************************* -C - INTEGER IADD, IDUMMY, IFIX, ISDEL, ISSAVE, JADD, JDEL, - * JDSAVE, JSMLST, KB, KDEL, KGFIX, KSMLST, - * LANORM, LAP, LENR, LNAMES, LPROB, LPX, LQTG, - * LRLAM, LROWA, LRT, LWRK, LZY, MODE, MSGLVL, - * MSTALL, NCNLN, NCLIN0, NCOLR, NCOLZ, NFIXED, - * NHESS, NROWJ, NSTALL, NUMINF - INTEGER MAX0 - DOUBLE PRECISION ALFA, ALFHIT, ANORM, ATPHIT, BIGALF, BIGBND, - * BIGDX, BND, CONDH, CONDMX, CONDT, CSLAST, - * DINKY, DRMAX, DRMIN, EMAX, EPSMCH, EPSPT9, - * FLMAX, GFIXED, GFNORM, GTP, HSIZE, - * OBJSIZ, PALFA, PNORM, RDLAST, RTMAX, SMLLST, - * SNLAST, ZTGNRM - DOUBLE PRECISION DSQRT, QUOTNT, V2NORM - DOUBLE PRECISION DABS, DMAX1 - LOGICAL FIRSTV, HITLOW, MODFYG, MODFYR, - * NOCURV, NULLR, POSDEF, REFINE, RENEWR, STALL, - * UNCON, UNITPG, ZEROLM - DOUBLE PRECISION ZERO , ONE - DATA ZERO , ONE - * /0.0D+0, 1.0D+0/ - DATA LPROB / 2HQP / - DATA MSTALL / 50 / -C -C SPECIFY MACHINE-DEPENDENT PARAMETERS. -C - EPSMCH = WMACH(3) - FLMAX = WMACH(7) - RTMAX = WMACH(8) -C - LNAMES = LOCLP( 1) - LANORM = LOCLP( 4) - LAP = LOCLP( 5) - LPX = LOCLP( 6) - LQTG = LOCLP( 7) - LRLAM = LOCLP( 8) - LRT = LOCLP( 9) - LZY = LOCLP(10) - LWRK = LOCLP(11) -C -C INITIALIZE -C - INFORM = 0 - ITER = 0 - JADD = 0 - JDEL = 0 - JDSAVE = 0 - LROWA = NROWA*(N - 1) + 1 - NCLIN0 = MAX0( NCLIN, 1 ) - NCNLN = 0 - NCOLZ = NFREE - NACTIV - NROWJ = 1 - NSTALL = 0 - NHESS = 0 - NUMINF = 0 -C - MSGLVL = MSG - MSG = 0 - IF (ISTART .EQ. 0) MSG = MSGLVL -C - BIGBND = PARM(1) - BIGDX = PARM(2) - EPSPT9 = PARM(4) -C - ALFA = ZERO - CONDMX = FLMAX - DRMAX = ONE - DRMIN = ONE - EMAX = ZERO - HSIZE = ONE -C - FIRSTV = .FALSE. - MODFYR = .TRUE. - MODFYG = .TRUE. - NOCURV = .FALSE. - NULLR = .FALSE. - POSDEF = .TRUE. - REFINE = .FALSE. - STALL = .TRUE. - UNCON = .FALSE. - UNITPG = .FALSE. - ZEROLM = .FALSE. -C -C --------------------------------------------------------------------- -C GIVEN THE TQ FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE -C WORKING SET, COMPUTE THE FOLLOWING QUANTITIES.... -C (1) THE CHOLESKY FACTOR R, OF Z(T)HZ (IF Z(T)HZ IS NOT POSITIVE -C DEFINITE, FIND A POSITIVE-DEFINITE (NCOLR)-TH ORDER PRINCIPAL -C SUBMATRIX OF Z(T)H Z, -C (2) THE QP OBJECTIVE FUNCTION, -C (3) THE VECTOR Q(FREE)(T)G(FREE), -C (4) THE VECTOR G(FIXED). -C -C USE THE ARRAY RLAM AS TEMPORARY WORK SPACE. -C --------------------------------------------------------------------- - CALL QPCRSH( UNITQ, QPHESS, N, NCOLR, NCOLZ, NCTOTL, NFREE, - * NHESS, NQ, NROWH, NCOLH, NROWRT, NCOLRT, - * KFREE, HSIZE, - * HESS, W(LRT), SCALE, W(LZY), W(LRLAM), W(LWRK) ) -C - MODE = 1 - CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV, - * NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD, - * KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP, - * CVEC, HESS, W(LPX), W(LQTG), SCALE, X, - * W(LZY), W(LWRK), W(LRLAM) ) -C -C .......................START OF THE MAIN LOOP........................ -C -C DURING THE MAIN LOOP, ONE OF THREE THINGS WILL HAPPEN -C ( I) THE CONVERGENCE CRITERION WILL BE SATISFIED AND THE ALGORITHM -C WILL TERMINATE. -C ( II) A LINEAR CONSTRAINT WILL BE DELETED. -C (III) A DIRECTION OF SEARCH WILL BE COMPUTED AND A CONSTRAINT MAY -C BE ADDED TO THE WORKING SET (NOTE THAT A ZERO STEP MAY BE TAKEN -C ALONG THE SEARCH DIRECTION). -C -C THESE COMPUTATIONS OCCUR IN SECTIONS I, II, AND III OF THE MAIN LOOP. -C -C --------------------------------------------------------------------- -C ******* SECTION I. TEST FOR CONVERGENCE ************************** -C --------------------------------------------------------------------- -C COMPUTE THE NORMS OF THE PROJECTED GRADIENT AND THE GRADIENT WITH -C RESPECT TO THE FREE VARIABLES. -C - 100 ZTGNRM = ZERO - IF (NCOLR .GT. 0) ZTGNRM = V2NORM( NCOLR, W(LQTG), NCOLR, 1 ) - GFNORM = ZTGNRM - IF (NFREE .GT. 0 .AND. NACTIV .GT. 0) - * GFNORM = V2NORM( NFREE, W(LQTG), NFREE, 1 ) -C -C DEFINE SMALL QUANTITIES THAT REFLECT THE MAGNITUDE OF C, X, H -C AND THE MATRIX OF CONSTRAINTS IN THE WORKING SET. -C - OBJSIZ = (EPSMCH + DABS( OBJQP )) / (EPSMCH + XNORM) - ANORM = ZERO - IF (NACTIV .GT. 0) ANORM = DABS( DTMAX ) - DINKY = EPSPT9 * DMAX1( ANORM, OBJSIZ, GFNORM ) -C - IF (MSG .GE. 80) WRITE (NOUT, 9000) ZTGNRM, DINKY -C -C --------------------------------------------------------------------- -C PRINT THE DETAILS OF THIS ITERATION. -C --------------------------------------------------------------------- -C USE THE LARGEST AND SMALLEST DIAGONALS OF R TO ESTIMATE THE -C CONDITION NUMBER OF THE PROJECTED HESSIAN MATRIX. -C - CONDT = QUOTNT( DTMAX, DTMIN ) -C - LENR = NROWRT*NCOLR - IF (NCOLR .GT. 0) - * CALL CONDVC( NCOLR, W(LRT), LENR, NROWRT + 1, DRMAX, DRMIN ) - CONDH = QUOTNT( DRMAX, DRMIN ) - IF (CONDH .GE. RTMAX) CONDH = FLMAX - IF (CONDH .LT. RTMAX) CONDH = CONDH*CONDH -C - CALL QPPRT ( ORTHOG, ISDEL, ITER, JADD, JDEL, NACTIV, - * NCOLR, NCOLZ, NFREE, N, NCLIN, NCLIN0, NCTOTL, - * NROWA, NROWRT, NCOLRT, NHESS, - * ISTATE, KFREE, - * ALFA, CONDH, CONDT, OBJQP, GFNORM, ZTGNRM, EMAX, - * A, W(LRT), X, W(LWRK), W(LAP) ) -C - JADD = 0 - JDEL = 0 -C - IF (.NOT. POSDEF) GO TO 300 - IF (ZTGNRM .LE. DINKY) UNITPG = .TRUE. - IF (ZTGNRM .LE. DINKY) GO TO 110 -C - IF (.NOT. UNCON) REFINE = .FALSE. - IF (.NOT. UNCON) GO TO 300 -C - IF (UNITPG) UNITPG = .FALSE. -C - IF (ZTGNRM .LE. DSQRT(DINKY)) GO TO 110 -C - IF (REFINE) GO TO 110 -C - REFINE = .TRUE. - GO TO 300 -C -C --------------------------------------------------------------------- -C THE PROJECTED GRADIENT IS NEGLIGIBLE AND THE PROJECTED HESSIAN -C IS POSITIVE DEFINITE. IF R IS NOT COMPLETE IT MUST BE -C EXPANDED. OTHERWISE, IF THE CURRENT POINT IS NOT OPTIMAL, -C A CONSTRAINT MUST BE DELETED FROM THE WORKING SET. -C --------------------------------------------------------------------- - 110 ALFA = ZERO - UNCON = .FALSE. - REFINE = .FALSE. - JDEL = - (NCOLR + 1) - IF (NCOLR .LT. NCOLZ) GO TO 220 -C - CALL GETLAM( LPROB, N, NCLIN0, NCTOTL, - * NACTIV, NCOLZ, NFREE, NROWA, - * NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST, - * ISTATE, KACTIV, - * A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) ) -C -C --------------------------------------------------------------------- -C TEST FOR CONVERGENCE. IF THE LEAST (ADJUSTED) MULTIPLIER IS GREATER -C THAN THE SMALL POSITIVE QUANTITY DINKY, AN ADEQUATE SOLUTION HAS -C BEEN FOUND. -C --------------------------------------------------------------------- - IF (SMLLST .GT. DINKY) GO TO 900 -C -C --------------------------------------------------------------------- -C ******* SECTION II. DELETE A CONSTRAINT FROM THE WORKING SET ***** -C --------------------------------------------------------------------- -C DELETE THE CONSTRAINT WITH THE LEAST (ADJUSTED) MULTIPLIER. -C -C FIRST CHECK IF THERE ARE ANY TINY MULTIPLIERS -C - IF (SMLLST .GT. ( - DINKY )) ZEROLM = .TRUE. - JDEL = JSMLST - JDSAVE = JSMLST - KDEL = KSMLST - ISDEL = ISTATE(JDEL) - ISSAVE = ISDEL - ISTATE(JDEL) = 0 -C -C UPDATE THE TQ FACTORIZATION OF THE MATRIX OF CONSTRAINTS IN THE -C WORKING SET. -C - CALL DELCON( MODFYG, ORTHOG, UNITQ, - * JDEL, KDEL, NACTIV, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, - * KACTIV, KFREE, - * A, W(LQTG), W(LRT), W(LZY) ) -C - NCOLZ = NCOLZ + 1 - IF (JDEL .LE. N) NFREE = NFREE + 1 - IF (JDEL .GT. N) NACTIV = NACTIV - 1 -C -C --------------------------------------------------------------------- -C THE PROJECTED HESSIAN IS EXPANDED BY A ROW AND COLUMN. COMPUTE THE -C ELEMENTS OF THE NEW COLUMN OF THE CHOLESKY FACTOR R. -C USE THE ARRAY P AS TEMPORARY WORK SPACE. -C --------------------------------------------------------------------- - 220 RENEWR = .TRUE. - NCOLR = NCOLR + 1 - CALL QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS, - * N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH, - * NROWRT, NCOLRT, NHESS, KFREE, - * CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST, - * HESS, W(LRT), SCALE, W(LZY), W(LPX), W(LWRK) ) -C -C REPEAT THE MAIN LOOP. -C - GO TO 100 -C -C --------------------------------------------------------------------- -C ******* SECTION III. COMPUTE THE SEARCH DIRECTION ******* -C --------------------------------------------------------------------- -C FIRST, CHECK FOR A WEAK LOCAL MINIMUM. EXIT IF THE NORM OF THE -C PROJECTED GRADIENT IS SMALL AND THE CURVATURE ALONG P IS NOT -C SIGNIFICANT. ALSO, CHECK FOR TOO MANY ITERATIONS AND UPDATE THE -C ITERATION COUNT. THE ITERATION COUNTER IS ONLY UPDATED WHEN A SEARCH -C DIRECTION IS COMPUTED. -C - 300 IF(ZTGNRM .LT. DINKY .AND. NCOLR .EQ. NCOLZ .AND. NOCURV)GO TO 910 - IF (ZEROLM .AND. NOCURV) GO TO 910 - IF (ITER .GE. ITMAX) GO TO 950 - ITER = ITER + 1 - IF (ITER .GE. ISTART) MSG = MSGLVL -C - CALL FINDP ( NULLR, UNITPG, UNITQ, - * N, NCLIN, NCLIN0, NCTOTL, NQ, - * NROWA, NROWRT, NCOLRT, NCOLR, NCOLZ, NFREE, - * ISTATE, KFREE, - * DINKY, GTP, PNORM, RDLAST, ZTGNRM, - * A, W(LAP), W(LPX), W(LQTG), W(LRT), W(LWRK), - * W(LZY), W(LWRK) ) -C -C IF A CONSTRAINT HAS JUST BEEN DELETED AND THE PROJECTED GRADIENT IS -C SMALL (THIS CAN ONLY OCCUR HERE WHEN THE PROJECTED HESSIAN IS -C INDEFINITE), THE SIGN OF P MAY BE INCORRECT BECAUSE OF ROUNDING -C ERRORS IN THE COMPUTATION OF ZTG. FIX THE SIGN OF P BY FORCING IT -C TO SATISFY THE CONSTRAINT THAT WAS JUST DELETED. -C - IF ((JDSAVE .GT. 0 .AND. ZTGNRM .LE. DINKY) .OR. ZEROLM) - *CALL QPCHKP( N, NCLIN, NCLIN0, ISSAVE, JDSAVE, W(LAP), W(LPX) ) -C -C --------------------------------------------------------------------- -C FIND THE CONSTRAINT WE BUMP INTO ALONG P. -C UPDATE X AND A*X IF THE STEP ALFA IS NONZERO. -C --------------------------------------------------------------------- -C ALFHIT IS INITIALIZED TO BIGALF. IF IT REMAINS THAT WAY AFTER -C THE CALL TO BNDALF, IT WILL BE REGARDED AS INFINITE. -C - BIGALF = QUOTNT( BIGDX, PNORM ) -C - CALL BNDALF( FIRSTV, HITLOW, ISTATE, INFORM, JADD, - * N, NROWA, NCLIN, NCLIN0, NCTOTL, NUMINF, - * ALFHIT, PALFA, ATPHIT, BIGALF, BIGBND, PNORM, - * W(LANORM), W(LAP), AX, BL, BU, FEATOL, W(LPX), X ) -C -C IF THE PROJECTED HESSIAN IS POSITIVE DEFINITE, THE STEP ALFA = 1.0 -C WILL BE THE STEP TO THE MINIMUM OF THE QUADRATIC FUNCTION ON THE -C CURRENT SUBSPACE. -C - ALFA = ONE -C -C IF THE STEP TO THE MINIMUM ON THE SUBSPACE IS LESS THAN THE DISTANCE -C TO THE NEAREST CONSTRAINT, THE CONSTRAINT IS NOT ADDED TO THE -C WORKING SET. -C - UNCON = PALFA .GT. ONE .AND. POSDEF - IF ( UNCON) JADD = 0 - IF (.NOT. UNCON) ALFA = ALFHIT -C -C CHECK FOR AN UNBOUNDED SOLUTION. -C - IF (ALFA .GE. BIGALF) GO TO 920 -C -C TEST IF THE CHANGE IN X IS NEGLIGIBLE. -C - STALL = DABS( ALFA*PNORM ) .LE. EPSPT9*XNORM - IF (.NOT. STALL) GO TO 410 -C -C TAKE A ZERO STEP. -C EXIT IF MORE THAN 50 ITERATIONS OCCUR WITHOUT CHANGING X. IF SUCH -C AN EXIT IS MADE WHEN THERE ARE SOME NEAR-ZERO MULTIPLIERS, THE USER -C SHOULD CALL A SEPARATE ROUTINE THAT CHECKS THE SOLUTION. -C - ALFA = ZERO - NSTALL = NSTALL + 1 - IF (NSTALL .LE. MSTALL) GO TO 420 - GO TO 940 -C -C --------------------------------------------------------------------- -C COMPUTE THE NEW VALUE OF THE QP OBJECTIVE FUNCTION. IF ITS VALUE HAS -C NOT INCREASED, UPDATE OBJQP, Q(FREE)(T)G(FREE) AND G(FIXED). -C AN INCREASE IN THE OBJECTIVE CAN OCCUR ONLY AFTER A MOVE ALONG -C A DIRECTION OF NEGATIVE CURVATURE FROM A POINT WITH TINY MULTIPLIERS. -C USE THE ARRAY RLAM AS TEMPORARY STORAGE. -C --------------------------------------------------------------------- - 410 MODE = 2 - CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV, - * NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD, - * KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP, - * CVEC, HESS, W(LPX), W(LQTG), SCALE, X, - * W(LZY), W(LWRK), W(LRLAM) ) -C - IF (MODE .LT. 0) GO TO 910 -C -C CHANGE X TO X + ALFA*P. UPDATE AX ALSO. -C WE NO LONGER NEED TO REMEMBER JDSAVE, THE LAST CONSTRAINT DELETED. -C - NSTALL = 0 - JDSAVE = 0 - ZEROLM = .FALSE. -C - CALL AXPY ( N , ALFA, W(LPX), N , 1, X , N , 1 ) - IF (NCLIN .GT. 0) - *CALL AXPY ( NCLIN, ALFA, W(LAP), NCLIN, 1, AX, NCLIN, 1 ) -C - XNORM = V2NORM( N, X, N, 1 ) -C -C IF AN UNCONSTRAINED STEP WAS TAKEN, REPEAT THE MAIN LOOP. -C - 420 IF (UNCON) GO TO 100 -C -C --------------------------------------------------------------------- -C ADD A CONSTRAINT TO THE WORKING SET. -C --------------------------------------------------------------------- -C UPDATE ISTATE. -C - IF ( HITLOW) ISTATE(JADD) = 1 - IF (.NOT. HITLOW) ISTATE(JADD) = 2 - IF (BL(JADD) .EQ. BU(JADD)) ISTATE(JADD) = 3 -C -C IF A BOUND IS TO BE ADDED, MOVE X EXACTLY ONTO IT, EXCEPT WHEN -C A NEGATIVE STEP WAS TAKEN. (BNDALF MAY HAVE HAD TO MOVE TO SOME -C OTHER CLOSER CONSTRAINT.) -C - IADD = JADD - N - IF (JADD .GT. N) GO TO 520 - IF ( HITLOW) BND = BL(JADD) - IF (.NOT. HITLOW) BND = BU(JADD) - IF (ALFA .GE. ZERO) X(JADD) = BND -C - DO 510 IFIX = 1, NFREE - IF (KFREE(IFIX) .EQ. JADD) GO TO 520 - 510 CONTINUE -C -C UPDATE THE TQ FACTORS OF THE MATRIX OF CONSTRAINTS IN THE WORKING -C SET. USE THE ARRAY P AS TEMPORARY WORK SPACE. -C - 520 CALL ADDCON( MODFYG, MODFYR, ORTHOG, UNITQ, INFORM, - * IFIX, IADD, JADD, NACTIV, NCOLR, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, KFREE, - * CONDMX, CSLAST, SNLAST, - * A, W(LQTG), W(LRT), W(LZY), W(LWRK), W(LPX) ) -C - NCOLR = NCOLR - 1 - NCOLZ = NCOLZ - 1 - NFIXED = N - NFREE - IF (NFIXED .EQ. 0) GO TO 540 - KB = NACTIV + NFIXED - DO 530 IDUMMY = 1, NFIXED - KACTIV(KB+1) = KACTIV(KB) - KB = KB - 1 - 530 CONTINUE - 540 IF (JADD .GT. N) GO TO 550 -C -C ADD A BOUND. IF STABILIZED ELIMINATIONS ARE BEING USED TO UPDATE -C THE TQ FACTORIZATION, RECOMPUTE THE COMPONENT OF THE GRADIENT -C CORRESPONDING TO THE NEWLY FIXED VARIABLE. -C USE THE ARRAY P AS TEMPORARY WORK SPACE. -C - NFREE = NFREE - 1 - KACTIV(NACTIV+1) = JADD - IF (ORTHOG) GO TO 560 -C - KGFIX = LQTG + NFREE - MODE = 3 - CALL QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV, - * NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD, - * KACTIV, KFREE, ALFA, OBJQP, W(KGFIX), GTP, - * CVEC, HESS, W(LPX), W(LQTG), SCALE, X, - * W(LZY), W(LWRK), W(LPX) ) -C - GO TO 560 -C -C ADD A GENERAL LINEAR CONSTRAINT. -C - 550 NACTIV = NACTIV + 1 - KACTIV(NACTIV) = IADD -C -C REPEAT THE MAIN LOOP IF THE PROJECTED HESSIAN THAT WAS USED TO -C COMPUTE THIS SEARCH DIRECTION WAS POSITIVE DEFINITE. -C - 560 IF (NCOLR .EQ. 0) POSDEF = .TRUE. - IF (NCOLR .EQ. 0) EMAX = ZERO -C -C --------------------------------------------------------------------- -C THE PROJECTED HESSIAN WAS NOT SUFFICIENTLY POSITIVE DEFINITE BEFORE -C THE CONSTRAINT WAS ADDED. EITHER COMPUTE THE TRUE VALUE OF THE LAST -C DIAGONAL OF R OR RECOMPUTE THE WHOLE OF ITS LAST COLUMN. -C USE THE ARRAY RLAM AS TEMPORARY WORK SPACE. -C --------------------------------------------------------------------- - IF (.NOT. POSDEF) - *CALL QPCOLR( NOCURV, POSDEF, RENEWR, UNITQ, QPHESS, - * N, NCOLR, NCTOTL, NFREE, NQ, NROWH, NCOLH, - * NROWRT, NCOLRT, NHESS, KFREE, - * CSLAST, SNLAST, DRMAX, EMAX, HSIZE, RDLAST, - * HESS, W(LRT), SCALE, W(LZY), W(LRLAM), W(LWRK) ) -C -C REPEAT THE MAIN LOOP. -C - GO TO 100 -C -C .........................END OF MAIN LOOP............................ -C -C OPTIMAL QP SOLUTION FOUND. -C - 900 INFORM = 0 - GO TO 960 -C -C WEAK LOCAL MINIMUM. -C - 910 INFORM = 1 - GO TO 960 -C -C UNBOUNDED QP. -C - 920 INFORM = 2 - GO TO 960 -C -C UNABLE TO VERIFY OPTIMALITY OF A STATIONARY POINT WITH TINY OR -C ZERO MULTIPLIERS. -C - 930 INFORM = 3 - GO TO 960 -C -C TOO MANY ITERATIONS WITHOUT CHANGING X. -C - 940 IF (ZEROLM) GO TO 930 - INFORM = 4 - GO TO 960 -C -C TOO MANY ITERATIONS. -C - 950 INFORM = 5 -C -C PRINT FULL SOLUTION. -C - 960 MSG = MSGLVL - IF (MSG .GE. 1) WRITE (NOUT, 1000) INFORM, ITER -C - IF (INFORM .GT. 0) - *CALL GETLAM( LPROB, N, NCLIN0, NCTOTL, - * NACTIV, NCOLZ, NFREE, NROWA, - * NROWRT, NCOLRT, JSMLST, KSMLST, SMLLST, - * ISTATE, KACTIV, - * A, W(LANORM), W(LQTG), W(LRLAM), W(LRT) ) -C - CALL PRTSOL( NFREE, NROWA, NROWJ, - * N, NCLIN, NCNLN, NCTOTL, BIGBND, - * NAMED, IW(LNAMES), LENNAM, - * NACTIV, ISTATE, KACTIV, - * A, BL, BU, X, CLAMDA, W(LRLAM), X ) -C - RETURN -C - 1000 FORMAT(/ 26H EXIT QP PHASE. INFORM =, I3, 9H ITER =, I4) - 9000 FORMAT(/ 34H //QPCORE// ZTGNRM DINKY - * / 11H //QPCORE//, 1P2E11.2 ) -C -C END OF QPCORE - END
deleted file mode 100644 --- a/libcruft/qpsol/qpcrsh.f +++ /dev/null @@ -1,188 +0,0 @@ - SUBROUTINE QPCRSH( UNITQ, QPHESS, N, NCOLR, NCOLZ, NCTOTL, NFREE, - * NHESS, NQ, NROWH, NCOLH, NROWRT, NCOLRT, - * KFREE, HSIZE, - * HESS, RT, SCALE, ZY, HZ, WRK ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER N, NCOLR, NCOLZ, NCTOTL, NFREE, NHESS, NQ, - * NROWH, NCOLH, NROWRT, NCOLRT - INTEGER KFREE(N) - DOUBLE PRECISION HSIZE - DOUBLE PRECISION HESS(NROWH,NCOLH), RT(NROWRT,NCOLRT), - * SCALE(NCTOTL), ZY(NQ,NQ), HZ(N) - DOUBLE PRECISION WRK(N) - LOGICAL UNITQ - EXTERNAL QPHESS -C - INTEGER NOUT, MSG, ISTART - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART -C - LOGICAL SCLDQP - COMMON /SOL2LP/ SCLDQP -C -C ********************************************************************* -C QPCRSH COMPUTES THE CHOLESKY FACTOR R OF THE PROJECTED HESSIAN -C Z(T) H Z, GIVEN Z AND ITS DIMENSIONS NFREE BY NCOLZ. -C IF THE PROJECTED HESSIAN IS INDEFINITE, A SMALLER CHOLESKY -C FACTORIZATION R1(T) R1 = Z1(T) H Z1 IS RETURNED, WHERE Z1 IS -C COMPOSED OF NCOLR COLUMNS OF Z. COLUMN INTERCHANGES ARE -C USED TO MAXIMIZE NCOLR. THESE ARE APPLIED TO Z. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION OF JANUARY 1983. -C ********************************************************************* -C - INTEGER I, J, JTHCOL, J1, K, KMAX, KSAVE, LEN, NUM - DOUBLE PRECISION D, DMAX, DMIN, EPSMCH, T - DOUBLE PRECISION DSQRT - DOUBLE PRECISION DABS, DMAX1 - DOUBLE PRECISION ZERO , ONE - DATA ZERO , ONE - * /0.0D+0, 1.0D+0/ -C - EPSMCH = WMACH(3) -C - NCOLR = 0 - IF (NCOLZ .EQ. 0) GO TO 900 -C -C --------------------------------------------------------------------- -C COMPUTE Z(T) H Z AND STORE THE UPPER-TRIANGULAR SYMMETRIC PART -C IN THE FIRST NCOLZ COLUMNS OF RT. -C --------------------------------------------------------------------- - DO 200 K = 1, NCOLZ - CALL ZEROVC( N, WRK, N, 1 ) - IF (UNITQ) GO TO 130 -C -C EXPAND THE COLUMN OF Z INTO AN N-VECTOR. -C - DO 120 I = 1, NFREE - J = KFREE(I) - WRK(J) = ZY(I,K) - 120 CONTINUE - IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK, N, 1 ) - JTHCOL = 0 - GO TO 150 -C -C ONLY BOUNDS ARE IN THE WORKING SET. THE K-TH COLUMN OF Z IS -C JUST A COLUMN OF THE IDENTITY MATRIX. -C - 130 JTHCOL = KFREE(K) - WRK(JTHCOL) = ONE -C -C SET RT(*,K) = TOP OF H * (COLUMN OF Z). -C - 150 CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK, HZ ) - NHESS = NHESS + 1 -C - IF (UNITQ .AND. SCLDQP) - * CALL SSCALE( N, SCALE(JTHCOL), HZ, N, 1 ) - IF (SCLDQP) - * CALL DSCALE( N, SCALE, N, 1, HZ, N, 1 ) -C - CALL ZYPROD( 4, N, NFREE, NCOLZ, NFREE, NQ, UNITQ, - * KFREE, KFREE, HZ, ZY, WRK ) -C - CALL COPYVC( NCOLZ, HZ, NCOLZ, 1, RT(1,K), NCOLZ, 1 ) -C -C UPDATE AN ESTIMATE OF THE SIZE OF THE PROJECTED HESSIAN. -C - HSIZE = DMAX1( HSIZE, DABS(RT(K,K)) ) - 200 CONTINUE -C -C --------------------------------------------------------------------- -C FORM THE CHOLESKY FACTORIZATION R(T) R = Z(T) H Z AS FAR AS -C POSSIBLE, USING SYMMETRIC ROW AND COLUMN INTERCHANGES. -C --------------------------------------------------------------------- - DMIN = EPSMCH * HSIZE -C - DO 400 J = 1, NCOLZ -C -C FIND THE MAXIMUM REMAINING DIAGONAL. -C - KMAX = J - DMAX = RT(J,J) - DO 310 K = J, NCOLZ - D = RT(K,K) - IF (DMAX .GE. D) GO TO 310 - DMAX = D - KMAX = K - 310 CONTINUE -C -C SEE IF THE DIAGONAL IS BIG ENOUGH. -C - IF (DMAX .LE. DMIN) GO TO 500 - NCOLR = J -C -C PERMUTE THE COLUMNS OF Z. -C - IF (KMAX .EQ. J) GO TO 350 - IF (UNITQ) GO TO 315 - CALL COPYVC( NFREE, ZY(1,KMAX), NFREE, 1, WRK , NFREE, 1 ) - CALL COPYVC( NFREE, ZY(1,J) , NFREE, 1, ZY(1,KMAX),NFREE, 1 ) - CALL COPYVC( NFREE, WRK , NFREE, 1, ZY(1,J) ,NFREE, 1 ) - GO TO 312 -C -C Z IS NOT STORED EXPLICITLY. -C - 315 KSAVE = KFREE(KMAX) - KFREE(KMAX) = KFREE(J) - KFREE(J) = KSAVE -C -C INTERCHANGE ROWS AND COLUMNS OF THE PROJECTED HESSIAN. -C - 312 DO 320 I = 1, J - T = RT(I,KMAX) - RT(I,KMAX) = RT(I,J) - RT(I,J) = T - 320 CONTINUE -C - DO 330 K = J, KMAX - T = RT(K,KMAX) - RT(K,KMAX) = RT(J,K) - RT(J,K) = T - 330 CONTINUE -C - DO 340 K = KMAX, NCOLZ - T = RT(KMAX,K) - RT(KMAX,K) = RT(J,K) - RT(J,K) = T - 340 CONTINUE -C - RT(KMAX,KMAX) = RT(J,J) -C -C SET THE DIAGONAL ELEMENT OF R. -C - 350 D = DSQRT(DMAX) - RT(J,J) = D - IF (J .EQ. NCOLZ) GO TO 400 -C -C SET THE ABOVE-DIAGONAL ELEMENTS OF THE K-TH ROW OF R, -C AND UPDATE THE ELEMENTS OF ALL REMAINING ROWS. -C - J1 = J + 1 - DO 360 K = J1, NCOLZ - T = RT(J,K)/D - RT(J,K) = T -C -C R(I,K) = R(I,K) - T * R(J,I), I = J1, K. -C - NUM = K - J - LEN = NROWRT*(NUM - 1) + 1 - IF (T .NE. ZERO) - * CALL AXPY( NUM, (- T), RT(J,J1), LEN, NROWRT, - * RT(J1,K), NUM, 1 ) - 360 CONTINUE - 400 CONTINUE -C - 500 IF (NCOLR .EQ. NCOLZ) GO TO 900 - IF (MSG .GE. 80) WRITE (NOUT, 1000) NCOLR, NCOLZ -C - 900 RETURN -C - 1000 FORMAT(/ 42H //QPCRSH// INDEFINITE PROJECTED HESSIAN. - * / 20H //QPCRSH// NCOLR =, I5, 6X, 7HNCOLZ =, I5) -C -C END OF QPCRSH - END
deleted file mode 100644 --- a/libcruft/qpsol/qpdump.f +++ /dev/null @@ -1,60 +0,0 @@ - SUBROUTINE QPDUMP( N, NROWH, NCOLH, - * CVEC, HESS, QPHESS, WRK, HX ) -C -C IMPLICIT REAL*8(A-H,O-Z) - EXTERNAL QPHESS - INTEGER N, NROWH, NCOLH - DOUBLE PRECISION CVEC(N), HESS(NROWH,NCOLH), WRK(N), HX(N) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C QPDUMP PRINTS QUANTITIES DEFINING THE QUADRATIC FUNCTION GIVEN -C TO QPCORE. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF APRIL 1982. -C ********************************************************************* -C - INTEGER I, J, NHESS - INTEGER MIN0 - DOUBLE PRECISION ZERO, ONE - DATA ZERO/0.0D+0/, ONE/1.0D+0/ -C - WRITE (NOUT, 1000) - WRITE (NOUT, 1500) CVEC -C -C PRINT HESS UNLESS IT APPEARS TO BE IMPLICIT. -C - WRITE (NOUT, 2000) NROWH, NCOLH - IF (NROWH .EQ. 1 .AND. NCOLH .EQ. 1) GO TO 200 - IF (NCOLH .EQ. 1) WRITE (NOUT, 2100) HESS - IF (NCOLH .EQ. 1) GO TO 200 - NHESS = MIN0( NCOLH, N ) - DO 100 J = 1, NHESS - WRITE (NOUT, 2200) J, (HESS(I,J), I=1,NHESS) - 100 CONTINUE -C -C CALL QPHESS TO COMPUTE EACH COLUMN OF THE HESSIAN. -C - 200 WRITE (NOUT, 3000) - CALL ZEROVC( N, WRK, N, 1 ) - DO 300 J = 1, N - WRK(J) = ONE - CALL QPHESS( N, NROWH, NCOLH, J, HESS, WRK, HX ) - WRITE (NOUT, 3100) J, HX - WRK(J) = ZERO - 300 CONTINUE - RETURN -C - 1000 FORMAT(1H1 / 19H OUTPUT FROM QPDUMP / 19H ******************) - 1500 FORMAT(/ 9H CVEC ... / (5G15.6)) - 2000 FORMAT(/ 8H NROWH =, I6, 11H NCOLH =, I6) - 2100 FORMAT(/ 9H HESS ... / (5G15.6)) - 2200 FORMAT(/ 7H COLUMN, I6, 14H OF HESS ... / (5G15.6)) - 3000 FORMAT(// 38H THE FOLLOWING IS RETURNED BY QPHESS.) - 3100 FORMAT(/ 7H COLUMN, I6, 18H FROM QPHESS ... / (5G15.6)) -C -C END OF QPDUMP - END
deleted file mode 100644 --- a/libcruft/qpsol/qpgrad.f +++ /dev/null @@ -1,115 +0,0 @@ - SUBROUTINE QPGRAD( MODE, UNITQ, QPHESS, N, NACTIV, - * NCTOTL, NFREE, NHESS, NQ, NROWH, NCOLH, JADD, - * KACTIV, KFREE, ALFA, OBJQP, GFIXED, GTP, - * CVEC, HESS, P, QTG, SCALE, X, ZY, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER MODE, N, NACTIV, NCTOTL, NFREE, NHESS, NQ, - * NROWH, NCOLH, JADD - INTEGER KACTIV(N), KFREE(N) - DOUBLE PRECISION ALFA, OBJQP, GFIXED, GTP - DOUBLE PRECISION CVEC(N), HESS(NROWH,NCOLH), P(N), QTG(N), - * SCALE(NCTOTL), X(N), ZY(NQ,NQ) - DOUBLE PRECISION WRK1(N), WRK2(N) - LOGICAL UNITQ - EXTERNAL QPHESS -C - LOGICAL SCLDQP - COMMON /SOL2LP/ SCLDQP -C -C ********************************************************************* -C QPGRAD COMPUTES OR UPDATES... -C (1) OBJQP, THE VALUE OF THE QUADRATIC OBJECTIVE FUNCTION, AND -C (2) THE VECTORS Q(FREE)(T)G(FREE) AND G(FIXED), WHERE Q(FREE) -C IS THE ORTHOGONAL FACTOR OF THE A(FREE) AND A IS THE MATRIX -C OF CONSTRAINTS IN THE WORKING SET. THESE VECTORS ARE STORED IN -C ELEMENTS 1,2,...,NFREE AND NFREE+1,...,N, RESPECTIVELY, OF -C THE ARRAY QTG. -C (3) THE COMPONENT OF THE GRADIENT VECTOR CORRESPONDING TO A BOUND -C CONSTRAINT THAT HAS JUST BEEN ADDED TO THE WORKING SET. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ORIGINAL VERSION OF OCTOBER 1982. -C ********************************************************************* -C - INTEGER JTHCOL, NCOLZ - DOUBLE PRECISION DELTAF - DOUBLE PRECISION DOT - DOUBLE PRECISION ZERO , HALF , ONE - DATA ZERO , HALF , ONE - * /0.0D+0, 0.5D+0, 1.0D+0/ -C - JTHCOL = 0 - GO TO ( 100, 200, 300 ), MODE -C -C --------------------------------------------------------------------- -C MODE = 1 --- COMPUTE THE OBJECTIVE FUNCTION AND GRADIENT FROM -C SCRATCH. ALLOW FOR A DIAGONAL SCALING OF X. -C --------------------------------------------------------------------- - 100 CALL COPYVC( N, X , N, 1, WRK1, N, 1 ) -C - IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 ) -C - CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK1, QTG ) - OBJQP = HALF*DOT( N, QTG , N, 1, WRK1, N, 1 ) - * + DOT( N, CVEC, N, 1, WRK1, N, 1 ) - CALL AXPY ( N, ONE, CVEC , N, 1, QTG, N, 1 ) -C - IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, QTG, N, 1 ) -C -C COMPUTE Q(FREE)(T)(G(FREE) AND G(FIXED). THE ELEMENTS OF G(FREE) -C ARE NOT STORED. -C - CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, QTG, ZY, WRK1 ) -C - GO TO 900 -C -C --------------------------------------------------------------------- -C MODE = 2 --- IF THE QP OBJECTIVE FUNCTION IS REDUCED BY A POSITIVE -C STEP ALFA, OR ALFA IS NEGATIVE, UPDATE OBJF, -C Q(FREE)(T)G(FREE) AND G(FIXED) CORRESPONDING TO -C THE CHANGE, X = X + ALFA P. -C --------------------------------------------------------------------- - 200 CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, P, WRK1 ) -C - IF (SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 ) -C -C UPDATE OBJQP. -C - DELTAF = ALFA*GTP + HALF*ALFA*ALFA*DOT( N, P, N, 1, WRK1, N, 1 ) - IF (DELTAF .GT. ZERO .AND. ALFA .GT. ZERO) GO TO 999 - OBJQP = OBJQP + DELTAF -C -C UPDATE THE ARRAY QTG. USE THE ARRAY P AS TEMPORARY WORK SPACE. -C - CALL ZYPROD( 6, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, WRK1, ZY, WRK2 ) -C - CALL AXPY ( N, ALFA, WRK1, N, 1, QTG, N, 1 ) - GO TO 900 -C -C --------------------------------------------------------------------- -C MODE = 3 --- COMPUTE THE JADD-TH COMPONENT OF THE GRADIENT VECTOR. -C --------------------------------------------------------------------- - 300 JTHCOL = JADD - CALL ZEROVC( N, WRK2, N, 1 ) - WRK2(JTHCOL) = ONE - CALL QPHESS( N, NROWH, NCOLH, JTHCOL, HESS, WRK2, WRK1 ) -C - IF ( SCLDQP) CALL DSCALE( N, SCALE, N, 1, WRK1, N, 1 ) - IF ( SCLDQP) - *GFIXED = SCALE(JADD)*(DOT( N, WRK1, N, 1, X, N, 1 ) + CVEC(JADD)) - IF (.NOT. SCLDQP) - *GFIXED = DOT( N, WRK1, N, 1, X, N, 1 ) + CVEC(JADD) -C - 900 NHESS = NHESS + 1 - RETURN -C -C THE STEP ALFA DOES NOT DECREASE THE OBJECTIVE FUNCTION. -C - 999 MODE = - 1 - RETURN -C -C END OF QPGRAD - END
deleted file mode 100644 --- a/libcruft/qpsol/qpprt.f +++ /dev/null @@ -1,139 +0,0 @@ - SUBROUTINE QPPRT ( ORTHOG, ISDEL, ITER, JADD, JDEL, NACTIV, - * NCOLR, NCOLZ, NFREE, N, NCLIN, NCLIN0, NCTOTL, - * NROWA, NROWRT, NCOLRT, NHESS, - * ISTATE, KFREE, - * ALFA, CONDH, CONDT, OBJ, GFNORM, ZTGNRM, EMAX, - * A, RT, X, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL ORTHOG - INTEGER ISDEL, ITER, JADD, JDEL, NACTIV, NCOLR, NCOLZ, - * NFREE, N, NCLIN, NCLIN0, NCTOTL, NROWA, - * NROWRT, NCOLRT, NHESS - INTEGER ISTATE(NCTOTL), KFREE(N) - DOUBLE PRECISION ALFA, CONDH, CONDT, OBJ, GFNORM, ZTGNRM, EMAX - DOUBLE PRECISION A(NROWA,N), RT(NROWRT,NCOLRT), X(N) - DOUBLE PRECISION WRK1(N), WRK2(NCLIN0) -C - INTEGER NOUT, MSG, ISTART - COMMON /SOL1CM/ NOUT, MSG, ISTART -C -C ********************************************************************* -C QPPRT PRINTS VARIOUS LEVELS OF OUTPUT FOR QPCORE. -C -C MSG CUMULATIVE RESULT -C --- ----------------- -C -C LE 0 NO OUTPUT. -C -C EQ 1 NOTHING NOW (BUT FULL OUTPUT LATER). -C -C EQ 5 ONE TERSE LINE OF OUTPUT. -C -C GE 10 SAME AS 5 (BUT FULL OUTPUT LATER). -C -C GE 15 NOTHING MORE IF ITER .LT. ISTART. -C OTHERWISE, X, ISTATE AND KFREE. -C -C GE 20 MULTIPLIERS (PRINTED OUTSIDE QPPRT). -C THE ARRAY AX. -C -C GE 30 DIAGONALS OF T AND R. -C -C GE 80 DEBUG OUTPUT. -C -C EQ 99 CVEC AND HESS (CALLED FROM QPDUMP). -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF APRIL 1982. REV. OCT. 1982. -C ********************************************************************* -C - INTEGER INCT, J, K, LADD, LDEL, LENT, LROWA, L1, L2 - INTEGER LSTATE(6) - DOUBLE PRECISION DOT - DATA LSTATE(1), LSTATE(2) / 1H , 1HL / - DATA LSTATE(3), LSTATE(4) / 1HU, 1HE / - DATA LSTATE(5) / 1HT / - DATA LSTATE(6) / 1HV / -C - IF (MSG .LT. 5) GO TO 900 -C - LDEL = 0 - LADD = 0 - IF (JDEL .GT. 0) LDEL = ISDEL - IF (JDEL .LT. 0) LDEL = 5 - IF (JDEL .LT. 0) JDEL = - JDEL - IF (JADD .GT. 0) LADD = ISTATE(JADD) - LDEL = LSTATE(LDEL + 1) - LADD = LSTATE(LADD + 1) - IF (MSG .GE. 15) GO TO 100 -C -C --------------------------------------------------------------------- -C PRINT HEADING (POSSIBLY) AND TERSE LINE. -C --------------------------------------------------------------------- - IF (ITER .GT. 0 .OR. JDEL .GT. 0) GO TO 50 - IF ( ORTHOG) WRITE (NOUT, 1100) - IF (.NOT. ORTHOG) WRITE (NOUT, 1110) - 50 WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, ALFA, NHESS, - * OBJ, NCOLZ, GFNORM, ZTGNRM, CONDT, CONDH, EMAX - GO TO 900 -C -C --------------------------------------------------------------------- -C PRINT TERSE LINE, X, ISTATE, KFREE. -C --------------------------------------------------------------------- - 100 WRITE (NOUT, 1000) ITER - IF ( ORTHOG) WRITE (NOUT, 1100) - IF (.NOT. ORTHOG) WRITE (NOUT, 1110) - WRITE (NOUT, 1200) ITER, JDEL, LDEL, JADD, LADD, ALFA, NHESS, - * OBJ, NCOLZ, GFNORM, ZTGNRM, CONDT, CONDH, EMAX - WRITE (NOUT, 1300) X - WRITE (NOUT, 1600) (ISTATE(J), J=1,N) - L1 = N + 1 - L2 = N + NCLIN - IF (L1 .LE. L2) WRITE (NOUT, 1610) (ISTATE(J), J=L1,L2) - IF (NFREE .GT. 0) WRITE (NOUT, 1700) (KFREE(K), K=1,NFREE) -C -C --------------------------------------------------------------------- -C COMPUTE AND PRINT AX. USE WORK TO AVOID SIDE EFFECTS. -C --------------------------------------------------------------------- - IF (MSG .LT. 20) GO TO 900 - IF (NCLIN .EQ. 0) GO TO 300 - LROWA = NROWA*(N - 1) + 1 - DO 250 K = 1, NCLIN - WRK2(K) = DOT( N, A(K,1), LROWA, NROWA, X, N, 1 ) - 250 CONTINUE - WRITE (NOUT, 2000) (WRK2(K), K=1,NCLIN) -C -C --------------------------------------------------------------------- -C PRINT ALL THE DIAGONALS OF T AND R. -C --------------------------------------------------------------------- - 300 IF (MSG .LT. 30) GO TO 900 - LENT = NROWRT*(NACTIV - 1) + 1 - INCT = NROWRT - 1 - IF (NACTIV .GT. 0) CALL COPYVC( NACTIV, RT(NACTIV,NCOLZ+1), - * LENT, INCT, WRK1, NACTIV, 1 ) - IF (NACTIV .GT. 0) WRITE (NOUT, 3000) (WRK1(J), J=1,NACTIV) - IF (NCOLZ .GT. 0) WRITE (NOUT, 3100) (RT(J,J), J=1,NCOLZ) -C - 900 RETURN -C - 1000 FORMAT(/// 18H ================= / 13H QP ITERATION, I5 - * / 18H ================= ) - 1100 FORMAT(// 5H ITN, 12H JDEL JADD , 10H STEP, - * 6H NHESS, 12H OBJECTIVE, 6H NCOLZ, 11H NORM GFREE, - * 10H NORM ZTG, 9H COND T, 9H COND ZHZ, 10H HESS MOD) - 1110 FORMAT(// 5H ITN, 12H JDEL JADD , 10H STEP, - * 6H NHESS, 12H OBJECTIVE, 6H NCOLZ, 11H NORM QTG, - * 10H NORM ZTG, 9H COND T, 9H COND ZHZ, 10H HESS MOD) - 1200 FORMAT(I5, I5, A1, I5, A1, 1PE10.2, I6, 1PE12.4, I6, - * 1PE11.2, 1PE10.2, 1P2E9.1, 1PE10.2) - 1300 FORMAT(/ 13H QP VARIABLES / (1P5E15.6)) - 1600 FORMAT(/ 35H STATUS OF THE QP BOUND CONSTRAINTS / (1X, 10I4)) - 1610 FORMAT(/ 37H STATUS OF THE QP GENERAL CONSTRAINTS / (1X, 10I4)) - 1700 FORMAT(/ 26H LIST OF FREE QP VARIABLES / (1X, 10I4)) - 2000 FORMAT(/ 40H VALUES OF QP GENERAL LINEAR CONSTRAINTS / (1P5E15.6)) - 3000 FORMAT(/ 40H DIAGONALS OF QP WORKING SET FACTOR T / (1P5E15.6)) - 3100 FORMAT(/ 40H DIAGONALS OF QP PRJ. HESSIAN FACTOR R / (1P5E15.6)) -C -C END OF QPPRT - END
deleted file mode 100644 --- a/libcruft/qpsol/qpsol.f +++ /dev/null @@ -1,325 +0,0 @@ - SUBROUTINE QPSOL ( ITMAX, MSGLVL, N, - * NCLIN, NCTOTL, NROWA, NROWH, NCOLH, - * BIGBND, A, BL, BU, CVEC, FEATOL, HESS, QPHESS, - * COLD, LP, ORTHOG, ISTATE, X, - * INFORM, ITER, OBJ, CLAMDA, - * IW, LENIW, W, LENW ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER ITMAX, MSGLVL, N, NCLIN, NCTOTL, NROWA, - * NROWH, NCOLH, INFORM, ITER - INTEGER LENIW, LENW - INTEGER ISTATE(NCTOTL), IW(LENIW) - DOUBLE PRECISION BIGBND, OBJ - DOUBLE PRECISION A(NROWA,N), BL(NCTOTL), BU(NCTOTL) - DOUBLE PRECISION CLAMDA(NCTOTL), CVEC(N), FEATOL(NCTOTL) - DOUBLE PRECISION HESS(NROWH,NCOLH), X(N), W(LENW) - LOGICAL COLD, LP, ORTHOG - EXTERNAL QPHESS -C -C ********************************************************************* -C QPSOL SOLVES QUADRATIC PROGRAMMING (QP) PROBLEMS OF THE FORM -C -C MINIMIZE C(T)*X + 1/2 X(T)*H*X -C -C SUBJECT TO ( X ) -C BL .LE.( ).GE. BU -C ( A*X ) -C -C -C WHERE (T) DENOTES THE TRANSPOSE OF A COLUMN VECTOR. -C THE SYMMETRIC MATRIX H MAY BE POSITIVE-DEFINITE, POSITIVE -C SEMI-DEFINITE, OR INDEFINITE. -C -C N IS THE NUMBER OF VARIABLES (DIMENSION OF X). -C -C NCLIN IS THE NUMBER OF GENERAL LINEAR CONSTRAINTS (ROWS OF A). -C (NCLIN MAY BE ZERO.) -C -C THE MATRIX H IS DEFINED BY THE SUBROUTINE QPHESS, WHICH -C MUST COMPUTE THE MATRIX-VECTOR PRODUCT H*X FOR ANY VECTOR X. -C -C THE VECTOR C IS ENTERED IN THE ONE-DIMENSIONAL ARRAY CVEC. -C -C THE FIRST N COMPONENTS OF BL AND BU ARE LOWER AND UPPER -C BOUNDS ON THE VARIABLES. THE NEXT NCLIN COMPONENTS ARE -C LOWER AND UPPER BOUNDS ON THE GENERAL LINEAR CONSTRAINTS. -C -C THE MATRIX A OF COEFFICIENTS IN THE GENERAL LINEAR CONSTRAINTS -C IS ENTERED AS THE TWO-DIMENSIONAL ARRAY A (OF DIMENSION -C NROWA BY N). IF NCLIN = 0, A IS NOT ACCESSED. -C -C THE VECTOR X MUST CONTAIN AN INITIAL ESTIMATE OF THE SOLUTION, -C AND WILL CONTAIN THE COMPUTED SOLUTION ON OUTPUT. -C -C -C -C COMPLETE DOCUMENTATION FOR QPSOL IS CONTAINED IN REPORT SOL 83-12, -C USERS GUIDE FOR SOL/QPSOL, BY P.E. GILL, W. MURRAY, M.A. SAUNDERS -C AND M.H. WRIGHT, DEPARTMENT OF OPERATIONS RESEARCH, STANFORD -C UNIVERSITY, STANFORD, CALIFORNIA 94305. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION 1 OF DECEMBER 1981. -C VERSION 2 OF JUNE 1982. -C VERSION 3 OF JANUARY 1983. -C VERSION 3.1 OF APRIL 1983. -C VERSION 3.2 OF JUNE 1984. -C -C COPYRIGHT 1983 STANFORD UNIVERSITY. -C -C THIS MATERIAL MAY BE REPRODUCED BY OR FOR THE U.S. GOVERNMENT PURSU- -C ANT TO THE COPYRIGHT LICENSE UNDER DAR CLAUSE 7-104.9(A) (1979 MAR). -C -C THIS MATERIAL IS BASED UPON WORK PARTIALLY SUPPORTED BY THE NATIONAL -C SCIENCE FOUNDATION UNDER GRANTS MCS-7926009 AND ECS-8012974; THE -C OFFICE OF NAVAL RESEARCH CONTRACT N00014-75-C-0267; THE DEPARTMENT -C OF ENERGY CONTRACT AM03-76SF00326, PA NO. DE-AT03-76ER72018; AND THE -C ARMY RESEARCH OFFICE CONTRACT DAA29-79-C-0110. -C ********************************************************************* -C -C COMMON BLOCKS. -C - INTEGER NOUT, MSG, ISTART, LENNAM, NROWRT, NCOLRT, NQ - DOUBLE PRECISION ASIZE, DTMAX, DTMIN - DOUBLE PRECISION WMACH, PARM - COMMON /SOLMCH/ WMACH(15) - COMMON /SOL1CM/ NOUT, MSG, ISTART - COMMON /SOL3CM/ LENNAM, NROWRT, NCOLRT, NQ - COMMON /SOL4CM/ PARM(10) - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C - LOGICAL SCLDQP - INTEGER LOCLP - COMMON /SOL1LP/ LOCLP(15) - COMMON /SOL2LP/ SCLDQP -C -C INTRINSIC FUNCTIONS. -C - INTEGER MAX0, MIN0 -C -C LOCAL VARIABLES. -C - LOGICAL MINSUM, NAMED, UNITQ, VERTEX - INTEGER L, LAX, LCRASH, LITOTL, LKACTV, LKFREE, - * LNAMES, LPX, LSCALE, LWRK, LWTOTL, - * MAXACT, MXCOLZ, MXFREE, MINACT, MINFXD, - * NACTIV, NALG, NCNLN, NERROR, NFREE, - * NROWJ, NUMINF - DOUBLE PRECISION BIGDX, EPSMCH, EPSPT9, TOLACT, XNORM - DOUBLE PRECISION POINT9 - INTEGER LPQP(2) - DATA LPQP(1), LPQP(2) - * /2HLP , 2HQP / - DATA POINT9 - * / 0.9D+0 / -C -C SET THE MACHINE-DEPENDENT CONSTANTS. -C - CALL MCHPAR - EPSMCH = WMACH( 3) - NOUT = WMACH(11) -C -C QPSOL WILL PROVIDE DEFAULT NAMES FOR VARIABLES DURING PRINTING. -C - NAMED = .FALSE. -C -C IF THERE IS NO FEASIBLE POINT FOR THE LINEAR CONSTRAINTS AND BOUNDS, -C COMPUTE THE MINIMUM SUM OF INFEASIBILITIES. -C IT IS NOT NECESSARY TO START THE QP PHASE AT A VERTEX. -C - MINSUM = .TRUE. - VERTEX = .FALSE. -C -C ANY CHANGE IN X THAT IS GREATER THAN BIGDX WILL BE REGARDED AS AN -C INFINITE STEP. -C - BIGDX = 1.0D+20 -C -C DURING SELECTION OF THE INITIAL WORKING SET (BY CRASH), -C CONSTRAINTS WITH RESIDUALS LESS THAN TOLACT WILL BE MADE ACTIVE. -C - TOLACT = 0.01D+0 -C - EPSPT9 = EPSMCH**(POINT9) -C - PARM(1) = BIGBND - PARM(2) = BIGDX - PARM(3) = TOLACT - PARM(4) = EPSPT9 -C -C ASSIGN THE DIMENSIONS OF ARRAYS IN THE PARAMETER LIST OF QPCORE. -C ECONOMIES OF STORAGE ARE POSSIBLE IF THE MINIMUM NUMBER OF ACTIVE -C CONSTRAINTS AND THE MINIMUM NUMBER OF FIXED VARIABLES ARE KNOWN IN -C ADVANCE. THE EXPERT USER SHOULD ALTER MINACT AND MINFXD -C ACCORDINGLY. -C IF A LINEAR PROGRAM IS BEING SOLVED AND THE MATRIX OF GENERAL -C CONSTRAINTS IS FAT, I.E., NCLIN .LT. N, A NON-ZERO VALUE IS -C KNOWN FOR MINFXD. NOTE THAT IN THIS CASE, VERTEX MUST BE .TRUE.. -C - MINACT = 0 - MINFXD = 0 -C - IF (LP .AND. NCLIN .LT. N) MINFXD = N - NCLIN - 1 - IF (LP .AND. NCLIN .LT. N) VERTEX = .TRUE. -C - MXFREE = N - MINFXD - MAXACT = MAX0( 1, MIN0( N, NCLIN ) ) - MXCOLZ = N - ( MINFXD + MINACT ) - NQ = MAX0( 1, MXFREE ) - NROWRT = MAX0( MXCOLZ, MAXACT ) - NCOLRT = MAX0( 1, MXFREE ) -C - NCNLN = 0 - LENNAM = 1 -C -C ALLOCATE CERTAIN ARRAYS THAT ARE NOT DONE IN ALLOC. -C - LNAMES = 1 - LITOTL = 0 -C - LAX = 1 - LWTOTL = LAX + NROWA - 1 -C -C ALLOCATE REMAINING WORK ARRAYS. -C - NALG = 2 - LOCLP(1) = LNAMES - CALL ALLOC ( NALG, N, NCLIN, NCNLN, NCTOTL, NROWA, NROWJ, - * LITOTL, LWTOTL ) -C - LKACTV = LOCLP( 2) - LKFREE = LOCLP( 3) -C - LPX = LOCLP( 6) - LWRK = LOCLP(11) -C -C SET THE MESSAGE LEVEL FOR LPDUMP, QPDUMP, CHKDAT AND LPCORE. -C - MSG = 0 - IF (MSGLVL .GE. 5) MSG = 5 - IF (LP .OR. MSGLVL .GE. 15) MSG = MSGLVL -C -C ******* THE FOLLOWING STATEMENT MUST BE EXECUTED IF ISTART ******* -C ******* IS NOT SET IN THE CALLING ROUTINE. ******* -C - ISTART = 0 -C - LCRASH = 1 - IF (COLD) LCRASH = 0 -C -C CHECK INPUT PARAMETERS AND STORAGE LIMITS. -C - IF (MSGLVL .EQ. 99) - *CALL LPDUMP( N, NCLIN, NCTOTL, NROWA, - * LCRASH, LP, MINSUM, NAMED, VERTEX, - * ISTATE, A, W(LAX), BL, BU, CVEC, X ) -C - IF (MSGLVL .EQ. 99) - *CALL QPDUMP( N, NROWH, NCOLH, - * CVEC, HESS, QPHESS, W(LWRK), W(LPX) ) -C - CALL CHKDAT( NERROR, LENIW, LENW, LITOTL, LWTOTL, - * NROWA, N, NCLIN, NCNLN, NCTOTL, - * ISTATE, IW(LKACTV), - * LCRASH, NAMED, IW(LNAMES), LENNAM, - * BIGBND, A, BL, BU, FEATOL, X ) -C - INFORM = 9 - ITER = 0 - IF (NERROR .NE. 0) GO TO 900 -C -C NO SCALING IS PROVIDED BY THIS VERSION OF QPSOL. -C GIVE A FAKE VALUE FOR THE START OF THE SCALE ARRAY. -C - SCLDQP = .FALSE. - LSCALE = 1 -C -C --------------------------------------------------------------------- -C CALL LPCORE TO OBTAIN A FEASIBLE POINT, OR SOLVE A LINEAR PROBLEM. -C --------------------------------------------------------------------- - CALL LPCORE( LP, MINSUM, NAMED, ORTHOG, UNITQ, VERTEX, - * INFORM, ITER, ITMAX, LCRASH, - * N, NCLIN, NCTOTL, NROWA, NACTIV, NFREE, NUMINF, - * ISTATE, IW(LKACTV), IW(LKFREE), - * OBJ, XNORM, - * A, W(LAX), BL, BU, CLAMDA, CVEC, FEATOL, X, - * IW, LENIW, W, LENW ) -C - IF (LP ) GO TO 50 - IF (INFORM .EQ. 0) GO TO 100 -C -C TROUBLE IN LPCORE. -C -C INFORM CANNOT BE GIVEN THE VALUE 2 WHEN FINDING A FEASIBLE POINT, -C SO IT IS NECESSARY TO DECREMENT ALL THE VALUES OF INFORM THAT ARE -C GREATER THAN 2. -C - IF (INFORM .GT. 2) INFORM = INFORM - 1 - INFORM = INFORM + 5 - GO TO 900 -C -C THE PROBLEM WAS AN LP, NOT A QP. -C - 50 IF (INFORM .GT. 2) INFORM = INFORM + 4 - IF (INFORM .EQ. 1) INFORM = 6 - GO TO 900 -C -C --------------------------------------------------------------------- -C CALL QPCORE TO SOLVE A QUADRATIC PROBLEM. -C --------------------------------------------------------------------- -C - 100 MSG = MSGLVL -C -C ******* THE FOLLOWING STATEMENT MUST BE EXECUTED IF ISTART ******* -C ******* IS NOT SET IN THE CALLING ROUTINE. ******* -C - ISTART = 0 -C - CALL QPCORE( NAMED, ORTHOG, UNITQ, INFORM, ITER, ITMAX, - * N, NCLIN, NCTOTL, NROWA, NROWH, NCOLH, - * NACTIV, NFREE, QPHESS, ISTATE, IW(LKACTV),IW(LKFREE), - * OBJ, XNORM, - * A, W(LAX), BL, BU, CLAMDA, CVEC, - * FEATOL, HESS, W(LSCALE), X, IW, LENIW, W, LENW ) -C -C PRINT MESSAGES IF REQUIRED. -C -C - 900 IF (MSGLVL .LE. 0) RETURN - IF ( LP) L = 1 - IF (.NOT. LP) L = 2 - IF (INFORM .EQ. 0) WRITE (NOUT, 1000) LPQP(L) - IF (INFORM .EQ. 1) WRITE (NOUT, 1010) - IF (INFORM .EQ. 2) WRITE (NOUT, 1020) LPQP(L) - IF (INFORM .EQ. 3) WRITE (NOUT, 1030) - IF (INFORM .EQ. 4) WRITE (NOUT, 1040) - IF (INFORM .EQ. 5) WRITE (NOUT, 1050) - IF (INFORM .EQ. 6) WRITE (NOUT, 1060) - IF (INFORM .EQ. 7) WRITE (NOUT, 1070) - IF (INFORM .EQ. 8) WRITE (NOUT, 1080) - IF (INFORM .EQ. 9) WRITE (NOUT, 1090) NERROR - IF (INFORM .EQ. 9) RETURN -C - IF (NUMINF .EQ. 0) WRITE (NOUT, 2000) LPQP(L), OBJ - IF (NUMINF .GT. 0) WRITE (NOUT, 2010) OBJ - RETURN -C - 1000 FORMAT(/ 22H EXIT QPSOL - OPTIMAL , A2, 10H SOLUTION.) - 1010 FORMAT(/ 33H EXIT QPSOL - WEAK LOCAL MINIMUM.) - 1020 FORMAT(/ 14H EXIT QPSOL - , A2, 23H SOLUTION IS UNBOUNDED.) - 1030 FORMAT(/ 31H EXIT QPSOL - ZERO MULTIPLIERS.) - 1040 FORMAT(/ 53H EXIT QPSOL - TOO MANY ITERATIONS WITHOUT CHANGING X.) - 1050 FORMAT(/ 34H EXIT QPSOL - TOO MANY ITERATIONS.) - 1060 FORMAT(/ 52H EXIT QPSOL - CANNOT SATISFY THE LINEAR CONSTRAINTS.) - 1070 FORMAT(/ 52H EXIT QPSOL - TOO MANY ITERATIONS WITHOUT CHANGING X, - * 21H DURING THE LP PHASE.) - 1080 FORMAT(/ 33H EXIT QPSOL - TOO MANY ITERATIONS, - * 21H DURING THE LP PHASE.) - 1090 FORMAT(/ 14H EXIT QPSOL - , I10, 26H ERRORS FOUND IN THE INPUT, - * 32H PARAMETERS. PROBLEM ABANDONED.) - 2000 FORMAT(/ 7H FINAL , A2, 18H OBJECTIVE VALUE =, G16.7) - 2010 FORMAT(/ 31H FINAL SUM OF INFEASIBILITIES =, G16.7) -C -C END OF QPSOL - END
deleted file mode 100644 --- a/libcruft/qpsol/quotnt.f +++ /dev/null @@ -1,27 +0,0 @@ - DOUBLE PRECISION FUNCTION QUOTNT( U, V ) -C - DOUBLE PRECISION U, V -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C QUOTNT RETURNS THE QUOTIENT U / V, GUARDING AGAINST OVERFLOW. -C VERSION OF FEBRUARY 1983. -C - DOUBLE PRECISION ABSV, FLMAX, ZERO, ONE - DOUBLE PRECISION DABS - DATA ZERO, ONE / 0.0D+0, 1.0D+0 / -C - FLMAX = WMACH(7) -C - ABSV = DABS( V ) - IF (ABSV .GE. ONE) GO TO 100 - QUOTNT = FLMAX - IF (V .EQ. ZERO .AND. U .LT. ZERO) QUOTNT = - FLMAX - IF (DABS( U ) .GE. ABSV*FLMAX) GO TO 110 - 100 QUOTNT = U / V -C - 110 RETURN -C -C END OF QUOTNT - END
deleted file mode 100644 --- a/libcruft/qpsol/refgen.f +++ /dev/null @@ -1,91 +0,0 @@ - SUBROUTINE REFGEN( N, ALPHA, X, LENX, INCX, BETA, DELTA ) -C - INTEGER N, LENX, INCX - DOUBLE PRECISION ALPHA, BETA, DELTA - DOUBLE PRECISION X(LENX) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C ********************************************************************* -C REFGEN GENERATES A HOUSEHOLDER REFLECTION P SUCH THAT -C -C P ( ALPHA ) = ( DELTA ) , P(T) P = I, -C ( X ) ( 0 ) -C -C WHERE P HAS THE FORM -C -C P = ( I ) - 1/BETA ( BETA ) ( BETA Z(T) ) -C ( 1 ) ( Z ) -C -C FOR SOME BETA AND Z, WHERE Z IS A VECTOR WITH N ELEMENTS. -C -C IN CERTAIN CIRCUMSTANCES ( X VERY SMALL IN ABSOLUTE TERMS OR -C X VERY SMALL COMPARED TO ALPHA), P WILL BE THE IDENTITY MATRIX. -C REFGEN WILL THEN LEAVE ALPHA AND X UNALTERED, AND WILL RETURN -C BETA = ZERO AND DELTA = ALPHA. -C -C OTHERWISE, REFGEN RETURNS BETA IN THE RANGE (1.0, 2.0), -C SETS ALPHA = BETA, AND STORES Z IN THE ARRAY X. -C (IN SOME CASES, SETTING ALPHA = BETA IS CONVENIENT FOR LATER USE.) -C -C REFGEN GUARDS AGAINST OVERFLOW AND UNDERFLOW. -C IT IS ASSUMED THAT FLMIN .LT. EPSMCH**2 (I.E. RTMIN .LT. EPSMCH). -C -C VERSION 1, MARCH 30 1983. DERIVED FROM SVEN HAMMARLING'S NREFG. -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C ********************************************************************* -C - INTEGER I, NINCX - DOUBLE PRECISION ABSALF, EPSMCH, GAMMA, ONE, RTMIN, TOL, XNORM, - * ZERO - DOUBLE PRECISION DABS - DOUBLE PRECISION DSQRT, V2NORM -C - DATA ZERO/0.0D+0/, ONE/1.0D+0/ -C - BETA = ZERO - DELTA = ALPHA - IF (N .LT. 1) RETURN - EPSMCH = WMACH(3) - RTMIN = WMACH(6) -C - ABSALF = DABS(ALPHA) - XNORM = V2NORM( N, X, LENX, INCX ) - IF (XNORM .LE. RTMIN ) RETURN - IF (ABSALF .LE. EPSMCH * XNORM ) GO TO 50 - IF (XNORM .LE. EPSMCH * ABSALF) RETURN - GO TO 100 -C -C ALPHA IS SMALL ENOUGH TO BE REGARDED AS ZERO. -C - 50 DELTA = XNORM - BETA = ONE - GO TO 200 -C -C NORMAL CASE. -C WE KNOW THAT EPSMCH .LT. XNORM / ABSALF .LT. 1/EPSMCH. -C - 100 GAMMA = DSQRT( ONE + (XNORM/ALPHA)**2 ) - DELTA = ALPHA * GAMMA - BETA = ONE + ONE/GAMMA -C -C SET X = X / DELTA, WHERE DABS(DELTA) = NORM( ALPHA, X ). -C CHANGE NEGLIGIBLE ELEMENTS TO ZERO TO AVOID UNDERFLOW LATER ON. -C - 200 TOL = DABS( DELTA ) * EPSMCH - NINCX = N * INCX - DO 300 I = 1, NINCX, INCX - IF (DABS( X(I) ) .LE. TOL) GO TO 250 - X(I) = X(I) / DELTA - GO TO 300 -C - 250 X(I) = ZERO - 300 CONTINUE -C - ALPHA = BETA - DELTA = - DELTA - RETURN -C -C END OF REFGEN - END
deleted file mode 100644 --- a/libcruft/qpsol/rot3.f +++ /dev/null @@ -1,71 +0,0 @@ - SUBROUTINE ROT3 ( N, X, LENX, INCX, Y, LENY, INCY, CS, SN ) -C - INTEGER N, LENX, INCX, LENY, INCY - DOUBLE PRECISION CS, SN - DOUBLE PRECISION X(LENX), Y(LENY) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C ********************************************************************* -C ROT3 APPLIES THE PLANE ROTATION DEFINED BY CS AND SN -C TO THE COLUMNS OF A 2 BY N MATRIX HELD IN X AND Y. -C THE METHOD USED REQUIRES 3 MULTIPLICATIONS AND 3 ADDITIONS -C PER COLUMN, AS DESCRIBED IN GILL, GOLUB, MURRAY AND SAUNDERS, -C MATHEMATICS OF COMPUTATION 28 (1974) 505--535 (SEE PAGE 508). -C -C ROT3 GUARDS AGAINST UNDERFLOW, AND OVERFLOW IS EXTREMELY UNLIKELY. -C IT IS ASSUMED THAT CS AND SN HAVE BEEN GENERATED BY ROTGEN, -C ENSURING THAT CS LIES IN THE CLOSED INTERVAL (0, 1), AND THAT -C THE ABSOLUTE VALUE OF CS AND SN (IF NONZERO) IS NO LESS THAN THE -C MACHINE PRECISION, EPS. IT IS ALSO ASSUMED THAT RTMIN .LT. EPS. -C NOTE THAT THE MAGIC NUMBER Z IS THEREFORE NO LESS THAN 0.5*EPS -C IN ABSOLUTE VALUE, SO IT IS SAFE TO USE TOL = 2*RTMIN IN THE -C UNDERFLOW TEST INVOLVING Z*A. FOR EFFICIENCY WE USE THE SAME TOL -C IN THE PREVIOUS TWO TESTS. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF JANUARY 1982. -C ********************************************************************* -C - INTEGER I, IX, IY - DOUBLE PRECISION A, B, ONE, RTMIN, TOL, W, Z, ZERO - DOUBLE PRECISION DABS - DATA ONE/1.0D+0/, ZERO/0.0D+0/ -C - IF (N .LT. 1 .OR. SN .EQ. ZERO) RETURN - IX = 1 - IY = 1 - IF (CS .EQ. ZERO) GO TO 100 - RTMIN = WMACH(6) - TOL = RTMIN + RTMIN - Z = SN/(ONE + CS) -C - DO 10 I = 1, N - A = X(IX) - B = Y(IY) - W = ZERO - IF (DABS(A) .GT. TOL) W = CS*A - IF (DABS(B) .GT. TOL) W = W + SN*B - X(IX) = W - A = A + W - IF (DABS(A) .GT. TOL) B = B - Z*A - Y(IY) = - B - IX = IX + INCX - IY = IY + INCY - 10 CONTINUE - RETURN -C -C JUST SWAP X AND Y. -C - 100 DO 110 I = 1, N - A = X(IX) - X(IX) = Y(IY) - Y(IY) = A - IX = IX + INCX - IY = IY + INCY - 110 CONTINUE - RETURN -C -C END OF ROT3 - END
deleted file mode 100644 --- a/libcruft/qpsol/rotgen.f +++ /dev/null @@ -1,71 +0,0 @@ - SUBROUTINE ROTGEN( X, Y, CS, SN ) -C - DOUBLE PRECISION X, Y, CS, SN -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C ********************************************************************* -C ROTGEN GENERATES A PLANE ROTATION THAT REDUCES THE VECTOR (X, Y) -C TO THE VECTOR (A, 0), WHERE A IS DEFINED AS FOLLOWS... -C -C IF BOTH X AND Y ARE NEGLIGIBLY SMALL, OR -C IF Y IS NEGLIGIBLE RELATIVE TO X, -C THEN A = X, AND THE IDENTITY ROTATION IS RETURNED. -C -C IF X IS NEGLIGIBLE RELATIVE TO Y, -C THEN A = Y, AND THE SWAP ROTATION IS RETURNED. -C -C OTHERWISE, A = SIGN(X) * SQRT( X**2 + Y**2 ). -C -C IN ALL CASES, X AND Y ARE OVERWRITTEN BY A AND 0, -C AND CS WILL LIE IN THE CLOSED INTERVAL (0, 1). ALSO, -C THE ABSOLUTE VALUE OF CS AND SN (IF NONZERO) WILL BE NO LESS -C THAN THE MACHINE PRECISION, EPS. -C -C ROTGEN GUARDS AGAINST OVERFLOW AND UNDERFLOW. -C IT IS ASSUMED THAT FLMIN .LT. EPS**2 (I.E. RTMIN .LT. EPS). -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF JANUARY 1982. -C ********************************************************************* -C - DOUBLE PRECISION A, B, EPS, ONE, RTMIN, ZERO - DOUBLE PRECISION DSQRT - DOUBLE PRECISION DABS, DMAX1 - DATA ONE/1.0D+0/, ZERO/0.0D+0/ -C - IF (Y .EQ. ZERO) GO TO 100 - IF (X .EQ. ZERO) GO TO 200 -C - EPS = WMACH(3) - RTMIN = WMACH(6) - A = DABS(X) - B = DABS(Y) - IF (DMAX1(A,B) .LE. RTMIN) GO TO 100 - IF (A .LT. B) GO TO 50 - IF (B .LE. EPS*A) GO TO 100 - A = A * DSQRT( ONE + (B/A)**2 ) - GO TO 60 -C - 50 IF (A .LE. EPS*B) GO TO 200 - A = B * DSQRT( ONE + (A/B)**2 ) -C - 60 IF (X .LT. ZERO) A = - A - CS = X/A - SN = Y/A - X = A - GO TO 300 -C - 100 CS = ONE - SN = ZERO - GO TO 300 -C - 200 CS = ZERO - SN = ONE - X = Y - 300 Y = ZERO - RETURN -C -C END OF ROTGEN - END
deleted file mode 100644 --- a/libcruft/qpsol/rsolve.f +++ /dev/null @@ -1,43 +0,0 @@ - SUBROUTINE RSOLVE( MODE, NROWR, N, R, Y ) -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER MODE, NROWR, N - DOUBLE PRECISION R(NROWR,N), Y(N) -C -C ********************************************************************* -C RSOLVE SOLVES EQUATIONS INVOLVING AN UPPER-TRIANGULAR MATRIX R -C AND A RIGHT-HAND-SIDE VECTOR Y, RETURNING THE SOLUTION IN Y. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF SEPTEMBER 1981. -C ********************************************************************* -C - INTEGER J, JJ - DOUBLE PRECISION YJ, ZERO - DOUBLE PRECISION DOT - DATA ZERO /0.0D+0/ -C - IF (MODE .NE. 1) GO TO 400 -C -C MODE = 1 --- SOLVE R * Y(NEW) = Y(OLD). -C - DO 100 JJ = 1, N - J = N + 1 - JJ - YJ = Y(J)/R(J,J) - Y(J) = YJ - IF (J .GT. 1 .AND. YJ .NE. ZERO) - * CALL AXPY( J-1, (-YJ), R(1,J), J, 1, Y, J, 1 ) - 100 CONTINUE - RETURN -C -C MODE = 2 --- SOLVE R(TRANSPOSE) * Y(NEW) = Y(OLD). -C - 400 DO 500 J = 1, N - YJ = Y(J) - IF (J .GT. 1) - * YJ = YJ - DOT( J-1, R(1,J), J, 1, Y, J, 1 ) - Y(J) = YJ/R(J,J) - 500 CONTINUE - RETURN -C -C END OF RSOLVE - END
deleted file mode 100644 --- a/libcruft/qpsol/sscale.f +++ /dev/null @@ -1,26 +0,0 @@ - SUBROUTINE SSCALE( N, A, X, LENX, INCX ) -C - INTEGER N, LENX, INCX - DOUBLE PRECISION A - DOUBLE PRECISION X(LENX) -C -C SCALE THE VECTOR X BY THE SCALAR A. -C - INTEGER I, IX -C - IF (N .LT. 1) RETURN - IF (INCX .EQ. 1) GO TO 50 - IX = 1 - DO 10 I = 1, N - X(IX) = A * X(IX) - IX = IX + INCX - 10 CONTINUE - RETURN -C - 50 DO 60 I = 1, N - X(I) = A * X(I) - 60 CONTINUE - RETURN -C -C END OF SSCALE - END
deleted file mode 100644 --- a/libcruft/qpsol/tqadd.f +++ /dev/null @@ -1,70 +0,0 @@ - SUBROUTINE TQADD ( ORTHOG, UNITQ, - * INFORM, K1, K2, NACTIV, NCOLZ, NFREE, - * N, NCTOTL, NQ, NROWA, NROWRT, NCOLRT, - * ISTATE, KACTIV, KFREE, - * CONDMX, - * A, QTG, RT, ZY, WRK1, WRK2 ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL ORTHOG, UNITQ - INTEGER INFORM, K1, K2, N, NCTOTL, NQ, NROWA, - * NROWRT, NCOLRT, NACTIV, NCOLZ, NFREE - INTEGER ISTATE(NCTOTL), KACTIV(N), KFREE(N) - DOUBLE PRECISION CONDMX - DOUBLE PRECISION A(NROWA,N), QTG(N), RT(NROWRT,NCOLRT), - * ZY(NQ,NQ), WRK1(N), WRK2(N) -C - DOUBLE PRECISION ASIZE, DTMAX, DTMIN - COMMON /SOL5CM/ ASIZE, DTMAX, DTMIN -C -C ********************************************************************* -C TQADD INCLUDES GENERAL LINEAR CONSTRAINTS K1 THRU K2 AS NEW -C COLUMNS OF THE TQ FACTORIZATION STORED IN RT, ZY. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF SEPTEMBER 1981. REV. OCT 1982, JAN 1983. -C ********************************************************************* -C - INTEGER I, IADD, IFIX, ISWAP, JADD, K, L - DOUBLE PRECISION CSLAST, SNLAST -C - DO 200 K = K1, K2 - IADD = KACTIV(K) - JADD = N + IADD - IF (NACTIV .EQ. NFREE) GO TO 100 -C - CALL ADDCON( .FALSE., .FALSE., ORTHOG, UNITQ, INFORM, - * IFIX, IADD, JADD, NACTIV, NCOLZ, NCOLZ, NFREE, - * N, NQ, NROWA, NROWRT, NCOLRT, KFREE, - * CONDMX, CSLAST, SNLAST, - * A, QTG, RT, ZY, WRK1, WRK2 ) -C - IF (INFORM .GT. 0) GO TO 100 - NACTIV = NACTIV + 1 - NCOLZ = NCOLZ - 1 - GO TO 200 -C - 100 ISTATE(JADD) = 0 - KACTIV(K) = - KACTIV(K) - 200 CONTINUE -C - IF (NACTIV .EQ. K2) RETURN -C -C SOME OF THE CONSTRAINTS WERE CLASSED AS DEPENDENT AND NOT INCLUDED -C IN THE FACTORIZATION. MOVE ACCEPTED INDICES TO THE FRONT OF KACTIV -C AND SHIFT REJECTED INDICES (WITH NEGATIVE VALUES) TO THE END. -C - L = K1 - 1 - DO 300 K = K1, K2 - I = KACTIV(K) - IF (I .LT. 0) GO TO 300 - L = L + 1 - IF (L .EQ. K) GO TO 300 - ISWAP = KACTIV(L) - KACTIV(L) = I - KACTIV(K) = ISWAP - 300 CONTINUE - RETURN -C -C END OF TQADD - END
deleted file mode 100644 --- a/libcruft/qpsol/tsolve.f +++ /dev/null @@ -1,59 +0,0 @@ - SUBROUTINE TSOLVE( MODE, NROWT, N, T, Y ) -C -C IMPLICIT REAL*8(A-H,O-Z) - INTEGER MODE, NROWT, N - DOUBLE PRECISION T(NROWT,N), Y(N) -C -C ********************************************************************* -C TSOLVE SOLVES EQUATIONS INVOLVING A REVERSE-TRIANGULAR MATRIX T -C AND A RIGHT-HAND-SIDE VECTOR Y, RETURNING THE SOLUTION IN Y. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF SEPTEMBER 1981. -C ********************************************************************* -C - INTEGER J, JJ, L, LROW, N1 - DOUBLE PRECISION YJ, ZERO - DATA ZERO /0.0D+0/ -C - N1 = N + 1 - IF (MODE .NE. 1) GO TO 400 -C -C MODE = 1 --- SOLVE T * Y(NEW) = Y(OLD). -C - DO 100 J = 1, N - JJ = N1 - J - YJ = Y(J)/T(J,JJ) - Y(J) = YJ - L = JJ - 1 - IF (L .GT. 0 .AND. YJ .NE. ZERO) - * CALL AXPY( L, (-YJ), T(J+1,JJ), L, 1, Y(J+1), L, 1 ) - 100 CONTINUE - GO TO 700 -C -C MODE = 2 --- SOLVE T(TRANSPOSE) * Y(NEW) = Y(OLD). -C - 400 DO 500 J = 1, N - JJ = N1 - J - YJ = Y(J)/T(JJ,J) - Y(J) = YJ - L = JJ - 1 - LROW = NROWT*(L - 1) + 1 - IF (L .GT. 0 .AND. YJ .NE. ZERO) - * CALL AXPY( L, (-YJ), T(JJ,J+1), LROW, NROWT, Y(J+1), L, 1 ) - 500 CONTINUE -C -C REVERSE THE SOLUTION VECTOR. -C - 700 IF (N .LE. 1) RETURN - L = N/2 - DO 800 J = 1, L - JJ = N1 - J - YJ = Y(J) - Y(J) = Y(JJ) - Y(JJ) = YJ - 800 CONTINUE - RETURN -C -C END OF TSOLVE - END
deleted file mode 100644 --- a/libcruft/qpsol/v2norm.f +++ /dev/null @@ -1,72 +0,0 @@ - DOUBLE PRECISION FUNCTION V2NORM( N, X, LENX, INCX ) -C - INTEGER N, LENX, INCX - DOUBLE PRECISION X(LENX) -C - DOUBLE PRECISION WMACH - COMMON /SOLMCH/ WMACH(15) -C -C ********************************************************************* -C V2NORM RETURNS THE EUCLIDEAN NORM OF THE VECTOR X. -C THE NORM IS COMPUTED BY A ONE-PASS METHOD (DUE TO SVEN HAMMARLING) -C THAT GUARDS AGAINST OVERFLOW AND (OPTIONALLY) UNDERFLOW. -C -C SYSTEMS OPTIMIZATION LABORATORY, STANFORD UNIVERSITY. -C VERSION OF NOVEMBER 1981. -C ********************************************************************* -C - INTEGER I, IX - DOUBLE PRECISION ABSXI, FLMAX, ONE, Q, RTMIN, SCALE, SQROOT, - * SUMSQ, UNDFLW, ZERO - DOUBLE PRECISION DSQRT - DOUBLE PRECISION DABS - DATA ZERO, ONE/0.0D+0, 1.0D+0/ -C - V2NORM = ZERO - IF (N .LT. 1) RETURN - RTMIN = WMACH(6) - FLMAX = WMACH(7) - UNDFLW = WMACH(9) -C - IX = 1 - SCALE = ZERO - SUMSQ = ONE - IF (UNDFLW .GT. ZERO) GO TO 130 -C -C NO CHECK FOR UNDERFLOW. -C - DO 120 I = 1, N - ABSXI = DABS( X(IX) ) - IF (ABSXI .EQ. ZERO) GO TO 110 - IF (SCALE .GE. ABSXI) GO TO 100 - SUMSQ = ONE + SUMSQ*(SCALE/ABSXI)**2 - SCALE = ABSXI - GO TO 110 - 100 SUMSQ = SUMSQ + (ABSXI/SCALE)**2 - 110 IX = IX + INCX - 120 CONTINUE - GO TO 170 -C -C CHECK FOR UNNECESSARY UNDERFLOWS. -C - 130 DO 160 I = 1, N - ABSXI = DABS( X(IX) ) - IF (ABSXI .EQ. ZERO) GO TO 150 - Q = ZERO - IF (SCALE .LT. ABSXI) GO TO 140 - IF (SCALE .GT. RTMIN) Q = SCALE*RTMIN - IF (ABSXI .GE. Q) SUMSQ = SUMSQ + (ABSXI/SCALE)**2 - GO TO 150 - 140 IF (ABSXI .GT. RTMIN) Q = ABSXI*RTMIN - IF (SCALE .GE. Q) SUMSQ = ONE + SUMSQ*(SCALE/ABSXI)**2 - SCALE = ABSXI - 150 IX = IX + INCX - 160 CONTINUE -C - 170 SQROOT = DSQRT( SUMSQ ) - V2NORM = FLMAX - IF (SCALE .LT. FLMAX/SQROOT) V2NORM = SCALE*SQROOT - RETURN -C -C END OF V2NORM - END
deleted file mode 100644 --- a/libcruft/qpsol/zerovc.f +++ /dev/null @@ -1,28 +0,0 @@ - SUBROUTINE ZEROVC( N, X, LENX, INCX ) -C - INTEGER N, LENX, INCX - DOUBLE PRECISION X(LENX) -C -C SET X TO ZERO. -C - INTEGER I, IX - DOUBLE PRECISION ZERO -C - DATA ZERO/0.0D+0/ -C - IF (N .LT. 1) RETURN - IF (INCX .EQ. 1) GO TO 50 - IX = 1 - DO 10 I = 1, N - X(IX) = ZERO - IX = IX + INCX - 10 CONTINUE - RETURN -C - 50 DO 60 I = 1, N - X(I) = ZERO - 60 CONTINUE - RETURN -C -C END OF ZEROVC - END
deleted file mode 100644 --- a/libcruft/qpsol/zyprod.f +++ /dev/null @@ -1,138 +0,0 @@ - SUBROUTINE ZYPROD( MODE, N, NACTIV, NCOLZ, NFREE, NQ, UNITQ, - * KACTIV, KFREE, V, ZY, WRK ) -C -C IMPLICIT REAL*8(A-H,O-Z) - LOGICAL UNITQ - INTEGER MODE, N, NACTIV, NCOLZ, NFREE, NQ - INTEGER KACTIV(N), KFREE(N) - DOUBLE PRECISION V(N), ZY(NQ,NQ), WRK(N) -C -C ********************************************************************* -C ZYPROD TRANSFORMS THE VECTOR V IN VARIOUS WAYS USING THE -C MATRIX Q = ( Z Y ) DEFINED BY THE INPUT PARAMETERS. -C -C MODE RESULT -C ---- ------ -C -C 1 V = Z*V -C 2 V = Y*V -C 3 V = Q*V (NOT YET USED) -C -C ON INPUT, V IS ASSUMED TO BE ORDERED AS ( V(FREE) V(FIXED) ). -C ON OUTPUT, V IS A FULL N-VECTOR. -C -C -C 4 V = Z(T)*V -C 5 V = Y(T)*V -C 6 V = Q(T)*V -C -C ON INPUT, V IS A FULL N-VECTOR. -C ON OUTPUT, V IS ORDERED AS ( V(FREE) V(FIXED) ). -C -C 7 V = Y(T)*V -C 8 V = Q(T)*V -C -C ON INPUT, V IS A FULL N-VECTOR. -C ON OUTPUT, V IS AS IN MODES 5 AND 6 EXCEPT THAT V(FIXED) IS NOT SET. -C -C BEWARE THAT NCOLZ WILL SOMETIMES BE NCOLR. -C ALSO, MODES 1, 4, 7 AND 8 DO NOT INVOLVE V(FIXED). -C NACTIV AND THE ARRAY KACTIV ARE NOT USED FOR THOSE CASES. -C ORIGINAL VERSION APRIL 1983. MODES 7 AND 8 ADDED APRIL 1984. -C ********************************************************************* -C - INTEGER J, J1, J2, K, KA, KW, L, LENV, NFIXED - DOUBLE PRECISION ZERO - DOUBLE PRECISION DOT - DATA ZERO /0.0D+0/ -C - NFIXED = N - NFREE - J1 = 1 - J2 = NFREE - IF (MODE .EQ. 1 .OR. MODE .EQ. 4) J2 = NCOLZ - IF (MODE .EQ. 2 .OR. MODE .EQ. 5 .OR. MODE .EQ. 7) - *J1 = NCOLZ + 1 - LENV = J2 - J1 + 1 - IF (MODE .GE. 4) GO TO 400 -C -C --------------------------------------------------------------------- -C MODE = 1, 2 OR 3. -C --------------------------------------------------------------------- - IF (NFREE .GT. 0) CALL ZEROVC( NFREE, WRK, NFREE, 1 ) -C -C COPY V(FIXED) INTO THE END OF WRK. -C - IF (MODE .EQ. 1 .OR. NFIXED .EQ. 0) GO TO 100 - CALL COPYVC( NFIXED, V(NFREE+1), NFIXED, 1, - * WRK(NFREE+1), NFIXED, 1 ) -C -C SET WRK = RELEVANT PART OF ZY * V. -C - 100 IF (LENV .LE. 0) GO TO 200 - IF (UNITQ) CALL COPYVC( LENV, V(J1), LENV, 1, WRK(J1), LENV, 1 ) - IF (UNITQ) GO TO 200 - DO 120 J = J1, J2 - IF (V(J) .NE. ZERO) - * CALL AXPY( NFREE, V(J), ZY(1,J), NFREE, 1, WRK, NFREE, 1 ) - 120 CONTINUE -C -C EXPAND WRK INTO V AS A FULL N-VECTOR. -C - 200 CALL ZEROVC( N, V, N, 1 ) - IF (NFREE .EQ. 0) GO TO 300 - DO 220 K = 1, NFREE - J = KFREE(K) - V(J) = WRK(K) - 220 CONTINUE -C -C COPY WRK(FIXED) INTO THE APPROPRIATE PARTS OF V. -C - 300 IF (MODE .EQ. 1 .OR. NFIXED .EQ. 0) GO TO 900 - DO 320 L = 1, NFIXED - KW = NFREE + L - KA = NACTIV + L - J = KACTIV(KA) - V(J) = WRK(KW) - 320 CONTINUE - GO TO 900 -C -C --------------------------------------------------------------------- -C MODE = 4, 5, 6, 7 OR 8. -C --------------------------------------------------------------------- -C PUT THE FIXED COMPONENTS OF V INTO THE END OF WRK. -C - 400 IF (MODE .EQ. 4 .OR. MODE .GT. 6 .OR. NFIXED .EQ. 0) GO TO 500 - DO 420 L = 1, NFIXED - KW = NFREE + L - KA = NACTIV + L - J = KACTIV(KA) - WRK(KW) = V(J) - 420 CONTINUE -C -C PUT THE FREE COMPONENTS OF V INTO THE BEGINNING OF WRK. -C - 500 IF (NFREE .EQ. 0) GO TO 600 - DO 520 K = 1, NFREE - J = KFREE(K) - WRK(K) = V(J) - 520 CONTINUE -C -C SET V = RELEVANT PART OF ZY(T) * WRK. -C - IF (LENV .LE. 0) GO TO 600 - IF (UNITQ) CALL COPYVC( LENV, WRK(J1), LENV, 1, V(J1), LENV, 1 ) - IF (UNITQ) GO TO 600 - DO 540 J = J1, J2 - V(J) = DOT( NFREE, ZY(1,J), NFREE, 1, WRK, NFREE, 1 ) - 540 CONTINUE -C -C COPY THE FIXED COMPONENTS OF WRK INTO THE END OF V. -C - 600 IF (MODE .EQ. 4 .OR. MODE .GT. 6 .OR. NFIXED .EQ. 0) GO TO 900 - CALL COPYVC( NFIXED, WRK(NFREE+1), NFIXED, 1, - * V(NFREE+1), NFIXED, 1 ) -C - 900 RETURN -C -C END OF ZYPROD - END
--- a/octMakefile.in +++ b/octMakefile.in @@ -25,10 +25,10 @@ DISTFILES = $(CONF_DISTFILES) \ BUGS COPYING INSTALL INSTALL.OCTAVE NEWS NEWS.[0-9] PROJECTS \ - README README.Linux README.NLP README.Windows ROADMAP \ - SENDING-PATCHES THANKS move-if-change octave-sh octave-bug.in \ - install-octave mkinstalldirs mkoctfile.in texi2dvi INFO.PATCH \ - MAKEINFO.PATCH ChangeLog ChangeLog.[0-9] + README README.Linux README.Windows ROADMAP SENDING-PATCHES \ + THANKS INFO.PATCH move-if-change octave-sh octave-bug.in \ + install-octave mkinstalldirs mkoctfile.in texi2dvi \ + ChangeLog ChangeLog.[0-9] # Complete directory trees to distribute. DISTDIRS = glob kpathsea # plplot @@ -169,8 +169,6 @@ -o -name "=*" -o -name '*~' -o -name '#*#' -o -name config.log \ -o -name config.status -o -name c-auto.h \) -print | xargs rm -rf rm -f `cat .fname`/test/octave.test/*.m - rm -rf `cat .fname`/test/octave.test/npsol - rm -rf `cat .fname`/test/octave.test/qpsol chmod -R a+rwX `cat .fname` tar cf `cat .fname`.tar `cat .fname` rm -rf `cat .fname` @@ -242,8 +240,6 @@ -o -name "=*" -o -name '*~' -o -name '#*#' -o -name Makefile \ -o -name c-auto.h \) -print | xargs rm -rf rm -f `cat .fname`/test/octave.test/*.m - rm -rf `cat .fname`/test/octave.test/npsol - rm -rf `cat .fname`/test/octave.test/qpsol chmod -R a+rw `cat .fname` find `cat .fname` \( -perm 766 -o -perm 676 -o -perm 667 \ -o -perm 776 -o -perm 677 -o -perm 767 \) -print | \
deleted file mode 100644 --- a/test/octave.test/npsol/npsol-1.m +++ /dev/null @@ -1,43 +0,0 @@ -# A test from Reklaitis, Ravindran and Ragsdell - -tol = 1.0e-5; - -x_opt = [1; 2]; - -phi_opt = 5; - -function phi = f (x) - phi = 6*x(1)/x(2) + x(2)/x(1)/x(1); -end - -function nlc = g (x) - nlc = x(1)*x(2) - 2; -end - -c = [1, 1]; - -x0 = [2; 2]; - -[x, phi, inform] = npsol (x0, 'f', 1, c, 100, 0, 'g', 0); - -info_bad = (inform != 0 && inform != 1 && inform != 6); -solution_bad = sum (abs (x - x_opt) > tol); -value_bad = sum (abs (phi - phi_opt) > tol); - -if (info_bad) - printf ("info bad\n"); -else - printf ("info good\n"); -endif - -if (solution_bad) - printf ("solution bad\n"); -else - printf ("solution good\n"); -endif - -if (value_bad) - printf ("value bad\n"); -else - printf ("value good\n"); -endif
deleted file mode 100644 --- a/test/octave.test/npsol/npsol-2.m +++ /dev/null @@ -1,37 +0,0 @@ -# Rosenbrock's famouns function: - -tol = 1.0e-5; - -x_opt = [1; 1]; - -phi_opt = 0.0; - -function obj = phi (x) - obj = 100 * (x(2) - x(1)^2)^2 + (1 - x(1))^2; -end - -x0 = [-1.2; 1]; - -[x, phi, inform] = npsol (x0, 'phi'); - -info_bad = (inform != 0 && inform != 1 && inform != 6); -solution_bad = sum (abs (x - x_opt) > tol); -value_bad = sum (abs (phi - phi_opt) > tol); - -if (info_bad) - printf ("info bad\n"); -else - printf ("info good\n"); -endif - -if (solution_bad) - printf ("solution bad\n"); -else - printf ("solution good\n"); -endif - -if (value_bad) - printf ("value bad\n"); -else - printf ("value good\n"); -endif